# Lisp-level sources built by 'make'.
*cus-load.el
*loaddefs.el
-lisp/cedet/semantic/bovine/c-by.el
-lisp/cedet/semantic/bovine/make-by.el
-lisp/cedet/semantic/bovine/scm-by.el
-lisp/cedet/semantic/wisent/javat-wy.el
-lisp/cedet/semantic/wisent/js-wy.el
-lisp/cedet/semantic/wisent/python-wy.el
-lisp/cedet/srecode/srt-wy.el
-lisp/cedet/semantic/grammar-wy.el
lisp/eshell/esh-module-loaddefs.el
lisp/finder-inf.el
lisp/leim/ja-dic/
rm -f config.cache config.status config.log~ \
Makefile makefile lib/gnulib.mk ${SUBDIR_MAKEFILES}
-distclean_dirs = $(clean_dirs) leim lisp admin/grammars
+distclean_dirs = $(clean_dirs) leim lisp
$(foreach dir,$(distclean_dirs),$(eval $(call submake_template,$(dir),distclean)))
places, they are trivial for copyright
purposes.
codespell supporting files for the run-codespell script.
-grammars wisent and bovine grammars, used to produce
- files in lisp/cedet/.
notes miscellaneous notes related to administrative
tasks.
nt support files for administrative tasks related
;; characters cannot be loaded twice ("Category `a' is already defined").
'("play/dunnet.el" "emulation/edt-mapper.el"
"loadup.el" "mail/blessmail.el" "international/characters.el"
- "cedet/ede/loaddefs.el" "cedet/semantic/loaddefs.el"
"net/tramp-loaddefs.el")
"List of files not to load by `cus-test-load-libs'.
Names should be as they appear in loaddefs.el.")
+++ /dev/null
-### @configure_input@
-
-## Copyright (C) 2013-2024 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 <https://www.gnu.org/licenses/>.
-
-### Commentary:
-
-## This directory contains grammar files in Bison and Wisent,
-## used to generate the parser data in the lisp/cedet directory.
-
-SHELL = @SHELL@
-
-srcdir = @srcdir@
-top_srcdir = @top_srcdir@
-top_builddir = @top_builddir@
-
--include ${top_builddir}/src/verbose.mk
-
-# Prevent any settings in the user environment causing problems.
-unexport EMACSDATA EMACSDOC EMACSLOADPATH EMACSPATH
-
-EMACS = ${top_builddir}/src/emacs
-emacs = "${EMACS}" -batch --no-site-file --no-site-lisp \
- --eval '(setq load-prefer-newer t)'
-
-make_bovine = ${emacs} -l semantic/bovine/grammar -f bovine-batch-make-parser
-make_wisent = ${emacs} -l semantic/wisent/grammar -f wisent-batch-make-parser
-
-cedetdir = ${top_srcdir}/lisp/cedet
-bovinedir = ${cedetdir}/semantic/bovine
-wisentdir = ${cedetdir}/semantic/wisent
-
-grammar_bovine = ${bovinedir}/grammar.el
-grammar_wisent = ${wisentdir}/grammar.el
-
-BOVINE = \
- ${bovinedir}/c-by.el \
- ${bovinedir}/make-by.el \
- ${bovinedir}/scm-by.el
-
-WISENT = \
- ${cedetdir}/semantic/grammar-wy.el \
- ${wisentdir}/javat-wy.el \
- ${wisentdir}/js-wy.el \
- ${wisentdir}/python-wy.el \
- ${cedetdir}/srecode/srt-wy.el
-
-ALL = ${BOVINE} ${WISENT}
-
-.PHONY: all bovine wisent
-
-all: ${ALL}
-
-bovine: ${BOVINE}
-
-wisent: ${WISENT}
-
-## c-by.el, make-by.el.
-${bovinedir}/%-by.el: ${srcdir}/%.by ${grammar_bovine}
- $(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
- $(AM_V_at)${make_bovine} -o "$@" $<
-
-${bovinedir}/scm-by.el: ${srcdir}/scheme.by ${grammar_bovine}
- $(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
- $(AM_V_at)${make_bovine} -o "$@" $<
-
-## grammar-wy.el
-${cedetdir}/semantic/%-wy.el: ${srcdir}/%.wy ${grammar_wisent}
- $(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
- $(AM_V_at)${make_wisent} -o "$@" $<
-
-## js-wy.el, python-wy.el
-${wisentdir}/%-wy.el: ${srcdir}/%.wy ${grammar_wisent}
- $(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
- $(AM_V_at)${make_wisent} -o "$@" $<
-
-${wisentdir}/javat-wy.el: ${srcdir}/java-tags.wy ${grammar_wisent}
- $(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
- $(AM_V_at)${make_wisent} -o "$@" $<
-
-${cedetdir}/srecode/srt-wy.el: ${srcdir}/srecode-template.wy ${grammar_wisent}
- $(AM_V_GEN)[ ! -f "$@" ] || chmod +w "$@"
- $(AM_V_at)${make_wisent} -o "$@" $<
-
-.PHONY: distclean bootstrap-clean maintainer-clean gen-clean
-
-distclean:
- rm -f Makefile
-
-## IMO this should run gen-clean.
-bootstrap-clean:
-
-gen-clean:
- rm -f ${ALL}
-
-maintainer-clean: gen-clean distclean
-
-
-
-# Makefile.in ends here
+++ /dev/null
-;;; c.by -- LL grammar for C/C++ language specification
-;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
-;;
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; David Ponce <david@dponce.com>
-;; Klaus Berndl <klaus.berndl@sdm.de>
-;;
-;; 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 <https://www.gnu.org/licenses/>.
-
-;; TODO: From Nate Schley
-;; > * Can't parse signature element: "const char* const rmc_ClrTxt"
-;; > * Can't parse signature element: "char* const dellog_ClrTxt"
-;; > * Can't parse signature element: "const char* dellog_SetTxt"
-;; > * Can't parse signature element: "const RmcCmdSSPADetailedStatus& status"
-;; >
-;; > And FWIW I have seen the following argument cases not handled, even
-;; > with no leading/trailing spaces in the split:
-;; >
-;; > * Can't parse signature element: "const bool currentAlarmStatus"
-;; > * Can't parse signature element: "unsigned char mode"
-;; > * Can't parse signature element: "TskTimingTask* tsktimingtask"
-;; > * Can't parse signature element: "unsigned char htrStatus"
-;; > * Can't parse signature element: "char trackPower[]"
-;; > * Can't parse signature element: "const RmcCmdMCDetailedStatus& status"
-;; > * Can't parse signature element: "RmcBucStatus* rftBucStatus"
-
-%package semantic-c-by
-%provide semantic/bovine/c-by
-
-%{
-(declare-function semantic-c-reconstitute-token "semantic/bovine/c"
- (tokenpart declmods typedecl))
-(declare-function semantic-c-reconstitute-template "semantic/bovine/c"
- (tag specifier))
-(declare-function semantic-expand-c-tag "semantic/bovine/c" (tag))
-(declare-function semantic-parse-region "semantic"
- (start end &optional nonterminal depth returnonerror))
-}
-
-%languagemode c-mode c++-mode
-%start declaration
-%scopestart codeblock
-
-%token <punctuation> HASH "\\`[#]\\'"
-%token <punctuation> PERIOD "\\`[.]\\'"
-%token <punctuation> COLON "\\`[:]\\'"
-%token <punctuation> SEMICOLON "\\`[;]\\'"
-%token <punctuation> STAR "\\`[*]\\'"
-%token <punctuation> AMPERSAND "\\`[&]\\'"
-%token <punctuation> DIVIDE "\\`[/]\\'"
-%token <punctuation> PLUS "\\`[+]\\'"
-%token <punctuation> MINUS "\\`[-]\\'"
-%token <punctuation> BANG "\\`[!]\\'"
-%token <punctuation> QUESTION "\\`[?]\\'"
-%token <punctuation> EQUAL "\\`[=]\\'"
-%token <punctuation> LESS "\\`[<]\\'"
-%token <punctuation> GREATER "\\`[>]\\'"
-%token <punctuation> COMA "\\`[,]\\'"
-%token <punctuation> TILDE "\\`[~]\\'"
-%token <punctuation> MOD "\\`[%]\\'"
-%token <punctuation> HAT "\\`\\^\\'"
-%token <punctuation> OR "\\`[|]\\'"
-%token <string> C "\"C\""
-%token <string> CPP "\"C\\+\\+\""
-%token <number> ZERO "^0$"
-%token <symbol> RESTRICT "\\<\\(__\\)?restrict\\>"
-%token <open-paren> LPAREN "("
-%token <close-paren> RPAREN ")"
-%token <open-paren> LBRACE "{"
-%token <close-paren> RBRACE "}"
-%token <semantic-list> BRACK_BLCK "\\[.*\\]$"
-%token <semantic-list> PAREN_BLCK "^("
-%token <semantic-list> BRACE_BLCK "^{"
-%token <semantic-list> VOID_BLCK "^(void)$"
-%token <semantic-list> PARENS "()"
-%token <semantic-list> BRACKETS "\\[\\]"
-
-%token EXTERN "extern"
-%put EXTERN summary "Declaration Modifier: extern <type> <name> ..."
-%token STATIC "static"
-%put STATIC summary "Declaration Modifier: static <type> <name> ..."
-%token CONST "const"
-%put CONST summary "Declaration Modifier: const <type> <name> ..."
-%token VOLATILE "volatile"
-%put VOLATILE summary "Declaration Modifier: volatile <type> <name> ..."
-%token REGISTER "register"
-%put REGISTER summary "Declaration Modifier: register <type> <name> ..."
-%token SIGNED "signed"
-%put SIGNED summary "Numeric Type Modifier: signed <numeric type> <name> ..."
-%token UNSIGNED "unsigned"
-%put UNSIGNED summary "Numeric Type Modifier: unsigned <numeric type> <name> ..."
-
-%token INLINE "inline"
-%put INLINE summary "Function Modifier: inline <return type> <name>(...) {...};"
-%token VIRTUAL "virtual"
-%put VIRTUAL summary "Method Modifier: virtual <type> <name>(...) ..."
-%token MUTABLE "mutable"
-%put MUTABLE summary "Member Declaration Modifier: mutable <type> <name> ..."
-%token EXPLICIT "explicit"
-%put EXPLICIT summary "Forbids implicit type conversion: explicit <constructor>"
-
-%token STRUCT "struct"
-%put STRUCT summary "Structure Type Declaration: struct [name] { ... };"
-%token UNION "union"
-%put UNION summary "Union Type Declaration: union [name] { ... };"
-%token ENUM "enum"
-%put ENUM summary "Enumeration Type Declaration: enum [name] { ... };"
-%token TYPEDEF "typedef"
-%put TYPEDEF summary "Arbitrary Type Declaration: typedef <typedeclaration> <name>;"
-%token CLASS "class"
-%put CLASS summary "Class Declaration: class <name>[:parents] { ... };"
-%token TYPENAME "typename"
-%put TYPENAME summary "typename is used to handle a qualified name as a typename;"
-%token NAMESPACE "namespace"
-%put NAMESPACE summary "Namespace Declaration: namespace <name> { ... };"
-%token USING "using"
-%put USING summary "using <namespace>;"
-
-%token NEW "new"
-%put NEW summary "new <classname>();"
-%token DELETE "delete"
-%put DELETE summary "delete <object>;"
-
-;; Despite this, this parser can find templates by ignoring the TEMPLATE
-;; keyword, and finding the class/method being templatized.
-%token TEMPLATE "template"
-%put TEMPLATE summary "template <class TYPE ...> TYPE_OR_FUNCTION"
-
-%token THROW "throw"
-%put THROW summary "<type> <methoddef> (<method args>) throw (<exception>) ..."
-%token REENTRANT "reentrant"
-%put REENTRANT summary "<type> <methoddef> (<method args>) reentrant ..."
-%token TRY "try"
-%token CATCH "catch"
-%put { TRY CATCH } summary "try { <body> } catch { <catch code> }"
-
-;; Leave these alone for now.
-%token OPERATOR "operator"
-%token PUBLIC "public"
-%token PRIVATE "private"
-%token PROTECTED "protected"
-%token FRIEND "friend"
-%put FRIEND summary "friend class <CLASSNAME>"
-
-;; These aren't used for parsing, but is a useful place to describe the keywords.
-%token IF "if"
-%token ELSE "else"
-%put {IF ELSE} summary "if (<condition>) { code } [ else { code } ]"
-
-%token DO "do"
-%token WHILE "while"
-%put DO summary " do { code } while (<condition>);"
-%put WHILE summary "do { code } while (<condition>); or while (<condition>) { code };"
-
-%token FOR "for"
-%put FOR summary "for(<init>; <condition>; <increment>) { code }"
-
-%token SWITCH "switch"
-%token CASE "case"
-%token DEFAULT "default"
-%put {SWITCH CASE DEFAULT} summary
-"switch (<variable>) { case <constvalue>: code; ... default: code; }"
-
-%token RETURN "return"
-%put RETURN summary "return <value>;"
-
-%token BREAK "break"
-%put BREAK summary "Non-local exit within a loop or switch (for, do/while, switch): break;"
-%token CONTINUE "continue"
-%put CONTINUE summary "Non-local continue within a loop (for, do/while): continue;"
-
-%token SIZEOF "sizeof"
-%put SIZEOF summary "Compile time macro: sizeof(<type or variable>) // size in bytes"
-
-;; Types
-%token VOID "void"
-%put VOID summary "Built in type: void"
-%token CHAR "char"
-%put CHAR summary "Integral Character Type: (0 to 256)"
-%token WCHAR "wchar_t"
-%put WCHAR summary "Wide Character Type"
-%token SHORT "short"
-%put SHORT summary "Integral Primitive Type: (-32768 to 32767)"
-%token INT "int"
-%put INT summary "Integral Primitive Type: (-2147483648 to 2147483647)"
-%token LONG "long"
-%put LONG summary "Integral primitive type (-9223372036854775808 to 9223372036854775807)"
-%token FLOAT "float"
-%put FLOAT summary "Primitive floating-point type (single-precision 32-bit IEEE 754)"
-%token DOUBLE "double"
-%put DOUBLE summary "Primitive floating-point type (double-precision 64-bit IEEE 754)"
-%token BOOL "bool"
-%put BOOL summary "Primitive boolean type"
-
-%token UNDERP "_P"
-%token UNDERUNDERP "__P"
-%put UNDERP summary "Common macro to eliminate prototype compatibility on some compilers"
-%put UNDERUNDERP summary "Common macro to eliminate prototype compatibility on some compilers"
-
-%%
-
-declaration
- : macro
- | type
- ;; TODO: Klaus Berndl: Is the define here necessary or even wrong?
- ;; Is this part not already covered by macro??
- | define
- | var-or-fun
- | extern-c
- | template
- | using
- ;
-
-codeblock
- : define
- | codeblock-var-or-fun
- | type ;; type is less likely to be used here.
- | using
- ;
-
-extern-c-contents
- : open-paren
- ( nil )
- | declaration
- | close-paren
- ( nil )
- ;
-
-extern-c
- : EXTERN C semantic-list
- ;; Extern C commands which contain a list need to have the
- ;; entries of the list extracted, and spliced into the main
- ;; list of entries. This must be done via the function
- ;; that expands singular nonterminals, such as int x,y;
- (TAG "C" 'extern :members (EXPANDFULL $3 extern-c-contents) )
- | EXTERN CPP semantic-list
- (TAG "C" 'extern :members (EXPANDFULL $3 extern-c-contents) )
- | EXTERN C
- ;; A plain extern "C" call should add something to the token,
- ;; but just strip it from the buffer here for now.
- ( nil )
- | EXTERN CPP
- ( nil )
- ;
-
-macro
- : spp-macro-def
- (VARIABLE-TAG $1 nil nil :constant-flag t )
- | spp-system-include
- (INCLUDE-TAG $1 t)
- | spp-include
- (INCLUDE-TAG $1 nil)
- ;
-
-;; This is used in struct parts.
-define
- : spp-macro-def
- (VARIABLE-TAG $1 nil nil :constant-flag t)
- | spp-macro-undef
- ( nil )
- ;
-
-;; In C++, structures can have the same things as classes.
-;; So delete this some day in the figure.
-;;
-;;structparts : semantic-list
-;; (EXPANDFULL $1 structsubparts)
-;; ;
-;;
-;;structsubparts : LBRACE
-;; ( nil )
-;; | RBRACE
-;; ( nil )
-;; | var-or-fun
-;; | define
-;; ;; sometimes there are defines in structs.
-;; ;
-
-unionparts
- : semantic-list
- (EXPANDFULL $1 classsubparts)
- ;
-
-opt-symbol
- : symbol
- | ;;EMPTY
- ;
-
-;; @todo - support 'friend' construct.
-classsubparts
- : LBRACE
- ( nil )
- | RBRACE
- ( nil )
- | class-protection opt-symbol COLON
- ;; For QT, they may put a `slot' keyword between the protection
- ;; and the COLON. @todo - Have the QT stuff use macros.
- (TAG (car $1) 'label)
- | var-or-fun
- | FRIEND func-decl
- (TAG (car $2) 'friend)
- | FRIEND CLASS symbol
- (TAG $3 'friend)
- | type
- | define
- | template
- | ;;EMPTY
- ;
-
-opt-class-parents
- : COLON class-parents opt-template-specifier
- ( $2 )
- | ;;EMPTY
- ( )
- ;
-
-one-class-parent
- : opt-class-protection opt-class-declmods namespace-symbol
- (TYPE-TAG (car $3) "class" nil nil :protection (car $1))
- | opt-class-declmods opt-class-protection namespace-symbol
- (TYPE-TAG (car $3) "class" nil nil :protection (car $2))
- ;
-
-class-parents
- : one-class-parent COMA class-parents
- ( ,(cons ,$1 $3 ) )
- | one-class-parent
- ( $1 )
- ;
-
-opt-class-declmods
- : class-declmods opt-class-declmods
- ( nil )
- | ;;EMPTY
- ;
-
-class-declmods
- : VIRTUAL
- ;
-
-class-protection
- : PUBLIC
- | PRIVATE
- | PROTECTED
- ;
-
-opt-class-protection
- : class-protection
- ( ,$1 )
- | ;;EMPTY - Same as private
- ( "unspecified" )
- ;
-
-namespaceparts
- : semantic-list
- (EXPANDFULL $1 namespacesubparts)
- ;
-
-namespacesubparts
- : LBRACE
- ( nil )
- | RBRACE
- ( nil )
- | type
- | var-or-fun
- | define
- | class-protection COLON
- (TAG (car $1) 'label)
- ;; In C++, this label in a classsubpart represents
- ;; PUBLIC or PRIVATE bits. Ignore them for now.
- | template
- | using
- ;; Includes inside namespaces
- | spp-include
- (TAG $1 'include :inside-ns t)
- | ;;EMPTY
- ;
-
-enumparts
- : semantic-list
- (EXPANDFULL $1 enumsubparts)
- ;
-
-enumsubparts
- : symbol opt-assign
- (VARIABLE-TAG $1 "int" (car $2) :constant-flag t )
- | LBRACE
- ( nil )
- | RBRACE
- ( nil )
- | COMA
- ( nil )
- ;
-
-opt-name
- : symbol
- | ;;EMPTY
- ( "" )
- ;
-
-typesimple
- : struct-or-class opt-class opt-name opt-template-specifier
- opt-class-parents semantic-list
- (TYPE-TAG (car $3) (car $1)
- (dlet ((semantic-c-classname (cons (car ,$3) (car ,$1))))
- (EXPANDFULL $6 classsubparts))
- $5
- :template-specifier $4
- :parent (car ,$2))
- | struct-or-class opt-class opt-name opt-template-specifier
- opt-class-parents
- (TYPE-TAG (car $3) (car $1) nil $5
- :template-specifier $4
- :prototype t
- :parent (car ,$2))
- | UNION opt-class opt-name unionparts
- (TYPE-TAG (car $3) $1 $4 nil
- :parent (car ,$2))
- | ENUM opt-class opt-name enumparts
- (TYPE-TAG (car $3) $1 $4 nil
- :parent (car ,$2))
- ;; Klaus Berndl: a typedef can be a typeformbase with all this
- ;; declmods stuff.
- | TYPEDEF declmods typeformbase cv-declmods typedef-symbol-list
- ;;;; We put the type this typedef renames into PARENT
- ;;;; but will move it in the expand function.
- (TYPE-TAG $5 $1 nil (list $3) )
- ;
-
-typedef-symbol-list
- : typedefname COMA typedef-symbol-list
- ( ,(cons $1 $3) )
- | typedefname
- ( $1 )
- ;
-
-;; TODO: Klaus Berndl: symbol -> namespace-symbol?! Answer: Probably
-;; symbol is correct here!
-typedefname
- : opt-stars symbol opt-bits opt-array
- ( $1 $2 )
- ;
-
-struct-or-class
- : STRUCT
- | CLASS
- ;
-
-type
- : typesimple SEMICOLON
- ( ,$1 )
- ;; named namespaces like "namespace XXX {"
- | NAMESPACE symbol namespaceparts
- (TYPE-TAG $2 $1 $3 nil )
- ;; unnamed namespaces like "namespace {"
- | NAMESPACE namespaceparts
- (TYPE-TAG "unnamed" $1 $2 nil )
- ;; David Engster: namespace alias like "namespace foo = bar;"
- | NAMESPACE symbol EQUAL typeformbase SEMICOLON
- (TYPE-TAG $2 $1 (list (TYPE-TAG (car $4) $1 nil nil)) nil :kind 'alias )
- ;
-
-;; Klaus Berndl: We must parse "using namespace XXX" too
-
-;; Using is vaguely like an include statement in the named portions
-;; of the code. We should probably specify a new token type for this.
-
-using
- : USING usingname SEMICOLON
- (TAG (car $2) 'using :type ,$2 )
- ;
-
-;; Jan Moringen: Differentiate between 'using' and 'using namespace'
-;; Adapted to creating type tags by EML.
-usingname
- : typeformbase
- (TYPE-TAG (car $1) "class" nil nil :prototype t)
- | NAMESPACE typeformbase
- (TYPE-TAG (car $2) "namespace" nil nil :prototype t)
- ;
-
-template
- : TEMPLATE template-specifier opt-friend template-definition
- ( ,(semantic-c-reconstitute-template $4 ,$2) )
- ;
-
-opt-friend
- : FRIEND
- | ;;EMPTY
- ;
-
-opt-template-specifier
- : template-specifier
- ( ,$1 )
- | ;;EMPTY
- ( )
- ;
-
-template-specifier
- : LESS template-specifier-types GREATER
- ( ,$2 )
- ;
-
-template-specifier-types
- : template-var template-specifier-type-list
- ( ,(cons ,$1 ,$2 ) )
- | ;;EMPTY
- ;
-
-template-specifier-type-list
- : COMA template-specifier-types
- ( ,$2 )
- | ;;EMPTY
- ( )
- ;
-
-;; template-var
-;; : template-type opt-stars opt-template-equal
-;; ( ,(cons (concat (car $1) (make-string (car ,$2) ?*))
-;; (cdr $1)))
-;; ;; Klaus Berndl: for template-types the template-var can also be
-;; ;; literals or constants. Example: map<ClassX, ClassY, 10>
-;; ;; map_size10_var; This parses also template<class T, 0> which is
-;; ;; nonsense but who cares....
-;; | string
-;; ( $1 )
-;; | number
-;; ( $1 )
-;; ;
-
-template-var
- :
- ;; Klaus Berndl: The following handles all template-vars of
- ;; template-definitions
- template-type opt-template-equal
- ( ,(cons (car $1) (cdr $1)) )
- ;; Klaus Berndl: for template-types the template-var can also be
- ;; literals or constants.
- ;; Example: map<ClassX, ClassY, 10> map_size10_var; This parses also
- ;; template<class T, 0> which is nonsense but who cares....
- | string
- ( $1 )
- | number
- ( $1 )
- ;; Klaus Berndl: In template-types arguments can be any symbols with
- ;; optional address-operator (&) and optional dereferencing operator
- ;; (*). Example map<ClassX, ClassY, *size_var_ptr> sized_map_var.
- | opt-stars opt-ref namespace-symbol
- ( ,$3 )
- ;; Some code can compile down into a number, but starts out as an
- ;; expression, such as "sizeof(a)", or (sizeof(a)/sizeof(b))
- | semantic-list
- ( $1 )
- | SIZEOF semantic-list
- ( $2 )
- ;
-
-opt-template-equal
- : EQUAL symbol LESS template-specifier-types GREATER
- ( $2 )
- | EQUAL symbol
- ( $2 )
- | ;;EMPTY
- ( )
- ;
-
-template-type
- : CLASS symbol
- (TYPE-TAG $2 "class" nil nil )
- | STRUCT symbol
- (TYPE-TAG $2 "struct" nil nil )
- ;; TODO: Klaus Berndl: For the moment it is ok, that we parse the C++
- ;; keyword typename as a class....
- | TYPENAME symbol
- (TYPE-TAG $2 "class" nil nil)
- ;; Klaus Berndl: template-types can be all flavors of variable-args
- ;; but here the argument is ignored, only the type stuff is needed.
- | declmods typeformbase cv-declmods opt-stars
- opt-ref variablearg-opt-name
- (TYPE-TAG (car $2) nil nil nil
- :template-specifier (plist-get (nth 2 $2) :template-specifier)
- :constant-flag (if (member "const" (append $1 $3)) t nil)
- :typemodifiers (delete "const" (append $1 $3))
- :reference (car ,$5)
- :pointer (car $4)
- :typevar (car $6)
- )
- ;
-
-template-definition
- : type
- ( ,$1 )
- | var-or-fun
- ( ,$1 )
- ;
-
-opt-stars
- : STAR opt-starmod opt-stars
- ( (1+ (car $3)) )
- | ;;EMPTY
- ( 0 )
- ;
-
-opt-starmod
- : STARMOD opt-starmod
- ( ,(cons (,car ,$1) $2) )
- | ;;EMPTY
- ()
- ;
-
-STARMOD
- : CONST
- ;
-
-declmods
- : DECLMOD declmods
- ( ,(cons ,(car ,$1) $2 ) )
- | DECLMOD
- ( ,$1 )
- | ;;EMPTY
- ()
- ;
-
-DECLMOD
- : EXTERN
- | STATIC
- | CVDECLMOD
- ;; Klaus Berndl: IMHO signed and unsigned are not decl-modes but
- ;; these are only valid for some buildin-types like short, int
- ;; etc... whereas "real" declmods are valid for all types, buildin
- ;; and user-defined! SIGNED UNSIGNED
- | INLINE
- | REGISTER
- | FRIEND
- ;; Klaus Berndl: There can be a few cases where TYPENAME is not
- ;; allowed in C++-syntax but better than not recognizing the allowed
- ;; situations.
- | TYPENAME
- | METADECLMOD
- ;; This is a hack in case we are in a class.
- | VIRTUAL
- ;
-
-metadeclmod
- : METADECLMOD
- ()
- | ;;EMPTY
- ()
- ;
-
-CVDECLMOD
- : CONST
- | VOLATILE
- ;
-
-cv-declmods
- : CVDECLMOD cv-declmods
- ( ,(cons ,(car ,$1) $2 ) )
- | CVDECLMOD
- ( ,$1 )
- | ;;EMPTY
- ()
- ;
-
-METADECLMOD
- : VIRTUAL
- | MUTABLE
- ;
-
-;; C++: A type can be modified into a reference by "&"
-opt-ref
- : AMPERSAND
- ( 1 )
- | ;;EMPTY
- ( 0 )
- ;
-
-typeformbase
- : typesimple
- ( ,$1 )
- | STRUCT symbol
- (TYPE-TAG $2 $1 nil nil )
- | UNION symbol
- (TYPE-TAG $2 $1 nil nil )
- | ENUM symbol
- (TYPE-TAG $2 $1 nil nil )
- | builtintype
- ( ,$1 )
- | symbol template-specifier
- (TYPE-TAG $1 "class" nil nil :template-specifier $2)
- ;;| namespace-symbol opt-stars opt-template-specifier
- ;;| namespace-symbol opt-template-specifier
- | namespace-symbol-for-typeformbase opt-template-specifier
- (TYPE-TAG (car $1) "class" nil nil
- :template-specifier $2)
- | symbol
- ( $1 )
- ;
-
-signedmod
- : UNSIGNED
- | SIGNED
- ;
-
-;; Klaus Berndl: builtintype-types was builtintype
-builtintype-types
- : VOID
- | CHAR
- ;; Klaus Berndl: Added WCHAR
- | WCHAR
- | SHORT INT
- ( (concat $1 " " $2) )
- | SHORT
- | INT
- | LONG INT
- ( (concat $1 " " $2) )
- | FLOAT
- | DOUBLE
- | BOOL
- | LONG DOUBLE
- ( (concat $1 " " $2) )
- ;; TODO: Klaus Berndl: Is there a long long, i think so?!
- | LONG LONG
- ( (concat $1 " " $2) )
- | LONG
- ;
-
-builtintype
- : signedmod builtintype-types
- ( (concat (car $1) " " (car $2)) )
- | builtintype-types
- ( ,$1 )
- ;; Klaus Berndl: unsigned is synonym for unsigned int and signed for
- ;; signed int. To make this confusing stuff clear we add here the
- ;; int.
- | signedmod
- ( (concat (car $1) " int") )
- ;
-
-;; Klaus Berndl: This parses also nonsense like "const volatile int
-;; const volatile const const volatile a ..." but IMHO nobody writes
-;; such code. Normally we should define a rule like typeformbase-mode
-;; which exactly defines the different allowed cases and combinations
-;; of declmods (minus the CVDECLMOD) typeformbase and cv-declmods so
-;; we could recognize more invalid code but IMHO this is not worth the
-;; effort...
-codeblock-var-or-fun
- : declmods typeformbase declmods
- opt-ref var-or-func-decl
- ( ,(semantic-c-reconstitute-token ,$5 $1 $2 ) )
- ;
-
-var-or-fun
- : codeblock-var-or-fun
- ( ,$1 )
- ;; it is possible for a function to not have a type, and
- ;; it is then assumed to be an int. How annoying.
- ;; In C++, this could be a constructor or a destructor.
- ;; Even more annoying. Only ever do this for regular
- ;; top-level items. Ignore this problem in code blocks
- ;; so that we don't have to deal with regular code
- ;; being erroneously converted into types.
- | declmods var-or-func-decl
- ( ,(semantic-c-reconstitute-token ,$2 $1 nil ) )
- ;
-
-var-or-func-decl
- : func-decl
- ( ,$1 )
- | var-decl
- ( ,$1 )
- ;
-
-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
- ( ,$4 'function
- ;; Extra stuff goes in here.
- ;; Continue with the stuff we found in
- ;; this definition
- $2 $3 $7 $9 $8 ,$1 ,$11 $5 ,$10)
- | opt-stars opt-class opt-destructor functionname
- opt-template-specifier
- opt-under-p
- ;; arg-list - - ini this case, a try implies a fcn.
- opt-post-fcn-modifiers
- opt-throw
- opt-initializers
- fun-try-end
- ( ,$4 'function
- ;; Extra stuff goes in here.
- ;; Continue with the stuff we found in
- ;; this definition
- $2 $3 nil $8 $7 ,$1 ,$10 $5 ,$9)
- ;
-
-var-decl
- : varnamelist SEMICOLON
- ( $1 'variable )
- ;
-
-opt-under-p
- : UNDERP
- ( nil )
- | UNDERUNDERP
- ( nil )
- | ;;EMPTY
- ;
-
-;; Klaus Berndl: symbol -> namespace-symbol
-opt-initializers
- : COLON namespace-symbol semantic-list opt-initializers
- | COMA namespace-symbol semantic-list opt-initializers
- | ;;EMPTY
- ;
-
-opt-post-fcn-modifiers
- : post-fcn-modifiers opt-post-fcn-modifiers
- ( ,(cons ,(car $1) $2) )
- | ;;EMPTY
- ( nil )
- ;
-
-post-fcn-modifiers
- : REENTRANT
- | CONST
- ;
-
-opt-throw
- : THROW semantic-list
- ( EXPAND $2 throw-exception-list )
- | ;;EMPTY
- ;
-
-;; Is this true? I don't actually know.
-throw-exception-list
- : namespace-symbol COMA throw-exception-list
- ( ,(cons (car $1) $3) )
- | namespace-symbol RPAREN
- ( ,$1 )
- | symbol RPAREN
- ( $1 )
- | LPAREN throw-exception-list
- ( ,$2 )
- | RPAREN
- ( )
- ;
-
-opt-bits
- : COLON number
- ( $2 )
- | ;;EMPTY
- ( nil )
- ;
-
-opt-array
- : BRACK_BLCK opt-array
- ;; Eventually we want to replace the 1 below with a size
- ;; (if available)
- ( (cons 1 (car ,$2) ) )
- | ;;EMPTY
- ( nil )
- ;
-
-opt-assign
- : EQUAL expression
- ( $2 )
- | ;;EMPTY
- ( nil )
- ;
-
-opt-restrict
- : RESTRICT
- | ;;EMPTY
- ;
-
-;; Klaus Berndl: symbol -> namespace-symbol?! I think so. Can be that
-;; then also some invalid C++-syntax is parsed but this is better than
-;; not parsing valid syntax.
-varname
- : opt-stars opt-restrict namespace-symbol opt-bits opt-array
- ( ,$3 ,$1 ,$4 ,$5 )
- ;
-
-;; I should store more in this def, but leave it simple for now.
-;; Klaus Berndl: const and volatile can be written after the type!
-variablearg
- : declmods typeformbase cv-declmods opt-ref variablearg-opt-name opt-assign
- ( VARIABLE-TAG (list (append $5 ,$6)) $2 nil
- :constant-flag (if (member "const" (append $1 $3)) t nil)
- :typemodifiers (delete "const" (append $1 $3))
- :reference (car ,$4)
- )
- ;
-
-variablearg-opt-name
- : varname
- ( ,$1 )
- | semantic-list arg-list
- ( (car ( EXPAND $1 function-pointer )) $2)
- ;; Klaus Berndl: This allows variableargs without an arg-name being
- ;; parsed correctly even if there several pointers (*)
- | opt-stars
- ( "" ,$1 nil nil nil )
- ;
-
-varname-opt-initializer
- : semantic-list
- | opt-assign
- | ;; EMPTY
- ;
-
-varnamelist
- : opt-ref varname varname-opt-initializer COMA varnamelist
- ( ,(cons (append $2 $3) $5) )
- | opt-ref varname varname-opt-initializer
- ( (append $2 $3) )
- ;
-
-;; Klaus Berndl: Is necessary to parse stuff like
-;; class list_of_facts : public list<fact>, public entity
-;; and
-;; list <shared_ptr<item> >::const_iterator l;
-;; Parses also invalid(?) and senseless(?) c++-syntax like
-;; symbol<template-spec>::symbol1<template-spec1>::test_iterator
-;; but better parsing too much than to less
-namespace-symbol
- : symbol opt-template-specifier COLON COLON namespace-symbol
- ( (concat $1 "::" (car $5)) )
- | symbol opt-template-specifier
- ( $1 )
- ;
-
-;; Don't pull an optional template specifier at the end of the
-;; namespace symbol so that it can be picked up by the type.
-namespace-symbol-for-typeformbase
- : symbol opt-template-specifier COLON COLON namespace-symbol-for-typeformbase
- ( (concat $1 "::" (car $5)) )
- | symbol
- ( $1 )
- ;
-;; namespace-symbol
-;; : symbol COLON COLON namespace-symbol
-;; ( (concat $1 "::" (car $4)) )
-;; | symbol
-;; ( $1 )
-;; ;
-
-namespace-opt-class
- : symbol COLON COLON namespace-opt-class
- ( (concat $1 "::" (car $4)) )
- ;; Klaus Berndl: We must recognize template-specifiers here so we can
- ;; parse correctly the method-implementations of template-classes
- ;; outside the template-class-declaration Example:
- ;; TemplateClass1<T>::method_1(...)
- | symbol opt-template-specifier COLON COLON
- ( $1 )
- ;
-
-;; Klaus Berndl: The opt-class of a func-decl must be able to
-;; recognize opt-classes with namespaces, e.g.
-;; Test1::Test2::classname::
-opt-class
- : namespace-opt-class
- ( ,$1 )
- | ;;EMPTY
- ( nil )
- ;
-
-opt-destructor
- : TILDE
- ( t )
- | ;;EMPTY
- ( nil )
- ;
-
-arg-list
- : PAREN_BLCK knr-arguments
- ( ,$2 )
- | PAREN_BLCK
- (EXPANDFULL $1 arg-sub-list)
- | VOID_BLCK
- ( )
- ;
-
-knr-varnamelist
- : varname COMA knr-varnamelist
- ( ,(cons $1 $3) )
- | varname
- ( $1 )
- ;
-
-
-knr-one-variable-decl
- : declmods typeformbase cv-declmods knr-varnamelist
- ( VARIABLE-TAG (nreverse $4) $2 nil
- :constant-flag (if (member "const" (append $3)) t nil)
- :typemodifiers (delete "const" $3)
- )
- ;
-
-knr-arguments
- : knr-one-variable-decl SEMICOLON knr-arguments
- ( ,(append (semantic-expand-c-tag ,$1) ,$3) )
- | knr-one-variable-decl SEMICOLON
- ( ,(semantic-expand-c-tag ,$1) )
- ;
-
-arg-sub-list
- : variablearg
- ( ,$1 )
- | PERIOD PERIOD PERIOD RPAREN
- (VARIABLE-TAG "..." "vararg" nil)
- | COMA
- ( nil )
- | LPAREN
- ( nil )
- | RPAREN
- ( nil )
- ;
-
-operatorsym
- : LESS LESS EQUAL
- ( "<<=" )
- | GREATER GREATER EQUAL
- ( ">>=" )
- | LESS LESS
- ( "<<" )
- | GREATER GREATER
- ( ">>" )
- | EQUAL EQUAL
- ( "==" )
- | LESS EQUAL
- ( "<=" )
- | GREATER EQUAL
- ( ">=" )
- | BANG EQUAL
- ( "!=" )
- | PLUS EQUAL
- ( "+=" )
- | MINUS EQUAL
- ( "-=" )
- | STAR EQUAL
- ( "*=" )
- | DIVIDE EQUAL
- ( "/=" )
- | MOD EQUAL
- ( "%=" )
- | AMPERSAND EQUAL
- ( "&=" )
- | OR EQUAL
- ( "|=" )
- | MINUS GREATER STAR
- ( "->*" )
- | MINUS GREATER
- ( "->" )
- | PARENS
- ( "()" )
- | BRACKETS
- ( "[]" )
- | LESS
- | GREATER
- | STAR
- | PLUS PLUS
- ( "++" )
- | PLUS
- | MINUS MINUS
- ( "--" )
- | MINUS
- | AMPERSAND AMPERSAND
- ( "&&" )
- | AMPERSAND
- | OR OR
- ( "||" )
- | OR
- | DIVIDE
- | EQUAL
- | BANG
- | TILDE
- | MOD
- | COMA
- ;; HAT EQUAL seems to have a really unpleasant result and
- ;; breaks everything after it. Leave it at the end, though it
- ;; doesn't seem to work.
- | HAT EQUAL
- ( "^=" )
- | HAT
- ;
-
-functionname
- : OPERATOR operatorsym
- ( ,$2 )
- | semantic-list
- ( EXPAND $1 function-pointer )
- | symbol
- ( $1 )
- ;
-
-function-pointer
- : LPAREN STAR opt-symbol RPAREN
- ( (concat "*" ,(car $3)) )
- | LPAREN symbol RPAREN
- ( $2 )
- ;
-
-fun-or-proto-end
- : SEMICOLON
- ( t )
- | semantic-list
- ( nil )
- ;; Here is an annoying feature of C++ pure virtual methods
- | EQUAL ZERO SEMICOLON
- ( :pure-virtual-flag )
- | fun-try-end
- ( nil )
- ;
-
-fun-try-end
- : TRY opt-initializers BRACE_BLCK fun-try-several-catches
- ( nil )
- ;
-
-fun-try-several-catches
- : CATCH PAREN_BLCK BRACE_BLCK fun-try-several-catches
- ( )
- | CATCH BRACE_BLCK fun-try-several-catches
- ( )
- | ;; EMPTY
- ( )
- ;
-
-type-cast
- : semantic-list
- ( EXPAND $1 type-cast-list )
- ;
-
-type-cast-list
- : open-paren typeformbase close-paren
- ;
-
-opt-brackets-after-symbol
- : brackets-after-symbol
- | ;; EMPTY
- ;
-
-brackets-after-symbol
- : PAREN_BLCK
- | BRACK_BLCK
- ;
-
-multi-stage-dereference
- : namespace-symbol opt-brackets-after-symbol
- PERIOD multi-stage-dereference ;; method call
- | namespace-symbol opt-brackets-after-symbol
- MINUS GREATER multi-stage-dereference ;;method call
- | namespace-symbol opt-brackets-after-symbol
- PERIOD namespace-symbol opt-brackets-after-symbol
- | namespace-symbol opt-brackets-after-symbol
- MINUS GREATER namespace-symbol opt-brackets-after-symbol
- | namespace-symbol brackets-after-symbol
- ;
-
-string-seq
- : string string-seq
- ( (concat $1 (car $2)) )
- | string
- ( $1 )
- ;
-
-expr-start
- : MINUS
- | PLUS
- | STAR
- | AMPERSAND
- ;
-
-expr-binop
- : MINUS
- | PLUS
- | STAR
- | DIVIDE
- | AMPERSAND AMPERSAND
- | AMPERSAND
- | OR OR
- | OR
- | MOD
- ;; There are more.
- ;
-
-;; Use expression for parsing only. Don't actually return anything
-;; for now. Hopefully we can fix this later.
-expression
- : unaryexpression QUESTION unaryexpression COLON unaryexpression
- ( (identity start) (identity end) )
- | unaryexpression expr-binop unaryexpression
- ( (identity start) (identity end) )
- | unaryexpression
- ( (identity start) (identity end) )
- ;
-
-unaryexpression
- : number
- | multi-stage-dereference
- | NEW multi-stage-dereference
- | NEW builtintype-types semantic-list
- | symbol
- ;; Klaus Berndl: C/C++ allows sequences of strings which are
- ;; concatenated by the precompiler to one string
- | string-seq
- | type-cast expression ;; A cast to some other type
- ;; Casting the results of one expression to something else.
- | semantic-list expression
- | semantic-list
- | expr-start expression
- ;
-
-;;; c.by ends here
+++ /dev/null
-;;; semantic-grammar.wy -- LALR grammar of Semantic input grammars
-;;
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-;;
-;; Author: David Ponce <david@dponce.com>
-;; Created: 26 Aug 2002
-;; Keywords: syntax
-;; X-RCS: $Id: semantic-grammar.wy,v 1.16 2005/09/30 20:20:27 zappo Exp $
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-%package semantic-grammar-wy
-%provide semantic/grammar-wy
-
-%{
-(defvar semantic-grammar-lex-c-char-re)
-
-;; Current parsed nonterminal name.
-(defvar semantic-grammar-wy--nterm nil)
-;; Index of rule in a nonterminal clause.
-(defvar semantic-grammar-wy--rindx nil)
-}
-
-%languagemode wy-mode
-
-;; Main
-%start grammar
-;; Reparse
-%start prologue epilogue declaration nonterminal rule
-;; EXPANDFULL
-%start put_names put_values use_names
-
-;; Keywords
-%type <keyword>
-%keyword DEFAULT-PREC "%default-prec"
-%keyword NO-DEFAULT-PREC "%no-default-prec"
-%keyword KEYWORD "%keyword"
-%keyword LANGUAGEMODE "%languagemode"
-%keyword LEFT "%left"
-%keyword NONASSOC "%nonassoc"
-%keyword PACKAGE "%package"
-%keyword EXPECTEDCONFLICTS "%expectedconflicts"
-%keyword PROVIDE "%provide"
-%keyword PREC "%prec"
-%keyword PUT "%put"
-%keyword QUOTEMODE "%quotemode"
-%keyword RIGHT "%right"
-%keyword SCOPESTART "%scopestart"
-%keyword START "%start"
-%keyword TOKEN "%token"
-%keyword TYPE "%type"
-%keyword USE-MACROS "%use-macros"
-
-;; Literals
-%type <string>
-%token <string> STRING
-
-%type <symbol> syntax ":?\\(\\sw\\|\\s_\\)+"
-%token <symbol> SYMBOL
-%token <symbol> PERCENT_PERCENT "\\`%%\\'"
-
-%type <char> syntax semantic-grammar-lex-c-char-re
-%token <char> CHARACTER
-
-%type <qlist> matchdatatype sexp syntax "\\s'\\s-*("
-%token <qlist> PREFIXED_LIST
-
-%type <sexp> matchdatatype sexp syntax "\\="
-%token <sexp> SEXP
-
-;; Don't generate these analyzers which needs special handling code.
-%token <code> PROLOGUE "%{...%}"
-%token <code> EPILOGUE "%%...EOF"
-
-;; Blocks & Parenthesis
-%type <block>
-%token <block> PAREN_BLOCK "(LPAREN RPAREN)"
-%token <block> BRACE_BLOCK "(LBRACE RBRACE)"
-%token <open-paren> LPAREN "("
-%token <close-paren> RPAREN ")"
-%token <open-paren> LBRACE "{"
-%token <close-paren> RBRACE "}"
-
-;; Punctuation
-%type <punctuation>
-%token <punctuation> COLON ":"
-%token <punctuation> SEMI ";"
-%token <punctuation> OR "|"
-%token <punctuation> LT "<"
-%token <punctuation> GT ">"
-
-%%
-
-grammar:
- prologue
- | epilogue
- | declaration
- | nonterminal
- | PERCENT_PERCENT
- ;
-
-;;; Prologue/Epilogue
-;;
-prologue:
- PROLOGUE
- (CODE-TAG "prologue" nil)
- ;
-
-epilogue:
- EPILOGUE
- (CODE-TAG "epilogue" nil)
- ;
-
-;;; Declarations
-;;
-declaration:
- decl
- (eval $1 t)
- ;
-
-decl:
- default_prec_decl
- | no_default_prec_decl
- | languagemode_decl
- | package_decl
- | expectedconflicts_decl
- | provide_decl
- | precedence_decl
- | put_decl
- | quotemode_decl
- | scopestart_decl
- | start_decl
- | keyword_decl
- | token_decl
- | type_decl
- | use_macros_decl
- ;
-
-default_prec_decl:
- DEFAULT-PREC
- `(TAG "default-prec" 'assoc :value '("t"))
- ;
-
-no_default_prec_decl:
- NO-DEFAULT-PREC
- `(TAG "default-prec" 'assoc :value '("nil"))
- ;
-
-languagemode_decl:
- LANGUAGEMODE symbols
- `(TAG ',(car $2) 'languagemode :rest ',(cdr $2))
- ;
-
-package_decl:
- PACKAGE SYMBOL
- `(PACKAGE-TAG ',$2 nil)
- ;
-
-expectedconflicts_decl:
- EXPECTEDCONFLICTS symbols
- `(TAG ',(car $2) 'expectedconflicts :rest ',(cdr $2))
- ;
-
-provide_decl:
- PROVIDE SYMBOL
- `(TAG ',$2 'provide)
- ;
-
-precedence_decl:
- associativity token_type_opt items
- `(TAG ',$1 'assoc :type ',$2 :value ',$3)
- ;
-
-associativity:
- LEFT
- (progn "left")
- | RIGHT
- (progn "right")
- | NONASSOC
- (progn "nonassoc")
- ;
-
-put_decl:
- PUT put_name put_value
- `(TAG ',$2 'put :value ',(list $3))
- | PUT put_name put_value_list
- `(TAG ',$2 'put :value ',$3)
- | PUT put_name_list put_value
- `(TAG ',(car $2) 'put :rest ',(cdr $2) :value ',(list $3))
- | PUT put_name_list put_value_list
- `(TAG ',(car $2) 'put :rest ',(cdr $2) :value ',$3)
- ;
-
-put_name_list:
- BRACE_BLOCK
- (mapcar #'semantic-tag-name (EXPANDFULL $1 put_names))
- ;
-
-put_names:
- LBRACE
- ()
- | RBRACE
- ()
- | put_name
- ;; Must return a list of Semantic tags to EXPANDFULL!
- (TAG $1 'put-name)
- ;
-
-put_name:
- SYMBOL
- | token_type
- ;
-
-put_value_list:
- BRACE_BLOCK
- (mapcar #'semantic-tag-code-detail (EXPANDFULL $1 put_values))
- ;
-
-put_values:
- LBRACE
- ()
- | RBRACE
- ()
- | put_value
- ;; Must return a list of Semantic tags to EXPANDFULL!
- (CODE-TAG "put-value" $1)
- ;
-
-put_value:
- SYMBOL any_value
- (cons $1 $2)
- ;
-
-scopestart_decl:
- SCOPESTART SYMBOL
- `(TAG ',$2 'scopestart)
- ;
-
-quotemode_decl:
- QUOTEMODE SYMBOL
- `(TAG ',$2 'quotemode)
- ;
-
-start_decl:
- START symbols
- `(TAG ',(car $2) 'start :rest ',(cdr $2))
- ;
-
-keyword_decl:
- KEYWORD SYMBOL string_value
- `(TAG ',$2 'keyword :value ',$3)
- ;
-
-token_decl:
- TOKEN token_type_opt SYMBOL string_value
- `(TAG ',$3 ',(if $2 'token 'keyword) :type ',$2 :value ',$4)
- | TOKEN token_type_opt symbols
- `(TAG ',(car $3) 'token :type ',$2 :rest ',(cdr $3))
- ;
-
-token_type_opt:
- ;; EMPTY
- | token_type
- ;
-
-token_type:
- LT SYMBOL GT
- (progn $2)
- ;
-
-type_decl:
- TYPE token_type plist_opt
- `(TAG ',$2 'type :value ',$3)
- ;
-
-plist_opt:
- ;;EMPTY
- | plist
- ;
-
-plist:
- plist put_value
- (append (list $2) $1)
- | put_value
- (list $1)
- ;
-
-use_name_list:
- BRACE_BLOCK
- (mapcar #'semantic-tag-name (EXPANDFULL $1 use_names))
- ;
-
-use_names:
- LBRACE
- ()
- | RBRACE
- ()
- | SYMBOL
- ;; Must return a list of Semantic tags to EXPANDFULL!
- (TAG $1 'use-name)
- ;
-
-use_macros_decl:
- USE-MACROS SYMBOL use_name_list
- `(TAG "macro" 'macro :type ',$2 :value ',$3)
- ;
-
-string_value:
- STRING
- (read $1)
- ;
-
-;; Return a Lisp readable form
-any_value:
- SYMBOL
- | STRING
- | PAREN_BLOCK
- | PREFIXED_LIST
- | SEXP
- ;
-
-symbols:
- lifo_symbols
- (nreverse $1)
- ;
-
-lifo_symbols:
- lifo_symbols SYMBOL
- (cons $2 $1)
- | SYMBOL
- (list $1)
- ;
-
-;;; Grammar rules
-;;
-nonterminal:
- SYMBOL
- (setq semantic-grammar-wy--nterm $1
- semantic-grammar-wy--rindx 0)
- COLON rules SEMI
- (TAG $1 'nonterminal :children $4)
- ;
-
-rules:
- lifo_rules
- (apply #'nconc (nreverse $1))
- ;
-
-lifo_rules:
- lifo_rules OR rule
- (cons $3 $1)
- | rule
- (list $1)
- ;
-
-rule:
- rhs
- (let* ((nterm semantic-grammar-wy--nterm)
- (rindx semantic-grammar-wy--rindx)
- (rhs $1)
- comps prec action elt)
- (setq semantic-grammar-wy--rindx (1+ semantic-grammar-wy--rindx))
- (while rhs
- (setq elt (car rhs)
- rhs (cdr rhs))
- (cond
- ;; precedence level
- ((vectorp elt)
- (if prec
- (error "Duplicate %%prec in `%s:%d' rule" nterm rindx))
- (setq prec (aref elt 0)))
- ;; action
- ((consp elt)
- ;; don't forget that rhs items are in reverse order, so
- ;; the end-of-rule semantic action is the first item.
- (if (or action comps)
- ;; a mid-rule action
- (setq comps (cons elt comps)
- ;; keep rule and action index synchronized
- semantic-grammar-wy--rindx
- (1+ semantic-grammar-wy--rindx))
- ;; the end-of-rule action
- (setq action (car elt))))
- ;; item
- (t
- (setq comps (cons elt comps)))))
- (EXPANDTAG
- (TAG (format "%s:%d" nterm rindx) 'rule
- :type (if comps "group" "empty")
- :value comps :prec prec :expr action)))
- ;
-
-rhs:
- ;; EMPTY
- | rhs item
- (cons $2 $1)
- | rhs action
- (cons (list $2) $1)
- | rhs PREC item
- (cons (vector $3) $1)
- ;
-
-action:
- PAREN_BLOCK
- | PREFIXED_LIST
- | BRACE_BLOCK
- (format "(progn\n%s)"
- (let ((s $1))
- (if (string-match "^{[\r\n\t ]*" s)
- (setq s (substring s (match-end 0))))
- (if (string-match "[\r\n\t ]*}$" s)
- (setq s (substring s 0 (match-beginning 0))))
- s))
- ;
-
-items:
- lifo_items
- (nreverse $1)
- ;
-
-lifo_items:
- lifo_items item
- (cons $2 $1)
- | item
- (list $1)
- ;
-
-item:
- SYMBOL
- | CHARACTER
- ;
-
-%%
-
-;;; grammar.wy ends here
+++ /dev/null
-;;; java-tags.wy -- Semantic LALR grammar for Java
-
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-;;
-;; Author: David Ponce <david@dponce.com>
-;; Created: 26 Aug 2002
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-%package wisent-java-tags-wy
-%provide semantic/wisent/javat-wy
-
-%{
-(declare-function semantic-parse-region "semantic"
- (start end &optional nonterminal depth returnonerror))
-}
-
-%languagemode java-mode
-
-;; The default start symbol
-%start compilation_unit
-;; Alternate entry points
-;; - Needed by partial re-parse
-%start package_declaration
-%start import_declaration
-%start class_declaration
-%start field_declaration
-%start method_declaration
-%start formal_parameter
-%start constructor_declaration
-%start interface_declaration
-;; - Needed by EXPANDFULL clauses
-%start class_member_declaration
-%start interface_member_declaration
-%start formal_parameters
-
-;; -----------------------------
-;; Block & Parenthesis terminals
-;; -----------------------------
-%type <block> ;;syntax "\\s(\\|\\s)" matchdatatype block
-
-%token <block> PAREN_BLOCK "(LPAREN RPAREN)"
-%token <block> BRACE_BLOCK "(LBRACE RBRACE)"
-%token <block> BRACK_BLOCK "(LBRACK RBRACK)"
-
-%token <open-paren> LPAREN "("
-%token <close-paren> RPAREN ")"
-%token <open-paren> LBRACE "{"
-%token <close-paren> RBRACE "}"
-%token <open-paren> LBRACK "["
-%token <close-paren> RBRACK "]"
-
-;; ------------------
-;; Operator terminals
-;; ------------------
-%type <punctuation> ;;syntax "\\(\\s.\\|\\s$\\|\\s'\\)+" matchdatatype string
-
-%token <punctuation> NOT "!"
-%token <punctuation> NOTEQ "!="
-%token <punctuation> MOD "%"
-%token <punctuation> MODEQ "%="
-%token <punctuation> AND "&"
-%token <punctuation> ANDAND "&&"
-%token <punctuation> ANDEQ "&="
-%token <punctuation> MULT "*"
-%token <punctuation> MULTEQ "*="
-%token <punctuation> PLUS "+"
-%token <punctuation> PLUSPLUS "++"
-%token <punctuation> PLUSEQ "+="
-%token <punctuation> COMMA ","
-%token <punctuation> MINUS "-"
-%token <punctuation> MINUSMINUS "--"
-%token <punctuation> MINUSEQ "-="
-%token <punctuation> DOT "."
-%token <punctuation> DIV "/"
-%token <punctuation> DIVEQ "/="
-%token <punctuation> COLON ":"
-%token <punctuation> SEMICOLON ";"
-%token <punctuation> LT "<"
-%token <punctuation> LSHIFT "<<"
-%token <punctuation> LSHIFTEQ "<<="
-%token <punctuation> LTEQ "<="
-%token <punctuation> EQ "="
-%token <punctuation> EQEQ "=="
-%token <punctuation> GT ">"
-%token <punctuation> GTEQ ">="
-%token <punctuation> RSHIFT ">>"
-%token <punctuation> RSHIFTEQ ">>="
-%token <punctuation> URSHIFT ">>>"
-%token <punctuation> URSHIFTEQ ">>>="
-%token <punctuation> QUESTION "?"
-%token <punctuation> XOR "^"
-%token <punctuation> XOREQ "^="
-%token <punctuation> OR "|"
-%token <punctuation> OREQ "|="
-%token <punctuation> OROR "||"
-%token <punctuation> COMP "~"
-
-;; -----------------
-;; Literal terminals
-;; -----------------
-%type <symbol> ;;syntax "\\(\\sw\\|\\s_\\)+"
-%token <symbol> IDENTIFIER
-
-%type <string> ;;syntax "\\s\"" matchdatatype sexp
-%token <string> STRING_LITERAL
-
-%type <number> ;;syntax semantic-lex-number-expression
-%token <number> NUMBER_LITERAL
-
-%type <unicode> syntax "\\\\u[0-9a-f][0-9a-f][0-9a-f][0-9a-f]"
-%token <unicode> unicodecharacter
-
-;; -----------------
-;; Keyword terminals
-;; -----------------
-
-;; Generate a keyword analyzer
-%type <keyword> ;;syntax "\\(\\sw\\|\\s_\\)+" matchdatatype keyword
-
-%keyword ABSTRACT "abstract"
-%put ABSTRACT summary
-"Class|Method declaration modifier: abstract {class|<type>} <name> ..."
-
-%keyword BOOLEAN "boolean"
-%put BOOLEAN summary
-"Primitive logical quantity type (true or false)"
-
-%keyword BREAK "break"
-%put BREAK summary
-"break [<label>] ;"
-
-%keyword BYTE "byte"
-%put BYTE summary
-"Integral primitive type (-128 to 127)"
-
-%keyword CASE "case"
-%put CASE summary
-"switch(<expr>) {case <const-expr>: <stmts> ... }"
-
-%keyword CATCH "catch"
-%put CATCH summary
-"try {<stmts>} catch(<parm>) {<stmts>} ... "
-
-%keyword CHAR "char"
-%put CHAR summary
-"Integral primitive type (0 to 65535)"
-
-%keyword CLASS "class"
-%put CLASS summary
-"Class declaration: class <name>"
-
-%keyword CONST "const"
-%put CONST summary
-"Unused reserved word"
-
-%keyword CONTINUE "continue"
-%put CONTINUE summary
-"continue [<label>] ;"
-
-%keyword DEFAULT "default"
-%put DEFAULT summary
-"switch(<expr>) { ... default: <stmts>}"
-
-%keyword DO "do"
-%put DO summary
-"do <stmt> while (<expr>);"
-
-%keyword DOUBLE "double"
-%put DOUBLE summary
-"Primitive floating-point type (double-precision 64-bit IEEE 754)"
-
-%keyword ELSE "else"
-%put ELSE summary
-"if (<expr>) <stmt> else <stmt>"
-
-%keyword EXTENDS "extends"
-%put EXTENDS summary
-"SuperClass|SuperInterfaces declaration: extends <name> [, ...]"
-
-%keyword FINAL "final"
-%put FINAL summary
-"Class|Member declaration modifier: final {class|<type>} <name> ..."
-
-%keyword FINALLY "finally"
-%put FINALLY summary
-"try {<stmts>} ... finally {<stmts>}"
-
-%keyword FLOAT "float"
-%put FLOAT summary
-"Primitive floating-point type (single-precision 32-bit IEEE 754)"
-
-%keyword FOR "for"
-%put FOR summary
-"for ([<init-expr>]; [<expr>]; [<update-expr>]) <stmt>"
-
-%keyword GOTO "goto"
-%put GOTO summary
-"Unused reserved word"
-
-%keyword IF "if"
-%put IF summary
-"if (<expr>) <stmt> [else <stmt>]"
-
-%keyword IMPLEMENTS "implements"
-%put IMPLEMENTS summary
-"Class SuperInterfaces declaration: implements <name> [, ...]"
-
-%keyword IMPORT "import"
-%put IMPORT summary
-"Import package declarations: import <package>"
-
-%keyword INSTANCEOF "instanceof"
-
-%keyword INT "int"
-%put INT summary
-"Integral primitive type (-2147483648 to 2147483647)"
-
-%keyword INTERFACE "interface"
-%put INTERFACE summary
-"Interface declaration: interface <name>"
-
-%keyword LONG "long"
-%put LONG summary
-"Integral primitive type (-9223372036854775808 to 9223372036854775807)"
-
-%keyword NATIVE "native"
-%put NATIVE summary
-"Method declaration modifier: native <type> <name> ..."
-
-%keyword NEW "new"
-
-%keyword PACKAGE "package"
-%put PACKAGE summary
-"Package declaration: package <name>"
-
-%keyword PRIVATE "private"
-%put PRIVATE summary
-"Access level modifier: private {class|interface|<type>} <name> ..."
-
-%keyword PROTECTED "protected"
-%put PROTECTED summary
-"Access level modifier: protected {class|interface|<type>} <name> ..."
-
-%keyword PUBLIC "public"
-%put PUBLIC summary
-"Access level modifier: public {class|interface|<type>} <name> ..."
-
-%keyword RETURN "return"
-%put RETURN summary
-"return [<expr>] ;"
-
-%keyword SHORT "short"
-%put SHORT summary
-"Integral primitive type (-32768 to 32767)"
-
-%keyword STATIC "static"
-%put STATIC summary
-"Declaration modifier: static {class|interface|<type>} <name> ..."
-
-%keyword STRICTFP "strictfp"
-%put STRICTFP summary
-"Declaration modifier: strictfp {class|interface|<type>} <name> ..."
-
-%keyword SUPER "super"
-
-%keyword SWITCH "switch"
-%put SWITCH summary
-"switch(<expr>) {[case <const-expr>: <stmts> ...] [default: <stmts>]}"
-
-
-%keyword SYNCHRONIZED "synchronized"
-%put SYNCHRONIZED summary
-"synchronized (<expr>) ... | Method decl. modifier: synchronized <type> <name> ..."
-
-%keyword THIS "this"
-
-%keyword THROW "throw"
-%put THROW summary
-"throw <expr> ;"
-
-%keyword THROWS "throws"
-%put THROWS summary
-"Method|Constructor declaration: throws <classType>, ..."
-
-%keyword TRANSIENT "transient"
-%put TRANSIENT summary
-"Field declaration modifier: transient <type> <name> ..."
-
-%keyword TRY "try"
-%put TRY summary
-"try {<stmts>} [catch(<parm>) {<stmts>} ...] [finally {<stmts>}]"
-
-%keyword VOID "void"
-%put VOID summary
-"Method return type: void <name> ..."
-
-%keyword VOLATILE "volatile"
-%put VOLATILE summary
-"Field declaration modifier: volatile <type> <name> ..."
-
-%keyword WHILE "while"
-%put WHILE summary
-"while (<expr>) <stmt> | do <stmt> while (<expr>);"
-
-;; --------------------------
-;; Official javadoc line tags
-;; --------------------------
-
-;; Javadoc tags are identified by a 'javadoc' keyword property. The
-;; value of this property must be itself a property list where the
-;; following properties are recognized:
-;;
-;; - `seq' (mandatory) is the tag sequence number used to check if tags
-;; are correctly ordered in a javadoc comment block.
-;;
-;; - `usage' (mandatory) is the list of token categories for which this
-;; documentation tag is allowed.
-;;
-;; - `opt' (optional) if non-nil indicates this is an optional tag.
-;; By default tags are mandatory.
-;;
-;; - `with-name' (optional) if non-nil indicates that this tag is
-;; followed by an identifier like in "@param <var-name> description"
-;; or "@exception <class-name> description".
-;;
-;; - `with-ref' (optional) if non-nil indicates that the tag is
-;; followed by a reference like in "@see <reference>".
-
-%keyword _AUTHOR "@author"
-%put _AUTHOR javadoc (seq 1 usage (type))
-%keyword _VERSION "@version"
-%put _VERSION javadoc (seq 2 usage (type))
-%keyword _PARAM "@param"
-%put _PARAM javadoc (seq 3 usage (function) with-name t)
-%keyword _RETURN "@return"
-%put _RETURN javadoc (seq 4 usage (function))
-%keyword _EXCEPTION "@exception"
-%put _EXCEPTION javadoc (seq 5 usage (function) with-name t)
-%keyword _THROWS "@throws"
-%put _THROWS javadoc (seq 6 usage (function) with-name t)
-%keyword _SEE "@see"
-%put _SEE javadoc (seq 7 usage (type function variable) opt t with-ref t)
-%keyword _SINCE "@since"
-%put _SINCE javadoc (seq 8 usage (type function variable) opt t)
-%keyword _SERIAL "@serial"
-%put _SERIAL javadoc (seq 9 usage (variable) opt t)
-%keyword _SERIALDATA "@serialData"
-%put _SERIALDATA javadoc (seq 10 usage (function) opt t)
-%keyword _SERIALFIELD "@serialField"
-%put _SERIALFIELD javadoc (seq 11 usage (variable) opt t)
-%keyword _DEPRECATED "@deprecated"
-%put _DEPRECATED javadoc (seq 12 usage (type function variable) opt t)
-
-%%
-
-;; ------------
-;; LALR Grammar
-;; ------------
-
-;; This grammar is not designed to fully parse correct Java syntax. It
-;; is optimized to work in an interactive environment to extract tokens
-;; (tags) needed by Semantic. In some cases a syntax not allowed by
-;; the Java Language Specification will be accepted by this grammar.
-
-compilation_unit
- : package_declaration
- | import_declaration
- | type_declaration
- ;
-
-;;; Package statement token
-;; ("NAME" package DETAIL "DOCSTRING")
-package_declaration
- : PACKAGE qualified_name SEMICOLON
- (PACKAGE-TAG $2 nil)
- ;
-
-;;; Include file token
-;; ("FILE" include SYSTEM "DOCSTRING")
-import_declaration
- : IMPORT qualified_name SEMICOLON
- (INCLUDE-TAG $2 nil)
- | IMPORT qualified_name DOT MULT SEMICOLON
- (INCLUDE-TAG (concat $2 $3 $4) nil)
- ;
-
-type_declaration
- : SEMICOLON
- ()
- | class_declaration
- | interface_declaration
- ;
-
-;;; Type Declaration token
-;; ("NAME" type "TYPE" ( PART-LIST ) ( PARENTS ) EXTRA-SPEC "DOCSTRING")
-class_declaration
- : modifiers_opt CLASS qualified_name superc_opt interfaces_opt class_body
- (TYPE-TAG $3 $2 $6 (if (or $4 $5) (cons $4 $5)) :typemodifiers $1)
- ;
-
-superc_opt
- : ;;EMPTY
- | EXTENDS qualified_name
- (identity $2)
- ;
-
-interfaces_opt
- : ;;EMPTY
- | IMPLEMENTS qualified_name_list
- (nreverse $2)
- ;
-
-class_body
- : BRACE_BLOCK
- (EXPANDFULL $1 class_member_declaration)
- ;
-
-class_member_declaration
- : LBRACE
- ()
- | RBRACE
- ()
- | block
- ()
- | static_initializer
- ()
- | constructor_declaration
- | interface_declaration
- | class_declaration
- | method_declaration
- | field_declaration
- ;
-
-;;; Type Declaration token
-;; ("NAME" type "TYPE" ( PART-LIST ) ( PARENTS ) EXTRA-SPEC "DOCSTRING")
-interface_declaration
- : modifiers_opt INTERFACE qualified_name extends_interfaces_opt interface_body
- (TYPE-TAG $3 $2 $5 (if $4 (cons nil $4)) :typemodifiers $1)
- ;
-
-extends_interfaces_opt
- : ;;EMPTY
- | EXTENDS qualified_name_list
- (identity $2)
- ;
-
-interface_body
- : BRACE_BLOCK
- (EXPANDFULL $1 interface_member_declaration)
- ;
-
-interface_member_declaration
- : LBRACE
- ()
- | RBRACE
- ()
- | interface_declaration
- | class_declaration
- | method_declaration
- | field_declaration
- ;
-
-static_initializer
- : STATIC block
- ;
-
-;;; Function token
-;; ("NAME" function "TYPE" ( ARG-LIST ) EXTRA-SPEC "DOCSTRING")
-constructor_declaration
- : modifiers_opt constructor_declarator throwsc_opt constructor_body
- (FUNCTION-TAG (car $2) nil (cdr $2)
- :typemodifiers $1
- :throws $3
- :constructor-flag t)
- ;
-
-constructor_declarator
- : IDENTIFIER formal_parameter_list
- (cons $1 $2)
- ;
-
-constructor_body
- : block
- ;
-
-;;; Function token
-;; ("NAME" function "TYPE" ( ARG-LIST ) EXTRA-SPEC "DOCSTRING")
-method_declaration
- : modifiers_opt VOID method_declarator throwsc_opt method_body
- (FUNCTION-TAG (car $3) $2 (cdr $3) :typemodifiers $1 :throws $4)
- | modifiers_opt type method_declarator throwsc_opt method_body
- (FUNCTION-TAG (car $3) $2 (cdr $3) :typemodifiers $1 :throws $4)
- ;
-
-method_declarator
- : IDENTIFIER formal_parameter_list dims_opt
- (cons (concat $1 $3) $2)
- ;
-
-throwsc_opt
- : ;;EMPTY
- | THROWS qualified_name_list
- (nreverse $2)
- ;
-
-qualified_name_list
- : qualified_name_list COMMA qualified_name
- (cons $3 $1)
- | qualified_name
- (list $1)
- ;
-
-method_body
- : SEMICOLON
- | block
- ;
-
-;; Just eat {...} block!
-block
- : BRACE_BLOCK
- ;
-
-formal_parameter_list
- : PAREN_BLOCK
- (EXPANDFULL $1 formal_parameters)
- ;
-
-formal_parameters
- : LPAREN
- ()
- | RPAREN
- ()
- | formal_parameter COMMA
- | formal_parameter RPAREN
- ;
-
-;;; Variable token
-;; ("NAME" variable "TYPE" DEFAULT-VALUE EXTRA-SPEC "DOCSTRING")
-formal_parameter
- : formal_parameter_modifier_opt type opt_variable_declarator_id
- (VARIABLE-TAG $3 $2 nil :typemodifiers $1)
- ;
-
-formal_parameter_modifier_opt
- : ;;EMPTY
- | FINAL
- (list $1)
- ;
-
-;;; Variable token
-;; ("NAME" variable "TYPE" DEFAULT-VALUE EXTRA-SPEC "DOCSTRING")
-field_declaration
- : modifiers_opt type variable_declarators SEMICOLON
- (VARIABLE-TAG $3 $2 nil :typemodifiers $1)
- ;
-
-variable_declarators
- : variable_declarators COMMA variable_declarator
- (progn
- ;; Set the end of the compound declaration to the end of the
- ;; COMMA delimiter.
- (setcdr (cdr (car $1)) (cdr $region2))
- (cons $3 $1))
- | variable_declarator
- (list $1)
- ;
-
-variable_declarator
- : variable_declarator_id EQ variable_initializer
- (cons $1 $region)
- | variable_declarator_id
- (cons $1 $region)
- ;
-
-opt_variable_declarator_id
- : ;; EMPTY
- (identity "")
- | variable_declarator_id
- (identity $1)
- ;
-
-variable_declarator_id
- : IDENTIFIER dims_opt
- (concat $1 $2)
- ;
-
-variable_initializer
- : expression
- ;
-
-;; Just eat expression!
-expression
- : expression term
- | term
- ;
-
-term
- : literal
- | operator
- | primitive_type
- | IDENTIFIER
- | BRACK_BLOCK
- | PAREN_BLOCK
- | BRACE_BLOCK
- | NEW
- | CLASS
- | THIS
- | SUPER
- ;
-
-literal
-;; : NULL_LITERAL
-;; | BOOLEAN_LITERAL
- : STRING_LITERAL
- | NUMBER_LITERAL
- ;
-
-operator
- : NOT
- | PLUS
- | PLUSPLUS
- | MINUS
- | MINUSMINUS
- | NOTEQ
- | MOD
- | MODEQ
- | AND
- | ANDAND
- | ANDEQ
- | MULT
- | MULTEQ
- | PLUSEQ
- | MINUSEQ
- | DOT
- | DIV
- | DIVEQ
- | COLON
- | LT
- | LSHIFT
- | LSHIFTEQ
- | LTEQ
- | EQ
- | EQEQ
- | GT
- | GTEQ
- | RSHIFT
- | RSHIFTEQ
- | URSHIFT
- | URSHIFTEQ
- | QUESTION
- | XOR
- | XOREQ
- | OR
- | OREQ
- | OROR
- | COMP
- | INSTANCEOF
- ;
-
-primitive_type
- : BOOLEAN
- | CHAR
- | LONG
- | INT
- | SHORT
- | BYTE
- | DOUBLE
- | FLOAT
- ;
-
-modifiers_opt
- : ;;EMPTY
- | modifiers
- (nreverse $1)
- ;
-
-modifiers
- : modifiers modifier
- (cons $2 $1)
- | modifier
- (list $1)
- ;
-
-modifier
- : STRICTFP
- | VOLATILE
- | TRANSIENT
- | SYNCHRONIZED
- | NATIVE
- | FINAL
- | ABSTRACT
- | STATIC
- | PRIVATE
- | PROTECTED
- | PUBLIC
- ;
-
-type
- : qualified_name dims_opt
- (concat $1 $2)
- | primitive_type dims_opt
- (concat $1 $2)
- ;
-
-qualified_name
- : qualified_name DOT IDENTIFIER
- (concat $1 $2 $3)
- | IDENTIFIER
- ;
-
-dims_opt
- : ;;EMPTY
- (identity "")
- | dims
- ;
-
-dims
- : dims BRACK_BLOCK
- (concat $1 "[]")
- | BRACK_BLOCK
- (identity "[]")
- ;
-
-%%
-;; Define the lexer for this grammar
-(define-lex wisent-java-tags-lexer
- "Lexical analyzer that handles Java buffers.
-It ignores whitespaces, newlines and comments."
- semantic-lex-ignore-whitespace
- semantic-lex-ignore-newline
- semantic-lex-ignore-comments
- ;;;; Auto-generated analyzers.
- wisent-java-tags-wy--<number>-regexp-analyzer
- wisent-java-tags-wy--<string>-sexp-analyzer
- ;; Must detect keywords before other symbols
- wisent-java-tags-wy--<keyword>-keyword-analyzer
- wisent-java-tags-wy--<symbol>-regexp-analyzer
- wisent-java-tags-wy--<punctuation>-string-analyzer
- wisent-java-tags-wy--<block>-block-analyzer
- ;; In theory, Unicode chars should be turned into normal chars
- ;; and then combined into regular ascii keywords and text. This
- ;; analyzer just keeps these things from making the lexer go boom.
- wisent-java-tags-wy--<unicode>-regexp-analyzer
- ;;;;
- semantic-lex-default-action)
-
-;;; java-tags.wy ends here
+++ /dev/null
-;;; javascript-jv.wy -- LALR grammar for Javascript
-
-;; Copyright (C) 2005-2024 Free Software Foundation, Inc.
-;; Copyright (C) 1998-2011 Ecma International.
-
-;; Author: Joakim Verona
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; The grammar itself is transcribed from the ECMAScript Language
-;; Specification published at
-;;
-;; https://www.ecma-international.org/publications/standards/Ecma-262.htm
-;;
-;; and redistributed under the following license:
-
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions
-;; are met:
-
-;; 1. Redistributions of source code must retain the above copyright
-;; notice, this list of conditions and the following disclaimer.
-
-;; 2. Redistributions in binary form must reproduce the above
-;; copyright notice, this list of conditions and the following
-;; disclaimer in the documentation and/or other materials provided
-;; with the distribution.
-
-;; 3. Neither the name of the authors nor Ecma International may be
-;; used to endorse or promote products derived from this software
-;; without specific prior written permission. THIS SOFTWARE IS
-;; PROVIDED BY THE ECMA INTERNATIONAL "AS IS" AND ANY EXPRESS OR
-;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-;; ARE DISCLAIMED. IN NO EVENT SHALL ECMA INTERNATIONAL BE LIABLE FOR
-;; ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
-;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
-;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
-;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
-;; DAMAGE.
-
-%package wisent-javascript-jv-wy
-%provide semantic/wisent/js-wy
-
-%{
-(declare-function semantic-parse-region "semantic"
- (start end &optional nonterminal depth returnonerror))
-}
-
-;; JAVE I preferred ecmascript-mode.
-%languagemode ecmascript-mode javascript-mode
-
-;; The default goal
-%start Program
-;; Other Goals
-%start FormalParameterList
-
-;; with the terminals stuff, I used the javascript.y names,
-;; but the semantic/wisent/java-tags.wy types
-;; when possible
-;; ------------------
-;; Operator terminals
-;; ------------------
-
-;;define-lex-string-type-analyzer gets called with the "syntax" comment
-%type <punctuation> ;;syntax "\\(\\s.\\|\\s$\\|\\s'\\)+" matchdatatype string
-
-%token <punctuation> ASSIGN_SYMBOL "="
-%token <punctuation> BITWISE_AND "&"
-%token <punctuation> BITWISE_AND_EQUALS "&="
-%token <punctuation> BITWISE_EXCLUSIVE_OR "^"
-%token <punctuation> BITWISE_EXCLUSIVE_OR_EQUALS "^="
-%token <punctuation> BITWISE_OR "|"
-%token <punctuation> BITWISE_OR_EQUALS "|="
-%token <punctuation> BITWISE_SHIFT_LEFT "<<"
-%token <punctuation> BITWISE_SHIFT_LEFT_EQUALS "<<="
-%token <punctuation> BITWISE_SHIFT_RIGHT ">>"
-%token <punctuation> BITWISE_SHIFT_RIGHT_EQUALS ">>="
-%token <punctuation> BITWISE_SHIFT_RIGHT_ZERO_FILL ">>>"
-%token <punctuation> BITWISE_SHIFT_RIGHT_ZERO_FILL_EQUALS ">>>="
-%token <punctuation> NOT_EQUAL "!="
-%token <punctuation> DIV_EQUALS "/="
-%token <punctuation> EQUALS "=="
-%token <punctuation> GREATER_THAN ">"
-%token <punctuation> GT_EQUAL ">="
-%token <punctuation> LOGICAL_AND "&&"
-%token <punctuation> LOGICAL_OR "||"
-%token <punctuation> LOGICAL_NOT "!!"
-%token <punctuation> LS_EQUAL "<="
-%token <punctuation> MINUS "-"
-%token <punctuation> MINUS_EQUALS "-="
-%token <punctuation> MOD "%"
-%token <punctuation> MOD_EQUALS "%="
-%token <punctuation> MULTIPLY "*"
-%token <punctuation> MULTIPLY_EQUALS "*="
-%token <punctuation> PLUS "+"
-%token <punctuation> PLUS_EQUALS "+="
-%token <punctuation> INCREMENT "++"
-%token <punctuation> DECREMENT "--"
-%token <punctuation> DIV "/"
-%token <punctuation> COLON ":"
-%token <punctuation> COMMA ","
-%token <punctuation> DOT "."
-%token <punctuation> LESS_THAN "<"
-%token <punctuation> LINE_TERMINATOR "\n"
-%token <punctuation> SEMICOLON ";"
-%token <punctuation> ONES_COMPLIMENT "~"
-
-
-;; -----------------------------
-;; Block & Parenthesis terminals
-;; -----------------------------
-%type <block> ;;syntax "\\s(\\|\\s)" matchdatatype block
-%token <block> PAREN_BLOCK "(OPEN_PARENTHESIS CLOSE_PARENTHESIS)"
-%token <block> BRACE_BLOCK "(START_BLOCK END_BLOCK)"
-%token <block> BRACK_BLOCK "(OPEN_SQ_BRACKETS CLOSE_SQ_BRACKETS)"
-
-%token <open-paren> OPEN_PARENTHESIS "("
-%token <close-paren> CLOSE_PARENTHESIS ")"
-
-%token <open-paren> START_BLOCK "{"
-%token <close-paren> END_BLOCK "}"
-
-%token <open-paren> OPEN_SQ_BRACKETS "["
-%token <close-paren> CLOSE_SQ_BRACKETS "]"
-
-
-;; -----------------
-;; Keyword terminals
-;; -----------------
-
-;; Generate a keyword analyzer
-%type <keyword> ;;syntax "\\(\\sw\\|\\s_\\)+" matchdatatype keyword
-
-%keyword IF "if"
-%put IF summary
-"if (<expr>) <stmt> [else <stmt>] (jv)"
-
-%keyword BREAK "break"
-%put BREAK summary
-"break [<label>] ;"
-
-%keyword CONTINUE "continue"
-%put CONTINUE summary
-"continue [<label>] ;"
-
-%keyword ELSE "else"
-%put ELSE summary
-"if (<expr>) <stmt> else <stmt>"
-
-
-%keyword FOR "for"
-%put FOR summary
-"for ([<init-expr>]; [<expr>]; [<update-expr>]) <stmt>"
-
-
-%keyword FUNCTION "function"
-%put FUNCTION summary
-"function declaration blah blah"
-
-%keyword THIS "this"
-%put THIS summary
-"this"
-
-
-%keyword RETURN "return"
-%put RETURN summary
-"return [<expr>] ;"
-
-%keyword WHILE "while"
-%put WHILE summary
-"while (<expr>) <stmt> | do <stmt> while (<expr>);"
-
-%keyword VOID_SYMBOL "void"
-%put VOID_SYMBOL summary
-"Method return type: void <name> ..."
-
-
-
-%keyword NEW "new"
-%put NEW summary
-"new <objecttype> - Creates a new object."
-
-%keyword DELETE "delete"
-%put DELETE summary
-"delete(<objectreference>) - Deletes the object."
-
-%keyword VAR "var"
-%put VAR summary
-"var <variablename> [= value];"
-
-%keyword WITH "with"
-%put WITH summary
-"with "
-
-%keyword TYPEOF "typeof"
-%put TYPEOF summary
-"typeof "
-
-%keyword IN "in"
-%put IN summary
-"in something"
-
-
-;; -----------------
-;; Literal terminals
-;; -----------------
-
-;;the .y file uses VARIABLE as IDENTIFIER, which seems a bit evil
-;; it think the normal .wy convention is better than this
-%type <symbol> ;;syntax "\\(\\sw\\|\\s_\\)+"
-%token <symbol> VARIABLE
-
-%type <string> ;;syntax "\\s\"" matchdatatype sexp
-%token <string> STRING
-
-%type <number> ;;syntax semantic-lex-number-expression
-%token <number> NUMBER
-
-
-%token <false> FALSE
-%token <true> TRUE
-%token <query> QUERY
-
-
-%token NULL_TOKEN
-
-;;%token UNDEFINED_TOKEN
-;;%token INFINITY
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; associativity and stuff
-%left PLUS MINUS
-%left MULTIPLY DIV MOD
-
-%nonassoc FALSE
-%nonassoc HIGHER_THAN_FALSE
-%nonassoc ELSE
-%nonassoc LOWER_THAN_CLOSE_PARENTHESIS
-%nonassoc CLOSE_PARENTHESIS
-
-%%
-
-Program : SourceElement
- ;
-
-SourceElement : Statement
- | FunctionDeclaration
- ;
-
-Statement : Block
- | VariableStatement
- | EmptyStatement
- | ExpressionStatement
- | IfStatement
- | IterationExpression
- | ContinueStatement
- | BreakStatement
- | ReturnStatement
- | WithStatement
- ;
-
-FunctionDeclaration : FUNCTION VARIABLE FormalParameterListBlock Block
- (FUNCTION-TAG $2 nil $3)
- ;
-
-FormalParameterListBlock : PAREN_BLOCK
- (EXPANDFULL $1 FormalParameterList)
- ;
-
-FormalParameterList: OPEN_PARENTHESIS
- ()
- | VARIABLE
- (VARIABLE-TAG $1 nil nil)
- | CLOSE_PARENTHESIS
- ()
- | COMMA
- ()
- ;
-
-Block : BRACE_BLOCK
- ;; If you want to parse the body of the function
- ;; ( EXPANDFULL $1 BlockExpand )
- ;
-
-VariableStatement : VAR VariableDeclarationList SEMICOLON
- (VARIABLE-TAG $2 nil nil)
- ;
-
-VariableDeclarationList : VariableDeclaration
- (list $1)
- | VariableDeclarationList COMMA VariableDeclaration
- (append $1 (list $3))
- ;
-
-VariableDeclaration : VARIABLE
- (append (list $1 nil) $region)
- | VARIABLE Initializer
- (append (cons $1 $2) $region)
- ;
-
-Initializer : ASSIGN_SYMBOL AssignmentExpression
- (list $2)
- ;
-
-EmptyStatement : SEMICOLON
- ;
-
-ExpressionStatement : Expression SEMICOLON
- ;
-
-IfStatement : IF OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement %prec HIGHER_THAN_FALSE
- | IF OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement ELSE Statement
- | IF OPEN_PARENTHESIS FALSE CLOSE_PARENTHESIS Statement
- | IF OPEN_PARENTHESIS LeftHandSideExpression AssignmentOperator AssignmentExpression CLOSE_PARENTHESIS Statement
- ;
-
-IterationExpression : WHILE OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement %prec HIGHER_THAN_FALSE
- | WHILE OPEN_PARENTHESIS FALSE CLOSE_PARENTHESIS Statement
- | WHILE OPEN_PARENTHESIS LeftHandSideExpression AssignmentOperator AssignmentExpression CLOSE_PARENTHESIS Statement
- | FOR OPEN_PARENTHESIS OptionalExpression SEMICOLON OptionalExpression SEMICOLON OptionalExpression CLOSE_PARENTHESIS Statement
- | FOR OPEN_PARENTHESIS VAR VariableDeclarationList SEMICOLON OptionalExpression SEMICOLON OptionalExpression CLOSE_PARENTHESIS Statement
- | FOR OPEN_PARENTHESIS LeftHandSideExpression IN Expression CLOSE_PARENTHESIS Statement
- | FOR OPEN_PARENTHESIS VAR VARIABLE OptionalInitializer IN Expression CLOSE_PARENTHESIS Statement
- ;
-
-ContinueStatement : CONTINUE SEMICOLON
- ;
-
-;;JAVE break needs labels
-BreakStatement : BREAK SEMICOLON
- ;; | BREAK identifier SEMICOLON
- ;
-
-ReturnStatement : RETURN Expression SEMICOLON
- | RETURN SEMICOLON
- ;
-
-WithStatement : WITH OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement
- ;
-
-OptionalInitializer : Initializer
- |
- ;
-
-PrimaryExpression : THIS
- | VARIABLE
- | NUMBER
- | STRING
- | NULL_TOKEN
- | TRUE
- | FALSE
- | OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS
- ;
-
-MemberExpression : PrimaryExpression
- | MemberExpression OPEN_SQ_BRACKETS Expression CLOSE_SQ_BRACKETS
- | MemberExpression DOT VARIABLE
- | NEW MemberExpression Arguments
- ;
-
-NewExpression : MemberExpression
- | NEW NewExpression
- ;
-
-CallExpression : MemberExpression Arguments
- | CallExpression Arguments
- | CallExpression OPEN_SQ_BRACKETS Expression CLOSE_SQ_BRACKETS
- | CallExpression DOT VARIABLE
- ;
-
-Arguments : OPEN_PARENTHESIS CLOSE_PARENTHESIS
- | OPEN_PARENTHESIS ArgumentList CLOSE_PARENTHESIS
- ;
-
-ArgumentList : AssignmentExpression
- | ArgumentList COMMA AssignmentExpression
- ;
-
-LeftHandSideExpression : NewExpression
- | CallExpression
- ;
-
-PostfixExpression : LeftHandSideExpression
- | LeftHandSideExpression INCREMENT
- | LeftHandSideExpression DECREMENT
- ;
-
-UnaryExpression : PostfixExpression
- | DELETE UnaryExpression
- | VOID_SYMBOL UnaryExpression
- | TYPEOF UnaryExpression
- | INCREMENT UnaryExpression
- | DECREMENT UnaryExpression
- | PLUS UnaryExpression
- | MINUS UnaryExpression
- | ONES_COMPLIMENT UnaryExpression
- | LOGICAL_NOT UnaryExpression
- ;
-
-MultiplicativeExpression : UnaryExpression
- | MultiplicativeExpression MULTIPLY UnaryExpression
- | MultiplicativeExpression DIV UnaryExpression
- | MultiplicativeExpression MOD UnaryExpression
- ;
-
-AdditiveExpression : MultiplicativeExpression
- | AdditiveExpression PLUS MultiplicativeExpression
- | AdditiveExpression MINUS MultiplicativeExpression
- ;
-
-ShiftExpression : AdditiveExpression
- | ShiftExpression BITWISE_SHIFT_LEFT AdditiveExpression
- | ShiftExpression BITWISE_SHIFT_RIGHT AdditiveExpression
- | ShiftExpression BITWISE_SHIFT_RIGHT_ZERO_FILL AdditiveExpression
- ;
-
-RelationalExpression : ShiftExpression
- | RelationalExpression LESS_THAN ShiftExpression
- | RelationalExpression GREATER_THAN ShiftExpression
- | RelationalExpression LS_EQUAL ShiftExpression
- | RelationalExpression GT_EQUAL ShiftExpression
- ;
-
-EqualityExpression : RelationalExpression
- | EqualityExpression EQUALS RelationalExpression
- | EqualityExpression NOT_EQUAL RelationalExpression
- ;
-
-BitwiseANDExpression : EqualityExpression
- | BitwiseANDExpression BITWISE_AND EqualityExpression
- ;
-
-BitwiseXORExpression : BitwiseANDExpression
- | BitwiseXORExpression BITWISE_EXCLUSIVE_OR BitwiseANDExpression
- ;
-
-BitwiseORExpression : BitwiseXORExpression
- | BitwiseORExpression BITWISE_OR BitwiseXORExpression
- ;
-
-LogicalANDExpression : BitwiseORExpression
- | LogicalANDExpression LOGICAL_AND BitwiseORExpression
- ;
-
-LogicalORExpression : LogicalANDExpression
- | LogicalORExpression LOGICAL_OR LogicalANDExpression
- ;
-
-ConditionalExpression : LogicalORExpression
- | LogicalORExpression QUERY AssignmentExpression COLON AssignmentExpression
- ;
-
-AssignmentExpression : ConditionalExpression
- | LeftHandSideExpression AssignmentOperator AssignmentExpression %prec LOWER_THAN_CLOSE_PARENTHESIS
- ;
-
-AssignmentOperator : ASSIGN_SYMBOL
- | MULTIPLY_EQUALS
- | DIV_EQUALS
- | MOD_EQUALS
- | PLUS_EQUALS
- | MINUS_EQUALS
- | BITWISE_SHIFT_LEFT_EQUALS
- | BITWISE_SHIFT_RIGHT_EQUALS
- | BITWISE_SHIFT_RIGHT_ZERO_FILL_EQUALS
- | BITWISE_AND_EQUALS
- | BITWISE_EXCLUSIVE_OR_EQUALS
- | BITWISE_OR_EQUALS
- ;
-
-Expression : AssignmentExpression
- | Expression COMMA AssignmentExpression
- ;
-
-OptionalExpression : Expression
- |
- ;
-
-%%
-
-;;here something like:
-;;(define-lex wisent-java-tags-lexer
-;; should go
-(define-lex javascript-lexer-jv
-"javascript thingy"
-;;std stuff
- semantic-lex-ignore-whitespace
- semantic-lex-ignore-newline
- semantic-lex-ignore-comments
-
- ;;stuff generated from the wy file(one for each "type" declaration)
- wisent-javascript-jv-wy--<number>-regexp-analyzer
- wisent-javascript-jv-wy--<string>-sexp-analyzer
-
- wisent-javascript-jv-wy--<keyword>-keyword-analyzer
-
- wisent-javascript-jv-wy--<symbol>-regexp-analyzer
- wisent-javascript-jv-wy--<punctuation>-string-analyzer
- wisent-javascript-jv-wy--<block>-block-analyzer
-
-
- ;;;;more std stuff
- semantic-lex-default-action
- )
-
-;;; javascript-jv.wy ends here
+++ /dev/null
-;;; make.by -- BY notation for Makefiles.
-
-;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
-;;
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; David Ponce <david@dponce.com>
-;; Klaus Berndl <klaus.berndl@sdm.de>
-;;
-;; 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 <https://www.gnu.org/licenses/>.
-
-%package semantic-make-by
-%provide semantic/bovine/make-by
-
-%languagemode makefile-mode
-%start Makefile
-
-;; This was always a test case.
-%quotemode backquote
-
-%token IF "if"
-%token IFDEF "ifdef"
-%token IFNDEF "ifndef"
-%token IFEQ "ifeq"
-%token IFNEQ "ifneq"
-%token ELSE "else"
-%token ENDIF "endif"
-%token INCLUDE "include"
-
-%put { IF ELSE ENDIF } summary "Conditional: if (expression) ... else ... endif"
-%put IFDEF summary "Conditional: ifdef (expression) ... else ... endif"
-%put IFNDEF summary "Conditional: ifndef (expression) ... else ... endif"
-%put IFEQ summary "Conditional: ifeq (expression) ... else ... endif"
-%put IFNEQ summary "Conditional: ifneq (expression) ... else ... endif"
-%put INCLUDE summary "Macro: include filename1 filename2 ..."
-
-%token <punctuation> COLON "\\`[:]\\'"
-%token <punctuation> PLUS "\\`[+]\\'"
-%token <punctuation> EQUAL "\\`[=]\\'"
-%token <punctuation> DOLLAR "\\`[$]\\'"
-%token <punctuation> BACKSLASH "\\`[\\]\\'"
-
-%%
-
-;; Escape the ,@ below because the reader doesn't correctly detect
-;; old-style backquotes for this case. The backslashes can be removed
-;; once old-style backquotes are completely gone (probably in
-;; Emacs 28).
-
-Makefile : bol newline (nil)
- | bol variable
- ( \,@$2 )
- | bol rule
- ( \,@$2 )
- | bol conditional
- ( \,@$2 )
- | bol include
- ( \,@$2 )
- | whitespace ( nil )
- | newline ( nil )
- ;
-
-variable: symbol opt-whitespace equals opt-whitespace element-list
- (VARIABLE-TAG ,$1 nil ,$5)
- ;
-
-rule: targets opt-whitespace colons opt-whitespace element-list commands
- (FUNCTION-TAG ,$1 nil ,$5)
- ;
-
-targets: target opt-whitespace targets
- ( (car ,$1) (car ,@$3) )
- | target
- ( (car ,$1) )
- ;
-
-target: sub-target target
- ( (concat (car ,$1) (car ,@$3) ) )
- | sub-target
- ( (car ,$1) )
- ;
-
-sub-target: symbol
- | string
- | varref
- ;
-
-conditional: IF some-whitespace symbol newline
- ( nil )
- | IFDEF some-whitespace symbol newline
- ( nil )
- | IFNDEF some-whitespace symbol newline
- ( nil )
- | IFEQ some-whitespace expression newline
- ( nil )
- | IFNEQ some-whitespace expression newline
- ( nil )
- | ELSE newline
- ( nil )
- | ENDIF newline
- ( nil )
- ;
-
-expression : semantic-list
- ;
-
-include: INCLUDE some-whitespace element-list
- (INCLUDE-TAG ,$3 nil)
- ;
-
-equals: COLON EQUAL ()
- | PLUS EQUAL ()
- | EQUAL ()
- ;
-
-colons: COLON COLON ()
- | COLON ()
- ;
-
-element-list: elements newline
- ( \,@$1 )
- ;
-
-elements: element some-whitespace elements
- ( \,@$1 ,@$3 )
- | element
- ( \,@$1 )
- | ;;EMPTY
- ;
-
-element: sub-element element
- ( (concat (car ,$1) (car ,$2)) )
- | ;;EMPTY
- ;
-
-sub-element: symbol
- | string
- | punctuation
- | semantic-list
- ( (buffer-substring-no-properties
- (identity start) (identity end)) )
- ;
-
-varref: DOLLAR semantic-list
- ( (buffer-substring-no-properties (identity start) (identity end)) )
- ;
-
-commands: bol shell-command newline commands
- ( ,$1 ,@$2 )
- | ;;EMPTY
- ( )
- ;
-
-opt-whitespace : some-whitespace ( nil )
- | ;;EMPTY
- ;
-
-some-whitespace : whitespace some-whitespace (nil)
- | whitespace (nil)
- ;
-
-;;; make.by ends here
+++ /dev/null
-;;; python.wy -- LALR grammar for Python
-
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-;; Copyright (c) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010 Python Software Foundation; All Rights Reserved
-
-;; Author: Richard Kim <ryk@dspwiz.com>
-;; Created: June 2002
-;; Keywords: syntax
-;;
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This is an LALR python parser that follows the official python
-;; grammar closely with very few exceptions. The Python grammar is
-;; used and reproduced under the following license:
-;;
-;; PYTHON SOFTWARE FOUNDATION LICENSE VERSION 2
-;; --------------------------------------------
-;; 1. This LICENSE AGREEMENT is between the Python Software Foundation
-;; ("PSF"), and the Individual or Organization ("Licensee") accessing
-;; and otherwise using this software ("Python") in source or binary
-;; form and its associated documentation.
-;;
-;; 2. Subject to the terms and conditions of this License Agreement,
-;; PSF hereby grants Licensee a nonexclusive, royalty-free, world-wide
-;; license to reproduce, analyze, test, perform and/or display
-;; publicly, prepare derivative works, distribute, and otherwise use
-;; Python alone or in any derivative version, provided, however, that
-;; PSF's License Agreement and PSF's notice of copyright, i.e.,
-;; "Copyright (c) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010 Python Software Foundation; All Rights Reserved" are
-;; retained in Python alone or in any derivative version prepared by
-;; Licensee.
-;;
-;; 3. In the event Licensee prepares a derivative work that is based
-;; on or incorporates Python or any part thereof, and wants to make
-;; the derivative work available to others as provided herein, then
-;; Licensee hereby agrees to include in any such work a brief summary
-;; of the changes made to Python.
-;;
-;; 4. PSF is making Python available to Licensee on an "AS IS"
-;; basis. PSF MAKES NO REPRESENTATIONS OR WARRANTIES, EXPRESS OR
-;; IMPLIED. BY WAY OF EXAMPLE, BUT NOT LIMITATION, PSF MAKES NO AND
-;; DISCLAIMS ANY REPRESENTATION OR WARRANTY OF MERCHANTABILITY OR FITNESS
-;; FOR ANY PARTICULAR PURPOSE OR THAT THE USE OF PYTHON WILL NOT
-;; INFRINGE ANY THIRD PARTY RIGHTS.
-;;
-;; 5. PSF SHALL NOT BE LIABLE TO LICENSEE OR ANY OTHER USERS OF PYTHON
-;; FOR ANY INCIDENTAL, SPECIAL, OR CONSEQUENTIAL DAMAGES OR LOSS AS A
-;; RESULT OF MODIFYING, DISTRIBUTING, OR OTHERWISE USING PYTHON, OR
-;; ANY DERIVATIVE THEREOF, EVEN IF ADVISED OF THE POSSIBILITY THEREOF.
-;;
-;; 6. This License Agreement will automatically terminate upon a
-;; material breach of its terms and conditions.
-;;
-;; 7. Nothing in this License Agreement shall be deemed to create any
-;; relationship of agency, partnership, or joint venture between PSF
-;; and Licensee. This License Agreement does not grant permission to
-;; use PSF trademarks or trade name in a trademark sense to endorse or
-;; promote products or services of Licensee, or any third party.
-;;
-;; 8. By copying, installing or otherwise using Python, Licensee
-;; agrees to be bound by the terms and conditions of this License
-;; Agreement.
-
-;;; To do:
-;;
-;; * Verify that semantic-lex-python-number regexp is correct.
-
-;; --------
-;; Settings
-;; --------
-
-%package wisent-python-wy
-%provide semantic/wisent/python-wy
-%expectedconflicts 5
-
-%{
-(require 'semantic/tag)
-(declare-function wisent-python-reconstitute-function-tag
- "semantic/wisent/python" (tag suite))
-(declare-function wisent-python-reconstitute-class-tag "semantic/wisent/python"
- (tag))
-(declare-function semantic-parse-region "semantic"
- (start end &optional nonterminal depth returnonerror))
-(defvar wisent-python-EXPANDING-block)
-}
-
-%languagemode python-mode
-
-;; The default start symbol
-%start goal
-;; Alternate entry points
-;; - Needed by partial re-parse
-%start function_parameter
-%start paren_class
-%start indented_block
-;; - Needed by EXPANDFULL clauses
-%start function_parameters
-%start paren_classes
-%start indented_block_body
-
-;; -------------------------------
-;; Misc. Python specific terminals
-;; -------------------------------
-;; The value of these tokens are for documentation only, they are not
-;; used by the lexer.
-%token <charquote> BACKSLASH "\\"
-%token <newline> NEWLINE "\n"
-%token <indentation> INDENT "^\\s-+"
-%token <indentation> DEDENT "[^:INDENT:]"
-%token <indentation> INDENT_BLOCK "(INDENT DEDENT)"
-
-;; -----------------------------
-;; Block & Parenthesis terminals
-;; -----------------------------
-%type <block> ;;syntax "\\s(\\|\\s)" matchdatatype block
-
-%token <block> PAREN_BLOCK "(LPAREN RPAREN)"
-%token <block> BRACE_BLOCK "(LBRACE RBRACE)"
-%token <block> BRACK_BLOCK "(LBRACK RBRACK)"
-
-%token <open-paren> LPAREN "("
-%token <close-paren> RPAREN ")"
-%token <open-paren> LBRACE "{"
-%token <close-paren> RBRACE "}"
-%token <open-paren> LBRACK "["
-%token <close-paren> RBRACK "]"
-
-;; ------------------
-;; Operator terminals
-;; ------------------
-%type <punctuation> ;;syntax "\\(\\s.\\|\\s$\\|\\s'\\)+" matchdatatype string
-
-%token <punctuation> LTLTEQ "<<="
-%token <punctuation> GTGTEQ ">>="
-%token <punctuation> EXPEQ "**="
-%token <punctuation> DIVDIVEQ "//="
-%token <punctuation> DIVDIV "//"
-%token <punctuation> LTLT "<<"
-%token <punctuation> GTGT ">>"
-%token <punctuation> EXPONENT "**"
-%token <punctuation> EQ "=="
-%token <punctuation> GE ">="
-%token <punctuation> LE "<="
-%token <punctuation> PLUSEQ "+="
-%token <punctuation> MINUSEQ "-="
-%token <punctuation> MULTEQ "*="
-%token <punctuation> DIVEQ "/="
-%token <punctuation> MODEQ "%="
-%token <punctuation> AMPEQ "&="
-%token <punctuation> OREQ "|="
-%token <punctuation> HATEQ "^="
-%token <punctuation> LTGT "<>"
-%token <punctuation> NE "!="
-%token <punctuation> HAT "^"
-%token <punctuation> LT "<"
-%token <punctuation> GT ">"
-%token <punctuation> AMP "&"
-%token <punctuation> MULT "*"
-%token <punctuation> DIV "/"
-%token <punctuation> MOD "%"
-%token <punctuation> PLUS "+"
-%token <punctuation> MINUS "-"
-%token <punctuation> PERIOD "."
-%token <punctuation> TILDE "~"
-%token <punctuation> BAR "|"
-%token <punctuation> COLON ":"
-%token <punctuation> SEMICOLON ";"
-%token <punctuation> COMMA ","
-%token <punctuation> ASSIGN "="
-%token <punctuation> BACKQUOTE "`"
-%token <punctuation> AT "@"
-%token <punctuation> FOLLOWS "->"
-
-
-;; -----------------
-;; Literal terminals
-;; -----------------
-%token <string> STRING_LITERAL
-
-%type <number> ;;syntax semantic-lex-number-expression
-%token <number> NUMBER_LITERAL
-
-%type <symbol> ;;syntax "\\(\\sw\\|\\s_\\)+"
-%token <symbol> NAME
-
-;; -----------------
-;; Keyword terminals
-;; -----------------
-%type <keyword> ;;syntax "\\(\\sw\\|\\s_\\)+" matchdatatype keyword
-
-%keyword AND "and"
-%put AND summary
-"Logical AND binary operator ... "
-
-%keyword AS "as"
-%put AS summary
-"EXPR as NAME makes value of EXPR available as variable NAME"
-
-%keyword ASSERT "assert"
-%put ASSERT summary
-"Raise AssertionError exception if <expr> is false"
-
-%keyword BREAK "break"
-%put BREAK summary
-"Terminate 'for' or 'while' loop"
-
-%keyword CLASS "class"
-%put CLASS summary
-"Define a new class"
-
-%keyword CONTINUE "continue"
-%put CONTINUE summary
-"Skip to the next iteration of enclosing 'for' or 'while' loop"
-
-%keyword DEF "def"
-%put DEF summary
-"Define a new function"
-
-%keyword DEL "del"
-%put DEL summary
-"Delete specified objects, i.e., undo what assignment did"
-
-%keyword ELIF "elif"
-%put ELIF summary
-"Shorthand for 'else if' following an 'if' statement"
-
-%keyword ELSE "else"
-%put ELSE summary
-"Start the 'else' clause following an 'if' statement"
-
-%keyword EXCEPT "except"
-%put EXCEPT summary
-"Specify exception handlers along with 'try' keyword"
-
-%keyword EXEC "exec"
-%put EXEC summary
-"Dynamically execute Python code"
-
-%keyword FINALLY "finally"
-%put FINALLY summary
-"Specify code to be executed after 'try' statements whether or not an exception occurred"
-
-%keyword FOR "for"
-%put FOR summary
-"Start a 'for' loop"
-
-%keyword FROM "from"
-%put FROM summary
-"Modify behavior of 'import' statement"
-
-%keyword GLOBAL "global"
-%put GLOBAL summary
-"Declare one or more symbols as global symbols"
-
-%keyword IF "if"
-%put IF summary
-"Start 'if' conditional statement"
-
-%keyword IMPORT "import"
-%put IMPORT summary
-"Load specified modules"
-
-%keyword IN "in"
-%put IN summary
-"Part of 'for' statement "
-
-%keyword IS "is"
-%put IS summary
-"Binary operator that tests for object equality"
-
-%keyword LAMBDA "lambda"
-%put LAMBDA summary
-"Create anonymous function"
-
-%keyword NOT "not"
-%put NOT summary
-"Unary boolean negation operator"
-
-%keyword OR "or"
-%put OR summary
-"Binary logical 'or' operator"
-
-%keyword PASS "pass"
-%put PASS summary
-"Statement that does nothing"
-
-%keyword PRINT "print"
-%put PRINT summary
-"Print each argument to standard output"
-
-%keyword RAISE "raise"
-%put RAISE summary
-"Raise an exception"
-
-%keyword RETURN "return"
-%put RETURN summary
-"Return from a function"
-
-%keyword TRY "try"
-%put TRY summary
-"Start of statements protected by exception handlers"
-
-%keyword WHILE "while"
-%put WHILE summary
-"Start a 'while' loop"
-
-%keyword WITH "with"
-%put WITH summary
-"Start statement with an associated context object"
-
-%keyword YIELD "yield"
-%put YIELD summary
-"Create a generator function"
-
-%%
-
-;;;****************************************************************************
-;;;@ goal
-;;;****************************************************************************
-
-;; simple_stmt are statements that do not involve INDENT tokens
-;; compound_stmt are statements that involve INDENT tokens
-goal
- : NEWLINE
- | simple_stmt
- | compound_stmt
- ;
-
-;;;****************************************************************************
-;;;@ simple_stmt
-;;;****************************************************************************
-
-;; simple_stmt: small_stmt (';' small_stmt)* [';'] NEWLINE
-simple_stmt
- : small_stmt_list semicolon_opt NEWLINE
- ;
-
-;; small_stmt (';' small_stmt)*
-small_stmt_list
- : small_stmt
- | small_stmt_list SEMICOLON small_stmt
- ;
-
-small_stmt
- : expr_stmt
- | print_stmt
- | del_stmt
- | pass_stmt
- | flow_stmt
- | import_stmt
- | global_stmt
- | exec_stmt
- | assert_stmt
- ;
-
-;;;============================================================================
-;;;@@ print_stmt
-;;;============================================================================
-
-;; print_stmt: 'print' [ test (',' test)* [','] ]
-;; | '>>' test [ (',' test)+ [','] ]
-print_stmt
- : PRINT print_stmt_trailer
- (CODE-TAG $1 nil)
- ;
-
-;; [ test (',' test)* [','] ] | '>>' test [ (',' test)+ [','] ]
-print_stmt_trailer
- : test_list_opt
- ()
- | GTGT test trailing_test_list_with_opt_comma_opt
- ()
- ;
-
-;; [ (',' test)+ [','] ]
-trailing_test_list_with_opt_comma_opt
- : ;;EMPTY
- | trailing_test_list comma_opt
- ()
- ;
-
-;; (',' test)+
-trailing_test_list
- : COMMA test
- ()
- | trailing_test_list COMMA test
- ()
- ;
-
-;;;============================================================================
-;;;@@ expr_stmt
-;;;============================================================================
-
-;; expr_stmt: testlist (augassign testlist | ('=' testlist)*)
-expr_stmt
- : testlist expr_stmt_trailer
- (if (and $2 (stringp $1) (string-match "^\\(\\sw\\|\\s_\\)+$" $1))
- ;; If this is an assignment statement and left side is a symbol,
- ;; then generate a 'variable token, else return 'code token.
- (VARIABLE-TAG $1 nil nil)
- (CODE-TAG $1 nil))
- ;
-
-;; Could be EMPTY because of eq_testlist_zom.
-;; (augassign testlist | ('=' testlist)*)
-expr_stmt_trailer
- : augassign testlist
- | eq_testlist_zom
- ;
-
-;; Could be EMPTY!
-;; ('=' testlist)*
-eq_testlist_zom
- : ;;EMPTY
- | eq_testlist_zom ASSIGN testlist
- (identity $3)
- ;
-
-;; augassign: '+=' | '-=' | '*=' | '/=' | '%=' | '&=' | '|=' | '^='
-;; | '<<=' | '>>=' | '**=' | '//='
-augassign
- : PLUSEQ | MINUSEQ | MULTEQ | DIVEQ | MODEQ
- | AMPEQ | OREQ | HATEQ | LTLTEQ
- | GTGTEQ | EXPEQ | DIVDIVEQ
- ;
-
-;;;============================================================================
-;;;@@ del_stmt
-;;;============================================================================
-
-;; del_stmt: 'del' exprlist
-del_stmt
- : DEL exprlist
- (CODE-TAG $1 nil)
- ;
-
-;; exprlist: expr (',' expr)* [',']
-exprlist
- : expr_list comma_opt
- ()
- ;
-
-;; expr (',' expr)*
-expr_list
- : expr
- ()
- | expr_list COMMA expr
- ()
- ;
-
-;;;============================================================================
-;;;@@ pass_stmt
-;;;============================================================================
-
-;; pass_stmt: 'pass'
-pass_stmt
- : PASS
- (CODE-TAG $1 nil)
- ;
-
-;;;============================================================================
-;;;@@ flow_stmt
-;;;============================================================================
-
-flow_stmt
- : break_stmt
- | continue_stmt
- | return_stmt
- | raise_stmt
- | yield_stmt
- ;
-
-;; break_stmt: 'break'
-break_stmt
- : BREAK
- (CODE-TAG $1 nil)
- ;
-
-;; continue_stmt: 'continue'
-continue_stmt
- : CONTINUE
- (CODE-TAG $1 nil)
- ;
-
-;; return_stmt: 'return' [testlist]
-return_stmt
- : RETURN testlist_opt
- (CODE-TAG $1 nil)
- ;
-
-;; [testlist]
-testlist_opt
- : ;;EMPTY
- | testlist
- ()
- ;
-
-;; yield_stmt: 'yield' testlist
-yield_stmt
- : YIELD
- (CODE-TAG $1 nil)
- | YIELD testlist
- (CODE-TAG $1 nil)
- ;
-
-;; raise_stmt: 'raise' [test [',' test [',' test]]]
-raise_stmt
- : RAISE zero_one_two_or_three_tests
- (CODE-TAG $1 nil)
- ;
-
-;; [test [',' test [',' test]]]
-zero_one_two_or_three_tests
- : ;;EMPTY
- | test zero_one_or_two_tests
- ()
- ;
-
-;; [',' test [',' test]]
-zero_one_or_two_tests
- : ;;EMPTY
- | COMMA test zero_or_one_comma_test
- ()
- ;
-
-;; [',' test]
-zero_or_one_comma_test
- : ;;EMPTY
- | COMMA test
- ()
- ;
-
-;;;============================================================================
-;;;@@ import_stmt
-;;;============================================================================
-
-;; import_stmt : 'import' dotted_as_name (',' dotted_as_name)*
-;; | 'from' dotted_name 'import'
-;; ('*' | import_as_name (',' import_as_name)*)
-import_stmt
- : IMPORT dotted_as_name_list
- (INCLUDE-TAG $2 nil)
- | FROM dotted_name IMPORT star_or_import_as_name_list
- (INCLUDE-TAG $2 nil)
- ;
-
-;; dotted_as_name (',' dotted_as_name)*
-dotted_as_name_list
- : dotted_as_name_list COMMA dotted_as_name
- (cons $3 $1)
- | dotted_as_name
- (list $1)
- ;
-
-;; ('*' | import_as_name (',' import_as_name)*)
-star_or_import_as_name_list
- : MULT
- ()
- | import_as_name_list
- ()
- ;
-
-;; import_as_name (',' import_as_name)*
-import_as_name_list
- : import_as_name
- ()
- | import_as_name_list COMMA import_as_name
- ()
- ;
-
-;; import_as_name: NAME [NAME NAME]
-import_as_name
- : NAME as_name_opt
- ()
- ;
-
-;; dotted_as_name: dotted_name [AS NAME]
-dotted_as_name
- : dotted_name as_name_opt
- ;
-
-;; [AS NAME]
-as_name_opt
- : ;;EMPTY
- | AS NAME
- (identity $2)
- ;
-
-;; dotted_name: NAME ('.' NAME)*
-dotted_name
- : NAME
- | dotted_name PERIOD NAME
- (format "%s.%s" $1 $3)
- ;
-
-;;;============================================================================
-;;;@@ global_stmt
-;;;============================================================================
-
-;; global_stmt: 'global' NAME (',' NAME)*
-global_stmt
- : GLOBAL comma_sep_name_list
- (CODE-TAG $1 nil)
- ;
-
-;; NAME (',' NAME)*
-comma_sep_name_list
- : NAME
- | comma_sep_name_list COMMA NAME
- ;
-
-;;;============================================================================
-;;;@@ exec_stmt
-;;;============================================================================
-
-;; exec_stmt: 'exec' expr ['in' test [',' test]]
-exec_stmt
- : EXEC expr exec_trailer
- (CODE-TAG $1 nil)
- ;
-
-;; ['in' test [',' test]]
-exec_trailer
- : ;;EMPTY
- | IN test comma_test_opt
- ()
- ;
-
-;; [',' test]
-comma_test_opt
- : ;;EMPTY
- | COMMA test
- ()
- ;
-
-;;;============================================================================
-;;;@@ assert_stmt
-;;;============================================================================
-
-;; assert_stmt: 'assert' test [',' test]
-assert_stmt
- : ASSERT test comma_test_opt
- (CODE-TAG $1 nil)
- ;
-
-;;;****************************************************************************
-;;;@ compound_stmt
-;;;****************************************************************************
-
-compound_stmt
- : if_stmt
- | while_stmt
- | for_stmt
- | try_stmt
- | with_stmt
- | funcdef
- | class_declaration
- ;
-
-;;;============================================================================
-;;;@@ if_stmt
-;;;============================================================================
-
-;; if_stmt: 'if' test ':' suite ('elif' test ':' suite)* ['else' ':' suite]
-if_stmt
- : IF test COLON suite elif_suite_pair_list else_suite_pair_opt
- (CODE-TAG $1 nil)
- ;
-
-;; ('elif' test ':' suite)*
-elif_suite_pair_list
- : ;;EMPTY
- | elif_suite_pair_list ELIF test COLON suite
- ()
- ;
-
-;; ['else' ':' suite]
-else_suite_pair_opt
- : ;;EMPTY
- | ELSE COLON suite
- ()
- ;
-
-;; This NT follows the COLON token for most compound statements.
-;; suite: simple_stmt | NEWLINE INDENT stmt+ DEDENT
-suite
- : simple_stmt
- (list $1)
- | NEWLINE indented_block
- (progn $2)
- ;
-
-indented_block
- : INDENT_BLOCK
- (EXPANDFULL $1 indented_block_body)
- ;
-
-indented_block_body
- : INDENT
- ()
- | DEDENT
- ()
- | simple_stmt
- | compound_stmt
- ;
-
-;;;============================================================================
-;;;@@ while_stmt
-;;;============================================================================
-
-;; while_stmt: 'while' test ':' suite ['else' ':' suite]
-while_stmt
- : WHILE test COLON suite else_suite_pair_opt
- (CODE-TAG $1 nil)
- ;
-
-;;;============================================================================
-;;;@@ for_stmt
-;;;============================================================================
-
-;; for_stmt: 'for' exprlist 'in' testlist ':' suite ['else' ':' suite]
-for_stmt
- : FOR exprlist IN testlist COLON suite else_suite_pair_opt
- (CODE-TAG $1 nil)
- ;
-
-;;;============================================================================
-;;;@@ try_stmt
-;;;============================================================================
-
-;; try_stmt: ('try' ':' suite (except_clause ':' suite)+ #diagram:break
-;; ['else' ':' suite] | 'try' ':' suite 'finally' ':' suite)
-try_stmt
- : TRY COLON suite except_clause_suite_pair_list else_suite_pair_opt
- (CODE-TAG $1 nil)
- | TRY COLON suite FINALLY COLON suite
- (CODE-TAG $1 nil)
- ;
-
-;; (except_clause ':' suite)+
-except_clause_suite_pair_list
- : except_clause COLON suite
- ()
- | except_clause_suite_pair_list except_clause COLON suite
- ()
- ;
-
-;; # NB compile.c makes sure that the default except clause is last
-;; except_clause: 'except' [test [',' test]]
-except_clause
- : EXCEPT zero_one_or_two_test
- ()
- ;
-
-;; [test [',' test]]
-zero_one_or_two_test
- : ;;EMPTY
- | test zero_or_one_comma_test
- ()
- ;
-
-;;;============================================================================
-;;@@ with_stmt
-;;;============================================================================
-
-;; with_stmt: 'with' test [ with_var ] ':' suite
-with_stmt
- : WITH test COLON suite
- (CODE-TAG $1 nil)
- | WITH test with_var COLON suite
- (CODE-TAG $1 nil) ;; TODO capture variable
- ;
-
-with_var
- : AS expr
- () ;; TODO capture
- ;
-
-;;;============================================================================
-;;;@@ funcdef
-;;;============================================================================
-
-decorator
- : AT dotted_name varargslist_opt NEWLINE
- (FUNCTION-TAG $2 "decorator" $3)
- ;
-
-decorators
- : decorator
- (list $1)
- | decorator decorators
- (cons $1 $2)
- ;
-
-;; funcdef: [decorators] 'def' NAME parameters ':' suite
-funcdef
- : DEF NAME function_parameter_list return_type_hint COLON suite
- (wisent-python-reconstitute-function-tag
- (FUNCTION-TAG $2 nil $3) $6)
- | decorators DEF NAME function_parameter_list return_type_hint COLON suite
- (wisent-python-reconstitute-function-tag
- (FUNCTION-TAG $3 nil $4 :decorators $1) $7)
- ;
-
-return_type_hint
- : ;;EMPTY
- | FOLLOWS type
- ;
-
-function_parameter_list
- : PAREN_BLOCK
- (let ((wisent-python-EXPANDING-block t))
- (EXPANDFULL $1 function_parameters))
- ;
-
-;; parameters: '(' [varargslist] ')'
-function_parameters
- : LPAREN
- ()
- | RPAREN
- ()
- | function_parameter COMMA
- | function_parameter RPAREN
- ;
-
-function_parameter
- : fpdef_opt_test
- ;; : NAME
- ;; (VARIABLE-TAG $1 nil nil)
- | MULT NAME
- (VARIABLE-TAG $2 nil nil)
- | EXPONENT NAME
- (VARIABLE-TAG $2 nil nil)
- ;
-
-;;;============================================================================
-;;;@@ class_declaration
-;;;============================================================================
-
-;; classdef: 'class' NAME ['(' testlist ')'] ':' suite
-class_declaration
- : CLASS NAME paren_class_list_opt COLON suite
- (wisent-python-reconstitute-class-tag
- (TYPE-TAG $2 $1 ;; Name "class"
- $5 ;; Members
- (cons $3 nil) ;; (SUPERCLASSES . INTERFACES)
- ))
- ;
-
-;; ['(' testlist ')']
-paren_class_list_opt
- : ;;EMPTY
- | paren_class_list
- ;
-
-paren_class_list
- : PAREN_BLOCK
- (let ((wisent-python-EXPANDING-block t))
- (mapcar #'semantic-tag-name (EXPANDFULL $1 paren_classes)))
- ;
-
-;; parameters: '(' [varargslist] ')'
-paren_classes
- : LPAREN
- ()
- | RPAREN
- ()
- | paren_class COMMA
- (VARIABLE-TAG $1 nil nil)
- | paren_class RPAREN
- (VARIABLE-TAG $1 nil nil)
- ;
-
-;; In general, the base class can be specified by a general expression
-;; which evaluates to a class object, i.e., base classes are not just names!
-;; However base classes are names in most cases. Thus the
-;; non-terminals below work only with simple names. Even if the
-;; parser can parse general expressions, I don't see much benefit in
-;; generating a string of expression as base class "name".
-paren_class
- : type
- ;
-
-;;;****************************************************************************
-;;;@ test
-;;;****************************************************************************
-
-;; test: and_test ('or' and_test)* | lambdef
-test
- : test_test
- | lambdef
- ;
-
-;; and_test ('or' and_test)*
-test_test
- : and_test
- | test_test OR and_test
- ()
- ;
-
-;; and_test: not_test ('and' not_test)*
-and_test
- : not_test
- | and_test AND not_test
- ()
- ;
-
-;; not_test: 'not' not_test | comparison
-not_test
- : NOT not_test
- ()
- | comparison
- ;
-
-;; comparison: expr (comp_op expr)*
-comparison
- : expr
- | comparison comp_op expr
- ()
- ;
-
-;; comp_op: '<'|'>'|'=='|'>='|'<='|'<>'|'!='|'in'|'not' 'in'|'is'|'is' 'not'
-comp_op
- : LT | GT | EQ | GE | LE | LTGT | NE | IN | NOT IN | IS | IS NOT
- ;
-
-;; expr: xor_expr ('|' xor_expr)*
-expr
- : xor_expr
- | expr BAR xor_expr
- ()
- ;
-
-;; xor_expr: and_expr ('^' and_expr)*
-xor_expr
- : and_expr
- | xor_expr HAT and_expr
- ()
- ;
-
-;; and_expr: shift_expr ('&' shift_expr)*
-and_expr
- : shift_expr
- | and_expr AMP shift_expr
- ()
- ;
-
-;; shift_expr: arith_expr (('<<'|'>>') arith_expr)*
-shift_expr
- : arith_expr
- | shift_expr shift_expr_operators arith_expr
- ()
- ;
-
-;; ('<<'|'>>')
-shift_expr_operators
- : LTLT
- | GTGT
- ;
-
-;; arith_expr: term (('+'|'-') term)*
-arith_expr
- : term
- | arith_expr plus_or_minus term
- ()
- ;
-
-;; ('+'|'-')
-plus_or_minus
- : PLUS
- | MINUS
- ;
-
-;; term: factor (('*'|'/'|'%'|'//') factor)*
-term
- : factor
- | term term_operator factor
- ()
- ;
-
-term_operator
- : MULT
- | DIV
- | MOD
- | DIVDIV
- ;
-
-;; factor: ('+'|'-'|'~') factor | power
-factor
- : prefix_operators factor
- ()
- | power
- ;
-
-;; ('+'|'-'|'~')
-prefix_operators
- : PLUS
- | MINUS
- | TILDE
- ;
-
-;; power: atom trailer* ('**' factor)*
-power
- : atom trailer_zom exponent_zom
- (concat $1
- (if $2 (concat " " $2 " ") "")
- (if $3 (concat " " $3) "")
- )
- ;
-
-trailer_zom
- : ;;EMPTY
- | trailer_zom trailer
- ()
- ;
-
-exponent_zom
- : ;;EMPTY
- | exponent_zom EXPONENT factor
- ()
- ;
-
-;; trailer: '(' [arglist] ')' | '[' subscriptlist ']' | '.' NAME
-trailer
- : PAREN_BLOCK
- ()
- | BRACK_BLOCK
- ()
- | PERIOD NAME
- ()
- ;
-
-;; atom: '(' [testlist] ')' | '[' [listmaker] ']' | '{' [dictmaker] '}'
-;; | '`' testlist '`' | NAME | NUMBER | STRING+
-atom
- : PAREN_BLOCK
- ()
- | BRACK_BLOCK
- ()
- | BRACE_BLOCK
- ()
- | BACKQUOTE testlist BACKQUOTE
- ()
- | NAME
- | NUMBER_LITERAL
- | one_or_more_string
- ;
-
-test_list_opt
- : ;;EMPTY
- | testlist
- ()
- ;
-
-;; testlist: test (',' test)* [',']
-testlist
- : comma_sep_test_list comma_opt
- ;
-
-;; test (',' test)*
-comma_sep_test_list
- : test
- | comma_sep_test_list COMMA test
- (format "%s, %s" $1 $3)
- ;
-
-;; (read $1) and (read $2) were done before to peel away the double quotes.
-;; However that does not work for single quotes, so it was taken out.
-one_or_more_string
- : STRING_LITERAL
- | one_or_more_string STRING_LITERAL
- (concat $1 $2)
- ;
-
-;;;****************************************************************************
-;;;@ lambdef
-;;;****************************************************************************
-
-;; lambdef: 'lambda' [varargslist] ':' test
-lambdef
- : LAMBDA varargslist_opt COLON test
- (format "%s %s" $1 (or $2 ""))
- ;
-
-;; [varargslist]
-varargslist_opt
- : ;;EMPTY
- | varargslist
- ;
-
-;; varargslist: (fpdef ['=' test] ',')* ('*' NAME [',' '**' NAME] | '**' NAME)
-;; | fpdef ['=' test] (',' fpdef ['=' test])* [',']
-varargslist
- : fpdef_opt_test_list_comma_zom rest_args
- (nconc $2 $1)
- | fpdef_opt_test_list comma_opt
- ;
-
-;; ('*' NAME [',' '**' NAME] | '**' NAME)
-rest_args
- : MULT NAME multmult_name_opt
- () ;;(VARIABLE-TAG $2 nil nil)
- | EXPONENT NAME
- () ;;(VARIABLE-TAG $2 nil nil)
- ;
-
-;; [',' '**' NAME]
-multmult_name_opt
- : ;;EMPTY
- | COMMA EXPONENT NAME
- (VARIABLE-TAG $3 nil nil)
- ;
-
-fpdef_opt_test_list_comma_zom
- : ;;EMPTY
- | fpdef_opt_test_list_comma_zom fpdef_opt_test COMMA
- (nconc $2 $1)
- ;
-
-;; fpdef ['=' test] (',' fpdef ['=' test])*
-fpdef_opt_test_list
- : fpdef_opt_test
- | fpdef_opt_test_list COMMA fpdef_opt_test
- (nconc $3 $1)
- ;
-
-;; fpdef ['=' test]
-fpdef_opt_test
- : fpdef eq_test_opt
- ;
-
-;; fpdef: NAME | '(' fplist ')'
-fpdef
- : NAME type_hint
- (VARIABLE-TAG $1 nil nil)
- ;; Below breaks the parser. Don't know why, but my guess is that
- ;; LPAREN/RPAREN clashes with the ones in function_parameters.
- ;; | LPAREN fplist RPAREN
- ;; (identity $2)
- ;
-
-;; These rules are now useless because the above rule doesn't refer to them.
-;; ;; fplist: fpdef (',' fpdef)* [',']
-;; fplist
-;; : fpdef_list comma_opt
-;; ;
-
-;; ;; fpdef (',' fpdef)*
-;; fpdef_list
-;; : fpdef
-;; | fpdef_list COMMA fpdef
-;; ;
-
-type_hint
- : ;;EMPTY
- | COLON type
- ;
-
-type
- : test
- ;
-
-;; ['=' test]
-eq_test_opt
- : ;;EMPTY
- | ASSIGN test
- ()
- ;
-
-;;;****************************************************************************
-;;;@ Misc
-;;;****************************************************************************
-
-;; [',']
-comma_opt
- : ;;EMPTY
- | COMMA
- ;
-
-;; [';']
-semicolon_opt
- : ;;EMPTY
- | SEMICOLON
- ;
-
-;;; python.wy ends here
+++ /dev/null
-;;; scheme.by -- Scheme BNF language specification
-
-;; Copyright (C) 2001-2024 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 <https://www.gnu.org/licenses/>.
-
-%package semantic-scm-by
-%provide semantic/bovine/scm-by
-
-%{
-(declare-function semantic-parse-region "semantic"
- (start end &optional nonterminal depth returnonerror))
-}
-
-%languagemode scheme-mode
-%start scheme
-
-%token DEFINE "define"
-%token DEFINE-MODULE "define-module"
-%token MODULE "module"
-%token LOAD "load"
-
-%put DEFINE summary "Function: (define symbol expression)"
-%put DEFINE-MODULE summary "Function: (define-module (name arg1 ...)) "
-%put LOAD summary "Function: (load \"filename\")"
-
-%token <open-paren> OPENPAREN "("
-%token <close-paren> CLOSEPAREN ")"
-
-%%
-
-scheme : semantic-list
- ( ,(let ((expand (EXPAND $1 scheme-list)))
- (cond
- ((semantic-tag-of-class-p expand 'module)
- (TYPE-TAG (semantic-tag-name expand)
- "module"
- (EXPANDFULL $1 scheme)
- nil) ;; Module contains more definitions like a type
- )
- (t
- expand))))
- ;
-
-scheme-list : OPENPAREN scheme-in-list
- ( ,$2 )
- ;
-
-
-scheme-in-list: DEFINE symbol expression
- (VARIABLE-TAG $2 nil $3 )
- | DEFINE name-args opt-doc
- (FUNCTION-TAG (car ,$2) nil (cdr ,$2) )
- | DEFINE-MODULE name-args
- (PACKAGE-TAG (nth (length $2) $2 ) nil)
- | MODULE symbol
- (TAG $1 'module :members nil)
- | LOAD string
- (INCLUDE-TAG (file-name-nondirectory (read $2)) (read $2) )
- | symbol sequence
- (CODE-TAG $1 nil)
- | ;; No match, error
- (TAG "Bad Tag in Sexp" 'error)
- ;
-
-name-args: semantic-list
- (EXPAND $1 name-arg-list)
- ;
-
-name-arg-list : OPENPAREN name-arg-expand
- ( ,$2 )
- ;
-
-name-arg-expand: symbol name-arg-expand
- ( ,(cons $1 ,$2) )
- | ;; EMPTY
- ( )
- ;
-
-opt-doc : string
- | ;; EMPTY
- ;
-
-sequence : expression sequence
- | expression
- ;
-
-expression : symbol
- | semantic-list
- | string
- | number
- ;
-
-;;; scheme.by ends here
+++ /dev/null
-;;; srecode-template.wy --- Semantic Recoder Template parser
-
-;; Copyright (C) 2005-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-;; X-RCS: $Id: srecode-template.wy,v 1.10 2009-01-09 23:01:54 zappo Exp $
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Parser for the Semantic Recoder template language
-;;
-;; Semantic Recoder templates are based on Google Templates
-;; and are at the bottom of the Semantic Recoder API.
-
-%package srecode-template-wy
-%provide srecode/srt-wy
-
-%languagemode srecode-mode
-
-%start template_file
-
-;;; KEYWORDS
-%type <keyword>
-%keyword SET "set"
-%put SET summary "set <name> <value>"
-%keyword SHOW "show"
-%put SHOW summary "show <name> ; to show a section"
-%keyword MACRO "macro"
-%put MACRO summary "... macro \"string\" ..."
-%keyword CONTEXT "context"
-%put CONTEXT summary "context <name>"
-%keyword TEMPLATE "template"
-%put TEMPLATE summary "template <name>\\n <template definition>"
-%keyword SECTIONDICTIONARY "sectiondictionary"
-%put SECTIONDICTIONARY summary "sectiondictionary <name>\\n <dictionary entries>"
-
-%keyword SECTION "section"
-%put SECTION summary
- "section <name>\\n <dictionary entries>\\n end"
-
-%keyword END "end"
-%put END summary
- "section ... end"
-
-%keyword PROMPT "prompt"
-%keyword DEFAULT "default"
-%keyword DEFAULTMACRO "defaultmacro"
-%keyword READ "read"
-%put { PROMPT DEFAULT DEFAULTMACRO READ } summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]"
-%keyword BIND "bind"
-%put BIND summary "bind \"<letter>\""
-
-;;; Punctuation Types
-%type <punctuation> syntax "\\s.+"
-%type <newline>
-%token <newline> newline
-
-%token <separator> TEMPLATE_BLOCK "^----"
-
-;;; Bland default types
-%type <property> syntax ":\\(\\w\\|\\s_\\)*"
-%token <property> property
-
-%type <symbol>
-%token <symbol> symbol
-
-%type <string>
-%token <string> string
-
-%type <number>
-%token <number> number
-
-%%
-
-template_file
- : newline ( )
- | context
- | prompt
- | variable
- | template
- ;
-
-context
- : CONTEXT symbol newline
- (TAG $2 'context)
- ;
-
-prompt
- : PROMPT symbol string opt-default-fcn opt-read-fcn newline
- (TAG $2 'prompt :text (read $3) :default $4 :read $5)
- ;
-
-opt-default-fcn
- : DEFAULT symbol
- (progn (read $2))
- | DEFAULT string
- (progn (read $2))
- | DEFAULTMACRO string
- (progn (cons 'macro (read $2)))
- | ()
- ;
-
-opt-read-fcn
- : READ symbol
- (progn (read $2))
- | ()
- ;
-
-variable
- : SET symbol insertable-string-list newline
- (VARIABLE-TAG $2 nil $3)
- | SET symbol number newline
- ;; This so a common error with priority works.
- ;; Note that "number" still has a string value in the lexer.
- (VARIABLE-TAG $2 nil (list $3))
- | SHOW symbol newline
- (VARIABLE-TAG $2 nil t)
- ;
-
-insertable-string-list
- : insertable-string
- (list $1)
- | insertable-string-list insertable-string
- (append $1 (list $2))
- ;
-
-insertable-string
- : string
- (read $1)
- | MACRO string
- (cons 'macro (read $2))
- ;
-
-template
- : TEMPLATE templatename opt-dynamic-arguments newline
- opt-string
- section-dictionary-list
- TEMPLATE_BLOCK newline
- opt-bind
- (FUNCTION-TAG $2 nil $3 :documentation $5 :code $7
- :dictionaries $6 :binding $9 )
- ;
-
-templatename
- : symbol
- | PROMPT
- | CONTEXT
- | TEMPLATE
- | DEFAULT
- | MACRO
- | DEFAULTMACRO
- | READ
- | SET
- ;
-
-opt-dynamic-arguments
- : property opt-dynamic-arguments
- (cons $1 $2)
- | ()
- ;
-
-opt-string
- : string newline
- ( read $1 )
- | ()
- ;
-
-section-dictionary-list
- : ;; empty
- ()
- | section-dictionary-list flat-section-dictionary
- (append $1 (list $2))
- | section-dictionary-list section-dictionary
- (append $1 (list $2))
- ;
-
-flat-section-dictionary
- : SECTIONDICTIONARY string newline
- flat-dictionary-entry-list
- (cons (read $2) $4)
- ;
-
-flat-dictionary-entry-list
- : ;; empty
- ()
- | flat-dictionary-entry-list flat-dictionary-entry
- (append $1 $2)
- ;
-
-flat-dictionary-entry
- : variable
- (EXPANDTAG $1)
- ;
-
-section-dictionary
- : SECTION string newline
- dictionary-entry-list
- END newline
- (cons (read $2) $4)
- ;
-
-dictionary-entry-list
- : ;; empty
- ()
- | dictionary-entry-list dictionary-entry
- (append $1 $2)
- ;
-
-dictionary-entry
- : variable
- (EXPANDTAG $1)
- | section-dictionary
- (list $1)
- ;
-
-opt-bind
- : BIND string newline
- ( read $2 )
- | ()
- ;
-
-%%
-(define-lex-simple-regex-analyzer srecode-template-property-analyzer
- "Detect and create a dynamic argument properties."
- ":\\(\\w\\|\\s_\\)*" 'property 0)
-
-(define-lex-regex-analyzer srecode-template-separator-block
- "Detect and create a template quote block."
- "^----\n"
- (semantic-lex-push-token
- (semantic-lex-token
- 'TEMPLATE_BLOCK
- (match-end 0)
- (semantic-lex-unterminated-syntax-protection 'TEMPLATE_BLOCK
- (goto-char (match-end 0))
- (re-search-forward "^----$")
- (match-beginning 0))))
- (setq semantic-lex-end-point (point)))
-
-
-(define-lex wisent-srecode-template-lexer
- "Lexical analyzer that handles SRecode Template buffers.
-It ignores whitespace, newlines and comments."
- semantic-lex-newline
- semantic-lex-ignore-whitespace
- semantic-lex-ignore-newline
- semantic-lex-ignore-comments
- srecode-template-separator-block
- srecode-template-wy--<keyword>-keyword-analyzer
- srecode-template-property-analyzer
- srecode-template-wy--<number>-regexp-analyzer
- srecode-template-wy--<symbol>-regexp-analyzer
- srecode-template-wy--<string>-sexp-analyzer
- srecode-template-wy--<punctuation>-string-analyzer
- semantic-lex-default-action
- )
-
-;;; srecode-template.wy ends here
make -C lisp "$@" ldefs-boot.el EMACS=../src/bootstrap-emacs || die "make src error"
-
-# Refresh the prebuilt grammar-wy.el
-grammar_in=lisp/cedet/semantic/grammar-wy.el
-grammar_out=lisp/cedet/semantic/grm-wy-boot.el
-make -C admin/grammars/ ../../$grammar_in EMACS=../../src/bootstrap-emacs
-cp $grammar_in $grammar_out || die "cp grm_wy_boot error"
-
-
echo "Checking status of loaddef files..."
## It probably would be fine to just check+commit lisp/, since
dnl along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
AC_PREREQ([2.65])
-dnl Note this is parsed by (at least) make-dist and lisp/cedet/ede/emacs.el.
AC_INIT([GNU Emacs], [30.0.50], [bug-gnu-emacs@gnu.org], [],
[https://www.gnu.org/software/emacs/])
dnl The admin/ directory used to be excluded from tarfiles.
if test -d $srcdir/admin; then
- SUBDIR_MAKEFILES="$SUBDIR_MAKEFILES admin/charsets/Makefile admin/unidata/Makefile admin/grammars/Makefile"
+ SUBDIR_MAKEFILES="$SUBDIR_MAKEFILES admin/charsets/Makefile admin/unidata/Makefile"
ARCH_INDEPENDENT_CONFIG_FILES([admin/charsets/Makefile])
ARCH_INDEPENDENT_CONFIG_FILES([admin/unidata/Makefile])
- ARCH_INDEPENDENT_CONFIG_FILES([admin/grammars/Makefile])
fi dnl -d admin
DOCMISC_W32 = @DOCMISC_W32@
## Info files to build and install on all platforms.
-INFO_COMMON = auth autotype bovine calc ccmode cl dbus dired-x \
- ede ediff edt efaq eglot eieio emacs-gnutls \
+INFO_COMMON = auth autotype calc ccmode cl dbus dired-x \
+ ediff edt efaq eglot eieio emacs-gnutls \
emacs-mime epa erc ert eshell eudc eww flymake forms gnus \
htmlfontify idlwave ido info.info mairix-el message mh-e \
modus-themes newsticker nxml-mode octave-mode org pcl-cvs pgg \
- rcirc reftex remember sasl sc semantic ses sieve smtpmail \
- speedbar srecode todo-mode tramp transient url use-package \
- vhdl-mode vip viper vtable widget wisent woman
+ rcirc reftex remember sasl sc ses sieve smtpmail \
+ speedbar todo-mode tramp transient url use-package \
+ vhdl-mode vip viper vtable widget woman
## Info files to install on current platform.
INFO_INSTALL = $(INFO_COMMON) $(DOCMISC_W32)
$(buildinfodir)/gnus.info gnus.html: ${srcdir}/gnus-faq.texi
-$(buildinfodir)/semantic.info semantic.dvi semantic.pdf semantic.html: ${srcdir}/sem-user.texi
-
-
## Please can we just rename cc-mode.texi to ccmode.texi...
${buildinfodir}/ccmode.info: \
${srcdir}/cc-mode.texi ${gfdl} ${style} | ${buildinfodir}
+++ /dev/null
-\input texinfo @c -*-texinfo-*-
-@c %**start of header
-@setfilename ../../info/bovine.info
-@set TITLE Bovine parser development
-@set AUTHOR Eric M. Ludlam, David Ponce, and Richard Y. Kim
-@settitle @value{TITLE}
-@include docstyle.texi
-
-@c *************************************************************************
-@c @ Header
-@c *************************************************************************
-
-@c Merge all indexes into a single index for now.
-@c We can always separate them later into two or more as needed.
-@syncodeindex vr cp
-@syncodeindex fn cp
-@syncodeindex ky cp
-@syncodeindex pg cp
-@syncodeindex tp cp
-
-@c @footnotestyle separate
-@c @paragraphindent 2
-@c @@smallbook
-@c %**end of header
-
-@copying
-Copyright @copyright{} 1999--2004, 2012--2024 Free Software Foundation,
-Inc.
-
-@quotation
-Permission is granted to copy, distribute and/or modify this document
-under the terms of the GNU Free Documentation License, Version 1.3 or
-any later version published by the Free Software Foundation; with no
-Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''
-and with the Back-Cover Texts as in (a) below. A copy of the license
-is included in the section entitled ``GNU Free Documentation License''.
-
-(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and
-modify this GNU manual.''
-@end quotation
-@end copying
-
-@dircategory Emacs misc features
-@direntry
-* Bovine: (bovine). Semantic bovine parser development.
-@end direntry
-
-@iftex
-@finalout
-@end iftex
-
-@c @setchapternewpage odd
-@c @setchapternewpage off
-
-@titlepage
-@sp 10
-@title @value{TITLE}
-@author by @value{AUTHOR}
-@page
-@vskip 0pt plus 1 fill
-@insertcopying
-@end titlepage
-@page
-
-@macro semantic{}
-@i{Semantic}
-@end macro
-
-@c *************************************************************************
-@c @ Document
-@c *************************************************************************
-@contents
-
-@node top
-@top @value{TITLE}
-
-The @dfn{bovine} parser is the original @semantic{} parser, and is an
-implementation of an @acronym{LL} parser. It is good for simple
-languages. It has many conveniences making grammar writing easy. The
-conveniences make it less powerful than a Bison-like @acronym{LALR}
-parser. For more information, @pxref{Top,, Wisent Parser Development,
-wisent}.
-
-Bovine @acronym{LL} grammars are stored in files with a @file{.by}
-extension. When compiled, the contents is converted into a file of
-the form @file{NAME-by.el}. This, in turn is byte compiled.
-@xref{top,, Grammar Framework Manual, grammar-fw}.
-
-@ifnottex
-@insertcopying
-@end ifnottex
-
-@menu
-* Starting Rules:: The starting rules for the grammar.
-* Bovine Grammar Rules:: Rules used to parse a language.
-* Optional Lambda Expression:: Actions to take when a rule is matched.
-* Bovine Examples:: Simple Samples.
-* GNU Free Documentation License:: The license for this documentation.
-@c * Index::
-@end menu
-
-@node Starting Rules
-@chapter Starting Rules
-
-In Bison, one and only one nonterminal is designated as the ``start''
-symbol. In @semantic{}, one or more nonterminals can be designated as
-the ``start'' symbol. They are declared following the @code{%start}
-keyword separated by spaces. @xref{start Decl,, Grammar Framework
-Manual, grammar-fw}.
-
-If no @code{%start} keyword is used in a grammar, then the very first
-is used. Internally the first start nonterminal is targeted by the
-reserved symbol @code{bovine-toplevel}, so it can be found by the
-parser harness.
-
-To find locally defined variables, the local context handler needs to
-parse the body of functional code. The @code{scopestart} declaration
-specifies the name of a nonterminal used as the goal to parse a local
-context, @pxref{scopestart Decl,, Grammar Framework Manual,
-grammar-fw}. Internally the
-scopestart nonterminal is targeted by the reserved symbol
-@code{bovine-inner-scope}, so it can be found by the parser harness.
-
-@node Bovine Grammar Rules
-@chapter Bovine Grammar Rules
-
-The rules are what allow the compiler to create tags from a language
-file. Once the setup is done in the prologue, you can start writing
-rules. @xref{Grammar Rules,, Grammar Framework Manual, grammar-fw}.
-
-@example
-@var{result} : @var{components1} @var{optional-semantic-action1})
- | @var{components2} @var{optional-semantic-action2}
- ;
-@end example
-
-@var{result} is a nonterminal, that is a symbol synthesized in your grammar.
-@var{components} is a list of elements that are to be matched if @var{result}
-is to be made. @var{optional-semantic-action} is an optional sequence
-of simplified Emacs Lisp expressions for concocting the parse tree.
-
-In bison, each time an element of @var{components} is found, it is
-@dfn{shifted} onto the parser stack. (The stack of matched elements.)
-When all @var{components}' elements have been matched, it is
-@dfn{reduced} to @var{result}. @xref{Algorithm,,, bison, The GNU Bison Manual}.
-
-A particular @var{result} written into your grammar becomes
-the parser's goal. It is designated by a @code{%start} statement
-(@pxref{Starting Rules}). The value returned by the associated
-@var{optional-semantic-action} is the parser's result. It should be
-a tree of @semantic{} @dfn{tags}, @pxref{Semantic Tags,, Semantic
-Application Development, semantic-appdev}.
-
-@var{components} is made up of symbols. A symbol such as @code{FOO}
-means that a syntactic token of class @code{FOO} must be matched.
-
-@menu
-* How Lexical Tokens Match::
-* Grammar-to-Lisp Details::
-* Order of components in rules::
-@end menu
-
-@node How Lexical Tokens Match
-@section How Lexical Tokens Match
-
-A lexical rule must be used to define how to match a lexical token.
-
-For instance:
-
-@example
-%keyword FOO "foo"
-@end example
-
-Means that @code{FOO} is a reserved language keyword, matched as such
-by looking up into a keyword table, @pxref{keyword Decl,, Grammar
-Framework Manual, grammar-fw}. This is because @code{"foo"} will be
-converted to
-@code{FOO} in the lexical analysis stage. Thus the symbol @code{FOO}
-won't be available any other way.
-
-If we specify our token in this way:
-
-@example
-%token <symbol> FOO "foo"
-@end example
-
-then @code{FOO} will match the string @code{"foo"} explicitly, but it
-won't do so at the lexical level, allowing use of the text
-@code{"foo"} in other forms of regular expressions.
-
-In that case, @code{FOO} is a @code{symbol}-type token. To match, a
-@code{symbol} must first be encountered, and then it must
-@code{string-match "foo"}.
-
-@table @strong
-@item Caution:
-Be especially careful to remember that @code{"foo"}, and more
-generally the %token's match-value string, is a regular expression!
-@end table
-
-Non symbol tokens are also allowed. For example:
-
-@example
-%token <punctuation> PERIOD "[.]"
-
-filename : symbol PERIOD symbol
- ;
-@end example
-
-@code{PERIOD} is a @code{punctuation}-type token that will explicitly
-match one period when used in the above rule.
-
-@table @strong
-@item Please Note:
-@code{symbol}, @code{punctuation}, etc., are predefined lexical token
-types, based on the @dfn{syntax class}-character associations
-currently in effect.
-@end table
-
-@node Grammar-to-Lisp Details
-@section Grammar-to-Lisp Details
-
-For the bovinator, lexical token matching patterns are @emph{inlined}.
-When the grammar-to-lisp converter encounters a lexical token
-declaration of the form:
-
-@example
-%token <@var{type}> @var{token-name} @var{match-value}
-@end example
-
-It substitutes every occurrences of @var{token-name} in rules, by its
-expanded form:
-
-@example
-@var{type} @var{match-value}
-@end example
-
-For example:
-
-@example
-%token <symbol> MOOSE "moose"
-
-find_a_moose: MOOSE
- ;
-@end example
-
-Will generate this pseudo equivalent-rule:
-
-@example
-find_a_moose: symbol "moose" ;; invalid syntax!
- ;
-@end example
-
-Thus, from the bovinator point of view, the @var{components} part of a
-rule is made up of symbols and strings. A string in the mix means
-that the previous symbol must have the additional constraint of
-exactly matching it, as described in @ref{How Lexical Tokens Match}.
-
-@table @strong
-@item Please Note:
-For the bovinator, this task was mixed into the language definition to
-simplify implementation, though Bison's technique is more efficient.
-@end table
-
-@node Order of components in rules
-@section Order of components in rules
-
-If a rule has multiple components, order is important, for example
-
-@example
-headerfile : symbol PERIOD symbol
- | symbol
- ;
-@end example
-
-would match @samp{foo.h} or the @acronym{C++} header @samp{foo}.
-The bovine parser will first attempt to match the long form, and then
-the short form. If they were in reverse order, then the long form
-would never be tested.
-
-@c @xref{Default syntactic tokens}.
-
-@node Optional Lambda Expression
-@chapter Optional Lambda Expressions
-
-The @acronym{OLE} (@dfn{Optional Lambda Expression}) is converted into
-a bovine lambda. This lambda has special short-cuts to simplify
-reading the semantic action definition. An @acronym{OLE} like this:
-
-@example
-( $1 )
-@end example
-
-results in a lambda return which consists entirely of the string
-or object found by matching the first (zeroth) element of match.
-An @acronym{OLE} like this:
-
-@example
-( ,(foo $1) )
-@end example
-
-executes @code{foo} on the first argument, and then splices its return
-into the return list whereas:
-
-@example
-( (foo $1) )
-@end example
-
-executes @code{foo}, and that is placed in the return list.
-
-Here are other things that can appear inline:
-
-@table @code
-@item $1
-The first object matched.
-
-@item ,$1
-The first object spliced into the list (assuming it is a list from a
-non-terminal).
-
-@item '$1
-The first object matched, placed in a list. I.e., @code{( $1 )}.
-
-@item foo
-The symbol @code{foo} (exactly as displayed).
-
-@item (foo)
-A function call to foo which is stuck into the return list.
-
-@item ,(foo)
-A function call to foo which is spliced into the return list.
-
-@item '(foo)
-A function call to foo which is stuck into the return list in a list.
-
-@item (EXPAND @var{$1} @var{nonterminal} @var{depth})
-A list starting with @code{EXPAND} performs a recursive parse on the
-token passed to it (represented by @samp{$1} above.) The
-@dfn{semantic list} is a common token to expand, as there are often
-interesting things in the list. The @var{nonterminal} is a symbol in
-your table which the bovinator will start with when parsing.
-@var{nonterminal}'s definition is the same as any other nonterminal.
-@var{depth} should be at least @samp{1} when descending into a
-semantic list.
-
-@item (EXPANDFULL @var{$1} @var{nonterminal} @var{depth})
-Is like @code{EXPAND}, except that the parser will iterate over
-@var{nonterminal} until there are no more matches. (The same way the
-parser iterates over the starting rule (@pxref{Starting Rules}). This
-lets you have much simpler rules in this specific case, and also lets
-you have positional information in the returned tokens, and error
-skipping.
-
-@item (ASSOC @var{symbol1} @var{value1} @var{symbol2} @var{value2} @dots{})
-This is used for creating an association list. Each @var{symbol} is
-included in the list if the associated @var{value} is non-@code{nil}.
-While the items are all listed explicitly, the created structure is an
-association list of the form:
-
-@example
-((@var{symbol1} . @var{value1}) (@var{symbol2} . @var{value2}) @dots{})
-@end example
-
-@item (TAG @var{name} @var{class} [@var{attributes}])
-This creates one tag in the current buffer.
-
-@table @var
-@item name
-Is a string that represents the tag in the language.
-
-@item class
-Is the kind of tag being create, such as @code{function}, or
-@code{variable}, though any symbol will work.
-
-@item attributes
-Is an optional set of labeled values such as @code{:constant-flag t :parent
-"parenttype"}.
-@end table
-
-@item (TAG-VARIABLE @var{name} @var{type} @var{default-value} [@var{attributes}])
-@itemx (TAG-FUNCTION @var{name} @var{type} @var{arg-list} [@var{attributes}])
-@itemx (TAG-TYPE @var{name} @var{type} @var{members} @var{parents} [@var{attributes}])
-@itemx (TAG-INCLUDE @var{name} @var{system-flag} [@var{attributes}])
-@itemx (TAG-PACKAGE @var{name} @var{detail} [@var{attributes}])
-@itemx (TAG-CODE @var{name} @var{detail} [@var{attributes}])
-Create a tag with @var{name} of respectively the class
-@code{variable}, @code{function}, @code{type}, @code{include},
-@code{package}, and @code{code}.
-See @ref{Creating Tags,, Semantic Application Development,
-semantic-appdev}, for the lisp functions these translate into.
-@end table
-
-If the symbol @code{%quotemode backquote} is specified, then use
-@code{,@@} to splice a list in, and @code{,} to evaluate the expression.
-This lets you send @code{$1} as a symbol into a list instead of having
-it expanded inline.
-
-@node Bovine Examples
-@chapter Examples
-
-The rule:
-
-@example
-any-symbol: symbol
- ;
-@end example
-
-is equivalent to
-
-@example
-any-symbol: symbol
- ( $1 )
- ;
-@end example
-
-which, if it matched the string @samp{"A"}, would return
-
-@example
-( "A" )
-@end example
-
-If this rule were used like this:
-
-@example
-%token <punctuation> EQUAL "="
-@dots{}
-assign: any-symbol EQUAL any-symbol
- ( $1 $3 )
- ;
-@end example
-
-it would match @samp{"A=B"}, and return
-
-@example
-( ("A") ("B") )
-@end example
-
-The letters @samp{A} and @samp{B} come back in lists because
-@samp{any-symbol} is a nonterminal, not an actual lexical element.
-
-To get a better result with nonterminals, use @asis{,} to splice lists
-in like this:
-
-@example
-%token <punctuation> EQUAL "="
-@dots{}
-assign: any-symbol EQUAL any-symbol
- ( ,$1 ,$3 )
- ;
-@end example
-
-which would return
-
-@example
-( "A" "B" )
-@end example
-
-@node GNU Free Documentation License
-@appendix GNU Free Documentation License
-
-@include doclicense.texi
-
-@c There is nothing to index at the moment.
-@ignore
-@node Index
-@unnumbered Index
-@printindex cp
-@end ignore
-
-@iftex
-@contents
-@summarycontents
-@end iftex
-
-@bye
-
-@c Following comments are for the benefit of ispell.
-
-@c LocalWords: bovinator inlined
+++ /dev/null
-\input texinfo
-@setfilename ../../info/ede.info
-@settitle Emacs Development Environment
-@include docstyle.texi
-
-@copying
-This file describes EDE, the Emacs Development Environment.
-
-Copyright @copyright{} 1998--2001, 2004--2005, 2008--2024 Free Software
-Foundation, Inc.
-
-@quotation
-Permission is granted to copy, distribute and/or modify this document
-under the terms of the GNU Free Documentation License, Version 1.3 or
-any later version published by the Free Software Foundation; with no
-Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''
-and with the Back-Cover Texts as in (a) below. A copy of the license
-is included in the section entitled ``GNU Free Documentation License.''
-
-(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and
-modify this GNU manual.''
-@end quotation
-@end copying
-
-@dircategory Emacs misc features
-@direntry
-* EDE: (ede). The Emacs Development Environment.
-@end direntry
-
-@titlepage
-@center @titlefont{EDE (The Emacs Development Environment)}
-@sp 4
-@center by Eric Ludlam
-@page
-@vskip 0pt plus 1filll
-@insertcopying
-@end titlepage
-@page
-
-@macro cedet{}
-@i{CEDET}
-@end macro
-
-@macro semantic{}
-@i{Semantic}
-@end macro
-
-@macro srecode{}
-@i{SRecode}
-@end macro
-
-@macro eieio{}
-@i{EIEIO}
-@end macro
-
-@macro ede{}
-@i{EDE}
-@end macro
-
-@macro cogre{}
-@i{COGRE}
-@end macro
-
-@macro speedbar{}
-@i{Speedbar}
-@end macro
-
-@contents
-
-@node Top
-@top EDE
-@comment node-name, next, previous, up
-
-@ede{} is the Emacs Development Environment: an Emacs extension that
-simplifies building and debugging programs in Emacs. It attempts to
-emulate a typical IDE (Integrated Development Environment). @ede{}
-can manage or create your makefiles and other building environment
-duties, allowing you to concentrate on writing code rather than
-support files. It aims to make it much easier for new programmers to
-learn and adopt GNU ways of doing things.
-
-@ifnottex
-@insertcopying
-@end ifnottex
-
-@menu
-* EDE Project Concepts:: @ede{} Project Concepts
-* EDE Mode:: Turning on @ede{} mode.
-* Quick Start:: Quick start to building a project.
-* Creating a project:: Creating a project.
-* Modifying your project:: Adding and removing files and targets.
-* Building and Debugging:: Initiating a build or debug session.
-* Miscellaneous commands:: Other project related commands.
-* Extending EDE:: Programming and extending @ede{}.
-* GNU Free Documentation License:: The license for this documentation.
-@end menu
-
-@node EDE Project Concepts
-@chapter @ede{} Project Concepts
-
-@ede{} is a generic interface for managing projects. It specifies a
-single set of menus and key bindings, while supporting multiple ways to
-express a project via a build system.
-
-In the subsequent chapters, we will describe the different project
-types (@pxref{Creating a project}), as well as the commands to build
-and debug projects (@pxref{Building and Debugging}).
-
-In @ede{}, a project hierarchy matches a directory hierarchy. The
-project's topmost directory is called the @dfn{project root}, and its
-subdirectories are @dfn{subprojects}.
-
-Each project can contain multiple @dfn{targets}. A target, at the
-simplest level, is a named collection of files within a project. A
-target can specify two different types of information:
-
-@enumerate
-@item
-A collection of files to be added to a distribution (e.g., a tarball
-that you intend to distribute to others).
-
-@item
-A collection of files that can be built into something else (e.g., a
-program or compiled documentation).
-@end enumerate
-
-Lastly, @ede{} provides a way for other tools to easily learn file
-associations. For example, a program might need to restrict some sort
-of search to files in a single target, or to discover the location of
-documentation or interface files. @ede{} can provide this
-information.
-
-@node EDE Mode
-@chapter @ede{} Mode
-
-@ede{} is implemented as a minor mode, which augments other modes such
-as C mode, and Texinfo mode. You can enable @ede{} for all buffers by
-running the command @code{global-ede-mode}, or by putting this in your
-init file:
-
-@example
-(global-ede-mode t)
-@end example
-
-Activating @ede{} adds a menu named @samp{Development} to the menu
-bar. This menu provides several menu items for high-level @ede{}
-commands. These menu items, and their corresponding key bindings, are
-independent of the type of project you are actually working on.
-
-@node Quick Start
-@chapter Quick Start
-
-Once you have @ede{} enabled, you can create a project. This chapter
-provides an example C++ project that will create Automake files for
-compilation.
-
-@section Step 1: Create root directory
-
-First, lets create a directory for our project. For this example,
-we'll start with something in @file{/tmp}.
-
-@example
-C-x C-f /tmp/myproject/README @key{RET}
-M-x make-directory @key{RET} @key{RET}
-@end example
-
-Now put some plain text in your README file to start.
-
-Now, lets create the project:
-
-@example
-M-x ede-new @key{RET} Automake @key{RET} myproject @key{RET}
-@end example
-
-
-Nothing visible happened, but if you use @code{dired} to look at the
-directory, you should see this:
-
-@example
- /tmp/myproject:
- total used in directory 32 available 166643476
- drwxr-xr-x 2 zappo users 4096 2012-02-23 22:10 .
- drwxrwxrwt 73 root root 20480 2012-02-23 22:10 ..
- -rw-r--r-- 1 zappo users 195 2012-02-23 22:10 Project.ede
- -rw-r--r-- 1 zappo users 10 2012-02-23 22:09 README
-@end example
-
-@section Step 2: Create Subdirectories and Files
-
-We'll make a more complex project, so use dired to create some more
-directories using the @kbd{+} key, and typing in new directories:
-
-@example
-+ include @key{RET}
-+ src @key{RET}
-@end example
-
-Now I'll short-cut in this tutorial. Create the following files:
-
-@file{include/myproj.hh}
-@example
-/** myproj.hh ---
- */
-
-#ifndef myproj_hh
-#define myproj_hh 1
-
-#define IMPORTANT_MACRO 1
-
-int my_lib_function();
-
-#endif // myproj_hh
-@end example
-
-
-@file{src/main.cpp}
-@example
-/** main.cpp ---
- */
-
-#include <iostream>
-#include "myproj.hh"
-
-int main() @{
-
-@}
-
-#ifdef IMPORTANT_MACRO
-int my_fcn() @{
-
-@}
-#endif
-@end example
-
-@file{src/mylib.cpp}
-@example
-/** mylib.cpp ---
- *
- * Shared Library to build
- */
-
-int my_lib_function() @{
-
-@}
-@end example
-
-@section Step 3: Create subprojects
-
-@ede{} needs subdirectories to also have projects in them. You can
-now create those projects.
-
-With @file{main.cpp} as your current buffer, type:
-
-@example
-M-x ede-new @key{RET} Automake @key{RET} src @key{RET}
-@end example
-
-and in @file{myproj.hh} as your current buffer, type:
-
-@example
-M-x ede-new @key{RET} Automake @key{RET} include @key{RET}
-@end example
-
-These steps effectively only create the Project.ede file in which you
-will start adding targets.
-
-@section Step 4: Create targets
-
-In order to build a program, you must have targets in your @ede{}
-Projects. You can create targets either from a buffer, or from a
-@code{dired} directory buffer.
-
-Note: If for some reason a directory list buffer, or file does not have the
-@samp{Project} menu item, or if @ede{} key bindings don't work, just
-use @kbd{M-x revert-buffer @key{RET}} to force a refresh. Sometimes
-creating a new project doesn't restart buffers correctly.
-
-Lets start with the header file. In @file{include/myproj.hh}, you
-could use the menu, but we will now start using the @ede{} command prefix
-which is @kbd{C-c .}.
-
-@example
-C-c . t includes @key{RET} miscellaneous @key{RET} y
-@end example
-
-
-This creates a misc target for holding your includes, and then adds
-myproj.hh to the target. Automake (the tool) has better ways to do
-this, but for this project, it is sufficient.
-
-Next, visit the @file{src} directory using dired. There should be a
-@samp{Project} menu. You can create a new target with
-
-@example
-. t myprogram @key{RET} program @key{RET}
-@end example
-
-Note that @kbd{. t} is a command for creating a target. This command
-is also in the menu. This will create a target that will build a
-program. If you want, visit @file{Project.ede} to see the structure
-built so far.
-
-Next, place the cursor on @file{main.cpp}, and use @kbd{. a} to add
-that file to your target.
-
-@example
-. a myprogram @key{RET}
-@end example
-
-Note that these prompts often have completion, so you can just press
-@kbd{TAB} to complete the name @file{myprogram}.
-
-If you had many files to add to the same target, you could mark them
-all in your dired buffer, and add them all at the same time.
-
-Next, do the same for the library by placing the cursor on @file{mylib.cpp}.
-
-@example
-. t mylib @key{RET} sharedobject @key{RET}
-. a mylib @key{RET}
-@end example
-
-@section Step 5: Compile, and fail
-
-Next, we'll try to compile the project, but we aren't done yet, so it
-won't work right away.
-
-Visit @file{/tmp/myproject/Project.ede}. We're starting here because
-we don't have any program files in this directory yet. Now we can use
-the compile command:
-
-@example
-C-c . C
-@end example
-
-Because this is the very first time, it will create a bunch of files
-for you that are required by Automake. It will then use automake to
-build the support infrastructure it needs. This step is skipped if
-you choose just a @file{Makefile} build system.
-
-After the Automake init, it runs compile. You will immediately
-discover the error in main.cpp can't find @file{myproj.hh}. We need
-to go fix this.
-
-@section Step 6: Customizing your project
-
-To fix the failed compile, we need to add
-@file{/tmp/myproject/include} to the include path.
-
-Visit @file{main.cpp}.
-
-@example
-M-x customize-project @key{RET}
-@end example
-
-Select the @samp{[Settings]} subgroup of options. Under
-@samp{Variable :} click @samp{[INS]}. At this point, you need to be
-somewhat savvy with Automake. Add a variable named @samp{CPPFLAGS},
-and set the value to @samp{../include}.
-
-You should see something like this:
-
-@example
-Variables :
-[INS] [DEL] Cons-cell:
- Name: AM_CPPFLAGS
- Value: -I../include
-[INS]
-Variables to set in this Makefile.
-@end example
-
-Click @samp{[Apply]}. Feel free to visit @file{Project.ede} to see
-how it changed the config file.
-
-Compile the whole project again with @kbd{C-c . C} from
-@file{main.cpp}. It should now compile.
-
-@section Step 7: Shared library dependency
-
-Note: Supporting shared libraries for Automake in this way is easy,
-but doing so from a project of type Makefile is a bit tricky. If you
-are creating shared libraries too, stick to Automake projects.
-
-Next, lets add a dependency from @file{main.cpp} on our shared
-library. To do that, update main like this:
-
-@example
-int main() @{
-
- my_lib_function();
-
-@}
-@end example
-
-Now compile with:
-
-@example
-C-c . c
-@end example
-
-where the lower case @kbd{c} compiles just that target. You should
-see an error.
-
-This time, we need to add a dependency from @file{main.cpp} on our shared
-library. To do that, we need to customize our target instead of the
-project. This is because variables such as the include path are
-treated globally, whereas dependencies for a target are target specific.
-
-@example
-M-x customize-target @key{RET}
-@end example
-
-On the first page, you will see an Ldlibs-local section. Add mylib to
-it by first clicking @samp{[INS]}, and they adding the library. It
-should look like this:
-
-@example
-Ldlibs-Local :
-[INS] [DEL] Local Library: libmylib.la
-[INS]
-Libraries that are part of this project. [Hide Rest]
-The full path to these libraries should be specified, such as:
-../lib/libMylib.la or ../ar/myArchive.a
-@end example
-
-You will also see other variables for library related flags and system
-libraries if you need them. Click @samp{[Accept]}, and from
-@file{main.cpp}, again compile the whole project to force all
-dependent elements to compile:
-
-@example
-C-c . C
-@end example
-
-@section Step 8: Run your program
-
-You can run your program directly from @ede{}.
-
-@example
-C-c . R @key{RET} @key{RET}
-@end example
-
-If your program takes command line arguments, you can type them in
-when it offers the command line you want to use to run your program.
-
-@node Creating a project
-@chapter Creating a project
-
-To create a new project, first visit a file that you want to include
-in that project. If you have a hierarchy of directories, first visit
-a file in the topmost directory. From this buffer, type @kbd{M-x
-ede-new}, or click on the @samp{Create Project} item in the
-@samp{Development} menu.
-
-The @command{ede-new} command prompts for the type of project you
-would like to create. Each project type has its own benefits or
-language specific enhancements. Not all projects that @ede{} supports
-also allow creating a new project. Projects such as @code{emacs}
-or @code{linux} are designed to recognize existing projects only.
-Project types such as @samp{Make} and @samp{Automake} do support
-creating new project types with @command{ede-new}.
-
-@itemize
-@item
-For the @samp{Make} project type, @ede{} creates a @dfn{project file},
-called @file{Project.ede}, in each project directory. Information
-about the project is stored in this file. This project autogenerates
-a @file{Makefile}.
-
-@item
-For the @samp{Automake} project type, @ede{} creates a
-@file{Project.ede} project file similar to a @samp{Make} project.
-Unlike a @samp{Make} project, this project autogenerates a
-@file{Makefile.am} file. @ede{} handles the Automake bootstrapping
-routines, which import and maintain a @file{configure.am} script and
-other required files.
-@end itemize
-
-A subproject is merely a project in a subdirectory of another project.
-You can create a subproject by using the @command{ede-new} command (or
-the @samp{Create Project} menu item), while visiting a buffer in a
-subdirectory of the project root. This new project is automatically
-added to the parent project, and will be automatically loaded when
-@ede{} reads the parent project.
-
-When using a project command that involves a makefile, @ede{} uses
-the top-most project's makefile as a starting place for the build. How
-the toplevel project handles subprojects in the build process is
-dependent on that project's type.
-
-@node Modifying your project
-@chapter Modifying your project
-
-In this chapter, we describe the generic features for manipulating
-projects, including the targets and files within them. Subsequent
-chapters, which describe specific project types, will provide more
-detailed information about exactly what these features do.
-
-@menu
-* Add/Remove target::
-* Add/Remove files::
-* Customize Features::
-* Project Local Variables::
-* EDE Project Features::
-@end menu
-
-@node Add/Remove target
-@section Add/Remove target
-
-To create a new target, type @kbd{C-c . t} (@code{ede-new-target}) or
-use the @samp{Add Target} menu item in the @samp{Project Options}
-submenu. This prompts for a target name, and adds the current buffer
-to that target.
-
-The @command{ede-new-target} command also prompts for a @dfn{target
-type}. Each target type has its own build process and class of files
-that it will accept.
-
-To remove a target from the project, type @kbd{M-x ede-delete-target},
-or use the @samp{Remove Target} menu item in the @samp{Project
-Options} submenu.
-
-@node Add/Remove files
-@section Add/Remove files
-
-To add the current file to an existing target, type @kbd{C-c . a}
-(@code{ede-add-file}), or use the @samp{Add File} menu item in the
-@samp{Target Options} submenu.
-
-You can add a file to more than one target; this is OK.
-
-To remove the current file from a target, type @kbd{C-c . d}
-(@code{ede-remove-file}), or use the @samp{Remove File} menu item
-in the @samp{Target Options} submenu. If the file belongs to multiple
-targets, this command prompts for each target it could be removed
-from.
-
-While working in a project, if you visit a file that is not part of an
-existing target, @ede{} automatically prompts for a target. If you do
-not wish to add the file to any target, you can choose @samp{none}.
-You can customize this behavior with the variable
-@command{ede-auto-add-method}.
-
-@node Customize Features
-@section Customize Features
-
-A project, and its targets, are objects using the @samp{EIEIO} object
-system. @xref{Top,,,eieio,EIEIO manual}. These objects have data
-fields containing important information related to your work.
-
-If the high-level functions aren't enough, you can tweak all
-user-customizable fields at any time by running the command
-@command{customize-project} or @command{customize-target}. This loads
-the current project or target into a customization buffer, where you
-can tweak individual slots. This is usually necessary for complex
-projects.
-
-Some project modes do not have a project file, but directly read a
-Makefile or other existing file. Instead of directly editing the
-object, you can edit the file by typing @kbd{C-c . e}
-(@code{ede-edit-file-target}). You should ``rescan'' the project
-afterwards (@pxref{Miscellaneous commands}).
-
-@node Project Local Variables
-@section Project Local Variables
-
-EDE projects can store and manager project local variables. The
-variables are stored in the project, and will be restored when a
-project reloads.
-
-Projects which are not stored on disk WILL NOT restore your project
-local variables later.
-
-You can use @ref{Customize Features} to of the project to edit the
-project local variables. They are under the 'Settings' group as
-``Project Local Variables''.
-
-You can also use @kbd{M-x ede-set} to set a new variable local in the
-mini buffer.
-
-In multi-level projects such as Automake and Make generating projects,
-project local variables are installed from both the TOP most project,
-and the local directory's project. In that way, you can have some
-variables across your whole project, and some specific to a
-subdirectory.
-
-You can use project local variables to set any Emacs variable so that
-buffers belonging to different projects can have different settings.
-
-NOTE: When you use project-local variables with @ref{ede-cpp-root},
-the format is an association list. For example:
-
-@example
-(ede-cpp-root-project "SOMENAME"
- :file "/dir/to/some/file"
- :local-variables
- '((grep-command . "grep -nHi -e ")
- (compile-command . "make -f MyCustomMakefile all")))
-@end example
-
-@node EDE Project Features
-@section EDE Project Features
-
-This section details user facing features of an @ede{} @samp{Make}
-style project. An @samp{Automake} project has similar options (but a
-direct Automake project does not).
-
-To modify any of the specific features mentioned here, you need to
-customize the project or target with @command{customize-project} or
-@command{customize-target}.
-
-When you are customizing, you are directly manipulating slot values in
-@eieio{} objects. @xref{Extending EDE}, if you are interested in
-additional details.
-
-@menu
-* Changing Compilers and Flags::
-* Configurations::
-@end menu
-
-@node Changing Compilers and Flags
-@subsection Changing Compilers and Flags
-
-Targets that build stuff need compilers. To change compilers, you
-need to customize the desired target.
-
-In the @samp{[Make]} section, you can choose a new compiler or linker
-from the list. If a linker you need is not available, you will need
-to create a new one. @xref{Compiler and Linker objects}.
-
-If an existing compiler or linker is close, but you need to modify
-some flag set such as adding an include path you will need to add a
-configuration variable.
-
-To start, you should create the basic setup, and construct a makefile
-with @command{ede-proj-regenerate}. Look in the @file{Makefile} to
-see what commands are inserted. Once you have determined the variable
-you need to modify, you can add a configuration for it.
-@xref{Configurations}.
-
-@node Configurations
-@subsection Configurations
-
-Configurations specify different ways to build a project. For
-example, you may configure a project to be in ``debug'' mode, or
-perhaps in ``release'' mode.
-
-The project, and each target type all have a slot named
-@code{configuration-variables}. To add new variables to a
-configuration find this slot in the custom buffer, and insert a new
-configuration. Name it either ``debug'' or ``release'', then insert
-some number of name/value pairs to it.
-
-You can have any number of valid configurations too. To add a new
-configuration, customize your project. Work in the @samp{[Settings]}
-block for ``configurations''. Add a new named configuration here.
-
-To switch between different active configurations, modify the
-``configuration default'' slot.
-
-@node Building and Debugging
-@chapter Building and Debugging
-
-@ede{} provides the following ``project-aware'' compilation and
-debugging commands:
-
-@table @kbd
-@item C-c . c
-Compile the current target (@code{ede-compile-target}).
-@item C-c . C
-Compile the entire project (@code{ede-compile-project}).
-@item c-c . D
-Debug the current target (@code{ede-debug-target}).
-@item M-x ede-make-dist
-Build a distribution file for your project.
-@end table
-
-These commands are also available from the @samp{Development} menu.
-
-@node Miscellaneous commands
-@chapter Miscellaneous commands
-
-If you opt to go in and edit @ede{} project files directly---for
-instance, by using @kbd{C-c . e} (@pxref{Customize Features})---you
-must then ``rescan'' the project files to update the internal data
-structures. To rescan the current project, type @kbd{C-c . g}
-(@code{ede-rescan-toplevel}).
-
-@ede{} can help you find files in your project, via the command
-@kbd{C-c . f} (@code{ede-find-file}). This prompts for a file name;
-you need not specify the directory. EDE then tries to visit a file
-with that name somewhere in your project.
-
-@ede{} can use external tools to help with file finding. To do this,
-customize @code{ede-locate-setup-options}.
-
-@defvar ede-locate-setup-options
-@anchor{ede-locate-setup-options}
-List of locate objects to try out by default.
-Listed in order of preference. If the first item cannot be used in
-a particular project, then the next one is tried.
-It is always assumed that @dfn{ede-locate-base} is at end of the list.
-@end defvar
-
-@ede{} also provides a project display mode for the speedbar
-(@pxref{Speedbar,,,emacs,GNU Emacs Manual}). This allows you to view
-your source files as they are structured in your project: as a
-hierarchical tree, grouped according to target.
-
-To activate the speedbar in this mode, type @kbd{C-c . s}
-(@code{ede-speedbar}).
-
-@menu
-* Make and Automake projects:: Project types of @samp{ede-project}
-* Automake direct projects:: Project interface on hand-written automake files.
-* Simple projects:: Projects @ede{} doesn't manage.
-@end menu
-
-@node Make and Automake projects
-@section Make and Automake projects
-
-A project of @samp{ede-project} type creates a file called
-@file{Project.ede} in every project directory. This is used to track
-your configuration information. If you configure this project to be
-in @samp{Makefile} mode, then this project will autogenerate a
-@file{Makefile}. If you configure it in @samp{Automake} mode a
-@file{Makefile.am} file will be created. The automake bootstrapping
-routines will also import and maintain a configure.am script and a
-host of other files required by Automake.
-
-@node Automake direct projects
-@section Automake direct projects
-
-The project type that reads @file{Makefile.am} directly is derived
-from the sources of the original @file{project-am.el} mode that was
-distributed independently. This mode eventually became @ede{}. The
-@samp{project-am} project will read existing automake files, but will
-not generate them automatically, or create new ones. As such, it is
-useful as a browsing tool, or as maintenance in managing file lists.
-
-@node Simple projects
-@section Simple Projects
-
-There is a wide array of simple projects. In this case a simple
-project is one that detects, or is directed to identify a directory as
-belonging to a project, but doesn't provide many features of a typical
-@ede{} project. Having the project however allows tools such as
-@semantic{} to find sources and perform project level completions.
-
-
-@menu
-* ede-cpp-root:: This project marks the root of a C/C++ code project.
-* ede-emacs:: A project for working with Emacs.
-* ede-linux:: A project for working with Linux kernels.
-* ede-generic-project:: A project type for wrapping build systems with EDE.
-* Custom Locate:: Customizing how to locate files in a simple project
-@end menu
-
-@node ede-cpp-root
-@subsection ede-cpp-root
-
-The @code{ede-cpp-root} project type allows you to create a single
-object with no save-file in your @file{.emacs} file. It allows @ede{}
-to provide the @semantic{} package with the ability to find header
-files quickly.
-
-The @code{ede-cpp-root} class knows a few things about C++ projects,
-such as the prevalence of "include" directories, and typical
-file-layout stuff. If this isn't sufficient, you can subclass
-@code{ede-cpp-root-project} and add your own tweaks in just a few
-lines. See the end of this file for an example.
-
-In the most basic case, add this to your @file{.emacs} file, modifying
-appropriate bits as needed.
-
-@example
-(ede-cpp-root-project "SOMENAME" :file "/dir/to/some/file")
-@end example
-
-Replace @var{SOMENAME} with whatever name you want, and the filename
-to an actual file at the root of your project. It might be a
-Makefile, a README file. Whatever. It doesn't matter. It's just a
-key to hang the rest of @ede{} off of.
-
-The most likely reason to create this project, is to speed up
-searching for includes files, or to simplify bootstrapping @semantic{}'s
-ability to find files without much user interaction. In conjunction
-with @semantic{} completion, having a short include path is key. You can
-override the default include path and system include path like this:
-
-@example
-(ede-cpp-root-project "NAME" :file "FILENAME"
- :include-path '( "/include" "../include" "/c/include" )
- :system-include-path '( "/usr/include/c++/3.2.2/" )
- :compile-command "make compile"
- :spp-table '( ("MOOSE" . "")
- ("CONST" . "const") ) )
-@end example
-
- In this case each item in the include path list is searched. If the
-directory starts with "/", then that expands to the project root
-directory. If a directory does not start with "/", then it is
-relative to the default-directory of the current buffer when the file
-name is expanded.
-
- The include path only affects C/C++ header files. Use the slot
-@code{:header-match-regexp} to change it.
-
-The @code{:system-include-path} allows you to specify absolute names
-of include directories where system header files can be found.
-These will be applied to files in this project only.
-
-With @code{:compile-command} you can provide a command which should be
-run when calling @code{ede-compile-project}.
-
-The @code{:spp-table} provides a list of project specific #define
-style macros that are unique to this project, passed in to the
-compiler on the command line, or are in special headers.
-See the @code{semantic-lex-c-preprocessor-symbol-map} for more
-on how to format this entry.
-
-If there is a single file in your project, you can instead set the
-@code{:spp-files} to a list of file names relative to the root of your
-project. Specifying this is like setting the variable
-@code{semantic-lex-c-preprocessor-symbol-file} in semantic.
-
-If you want to override the file-finding tool with your own
-function you can do this:
-
-@example
-(ede-cpp-root-project "NAME" :file "FILENAME" :locate-fcn 'MYFCN)
-@end example
-
-Where @var{MYFCN} is a symbol for a function. The locate function can
-be used in place of @code{ede-expand-filename} so you can quickly
-customize your custom target to use specialized local routines instead
-of the default @ede{} routines. The function symbol must take two
-arguments:
-
-@table @var
-@item NAME
-The name of the file to find.
-@item DIR
-The directory root for this cpp-root project.
-@end table
-
-When creating a project with @code{ede-cpp-root}, you can get
-additional configurations via @ref{Project Local Variables}. Be aware
-that the format for project local variables is an association list.
-You cannot use @kbd{M-x ede-set} and have your project local variables
-persist between sessions.
-
-If the cpp-root project style is right for you, but you want a dynamic
-loader, instead of hard-coding path name values in your @file{.emacs}, you
-can do that too, but you will need to write some lisp code.
-
-To do that, you need to add an entry to the
-@code{ede-project-class-files} list, and also provide two functions to
-teach @ede{} how to load your project pattern
-
-It would look like this:
-
-@example
-(defun MY-FILE-FOR-DIR (&optional dir)
- "Return a full file name to the project file stored in DIR."
- <write your code here, or return nil>
- )
-
-(defun MY-ROOT-FCN ()
- "Return the root fcn for `default-directory'"
- ;; You might be able to use 'ede-cpp-root-project-root'
- ;; and not write this at all.
- )
-
-(defun MY-LOAD (dir)
- "Load a project of type `cpp-root' for the directory DIR.
-Return nil if there isn't one."
- ;; Use your preferred construction method here.
- (ede-cpp-root-project "NAME" :file (expand-file-name "FILE" dir)
- :locate-fcn 'MYFCN)
- )
-
-(add-to-list 'ede-project-class-files
- (ede-project-autoload "cpp-root"
- :name "CPP ROOT"
- :file 'ede-cpp-root
- :proj-file 'MY-FILE-FOR-DIR
- :proj-root 'MY-ROOT-FCN
- :load-type 'MY-LOAD
- :class-sym 'ede-cpp-root)
- t)
-@end example
-
-This example only creates an auto-loader, and does not create a new kind
-of project.
-
-@xref{ede-cpp-root-project}, for details about the class that defines
-the @code{ede-cpp-root} project type.
-
-@node ede-emacs
-@subsection ede-emacs
-
-The @code{ede-emacs} project automatically identifies an Emacs source
-tree, and enables EDE project mode for it.
-
-It pre-populates the C Preprocessor symbol map for correct parsing,
-and has an optimized include file identification function.
-
-@node ede-linux
-@subsection ede-linux
-
-The @code{ede-linux} project will automatically identify a Linux
-Kernel source tree, and enable EDE project mode for it.
-
-It pre-populates the C Preprocessor symbol map for reasonable parsing,
-and has an optimized include file identification function.
-
-Through the variables @code{project-linux-build-directory-default} and
-@code{project-linux-architecture-default}, you can set the build
-directory and its architecture, respectively. The default is to assume that
-the build happens in the source directory and to auto-detect the
-architecture; if the auto-detection fails, you will be asked.
-
-@node ede-generic-project
-@subsection ede-generic-project
-
-The @code{ede-generic-project} is a project system that makes it easy
-to wrap up different kinds of build systems as an EDE project.
-Projects such as @ref{ede-emacs} require coding skills to create.
-Generic projects also require writing Emacs Lisp code, but the
-requirements are minimal. You can then use
-@command{customize-project} to configure build commands, includes, and
-other options for that project. The configuration is saved in
-@file{EDEConfig.el}.
-
-Generic projects are disabled by default because they have the
-potential to interfere with other projects. To use the generic
-project system to start detecting projects, you need to enable it.
-
-@deffn Command ede-enable-generic-projects
-Enable generic project loaders.
-
-This enables generic loaders for projects that are detected using
-either a @file{Makefile}, @file{SConstruct}, or @file{CMakeLists}.
-
-You do not need to use this command if you create your own generic
-project type.
-@end deffn
-
-If you want to create your own generic project loader, you need to
-define your own project and target classes, and create an autoloader.
-The example for Makefiles looks like this:
-
-@example
-;;; MAKEFILE
-
-(defclass ede-generic-makefile-project (ede-generic-project)
- ((buildfile :initform "Makefile"))
- "Generic Project for makefiles.")
-
-(cl-defmethod ede-generic-setup-configuration ((proj ede-generic-makefile-project) config)
- "Set up a configuration for Make."
- (oset config build-command "make -k")
- (oset config debug-command "gdb "))
-
-(ede-generic-new-autoloader "generic-makefile" "Make"
- "Makefile" 'ede-generic-makefile-project)
-@end example
-
-This example project will detect any directory with the file
-@file{Makefile} in it as belonging to this project type.
-Customization of the project will allow you to make build and debug
-commands more precise.
-
-@node Custom Locate
-@subsection Custom Locate
-
-The various simple project styles all have one major drawback, which
-is that the files in the project are not completely known to EDE@.
-When the EDE API is used to try and file files by some reference name
-in the project, then that could fail.
-
-@ede{} can therefore use some external locate commands, such as the unix
-``locate'' command, or ``GNU Global''.
-
-Configuration of the tool you want to use such as @code{locate}, or
-@code{global} will need to be done without the aid of @ede{}. Once
-configured, however, @ede{} can use it.
-
-To enable one of these tools, set the variable
-@code{ede-locate-setup-options} with the names of different locate
-objects. @ref{Miscellaneous commands}.
-
-Configure this in your @file{.emacs} before loading in CEDET or EDE@.
-If you want to add support for GNU Global, your configuration would
-look like this:
-
-@example
-(setq ede-locate-setup-options '(ede-locate-global ede-locate-base))
-@end example
-
-That way, when a search needs to be done, it will first try using
-GLOBAL@. If global is not available for that directory, then it will
-revert to the base locate object. The base object always fails to
-find a file.
-
-You can add your own locate tool but subclassing from
-@code{ede-locate-base}. The subclass should also implement two
-methods. See the code in @file{ede-locate.el} for GNU Global as a
-simple example.
-
-@@TODO - Add ID Utils and CScope examples
-
-More on idutils and cscope is in the CEDET manual, and they each have
-their own section.
-
-@node Extending EDE
-@chapter Extending @ede{}
-
-This chapter is intended for users who want to write new parts or fix
-bugs in @ede{}. A knowledge of Emacs Lisp, and some @eieio{}(CLOS) is
-required.
-
-@ede{} uses @eieio{}, the CLOS package for Emacs, to define two object
-superclasses, specifically the PROJECT and TARGET@. All commands in
-@ede{} are usually meant to address the current project, or current
-target.
-
-All specific projects in @ede{} derive subclasses of the @ede{}
-superclasses. In this way, specific behaviors such as how a project is
-saved, or how a target is compiled can be customized by a project author
-in detail. @ede{} communicates to these project objects via an API
-using methods. The commands you use in @ede{} mode are high-level
-functional wrappers over these methods. @xref{Top,,, eieio, EIEIO
-manual}, for details on using @eieio{} to extending classes, and writing
-methods.
-
-If you intend to extend @ede{}, it is most likely that a new target type is
-needed in one of the existing project types. The rest of this chapter
-will discuss extending the @code{ede-project} class, and its targets.
-See @file{project-am.el} for basic details on adding targets to it.
-
-For the @code{ede-project} type, the core target class is called
-@code{ede-proj-target}. Inheriting from this will give you everything
-you need to start, including adding your sources into the makefile. If
-you also need additional rules in the makefile, you will want to inherit
-from @code{ede-proj-target-makefile} instead. You may want to also add
-new fields to track important information.
-
-If you are building currently unsupported code into a program or shared
-library, it is unlikely you need a new target at all. Instead you
-would need to create a new compiler or linker object that compiles
-source code of the desired type. @ref{Compiler and Linker objects}.
-
-Once your new class exists, you will want to fill in some basic methods.
-See the @file{ede-skel.el} file for examples of these. The files
-@file{ede-proj-info.el} and @file{ede-proj-elisp.el} are two interesting
-examples.
-
-@menu
-* Development Overview::
-* Detecting a Project::
-* User interface methods:: Methods associated with key bindings
-* Base project methods:: The most basic methods on @ede{} objects.
-* Sourcecode objects:: Defining new sourcecode classes.
-* Compiler and Linker objects:: Defining new compilers and linkers.
-* Project:: Details of project classes.
-* Targets:: Details of target classes.
-* Sourcecode:: Details of source code classes.
-* Compilers:: Details of compiler classes.
-@end menu
-
-@node Development Overview
-@section Development Overview
-
-@ede{} is made up of a series of classes implemented with @eieio{}.
-These classes define an interface that can be used to create different
-types of projects.
-
-@ede{} defines two superclasses which are @code{ede-project} and
-@code{ede-target}. All commands in @ede{} are usually meant to
-address the current project, or current target.
-
-All specific projects in @ede{} derive subclasses of the @ede{} superclasses.
-In this way, specific behaviors such as how a project is saved, or how a
-target is compiled can be customized by a project author in detail. @ede{}
-communicates to these project objects via an API using methods. The
-commands you use in @ede{} mode are high-level functional wrappers over
-these methods.
-
-Some example project types are:
-
-@table @code
-@item project-am
-Automake project which reads existing Automake files.
-@item ede-proj-project
-This project type will create @file{Makefiles},
-or @file{Makefile.am} files to compile your project.
-@item ede-linux
-This project type will detect linux source trees.
-@item ede-emacs
-This project will detect an Emacs source tree.
-@end table
-
-There are several other project types as well.
-
-The first class you need to know to create a new project type is
-@code{ede-project-autoload}. New instances of this class are needed
-to define how Emacs associates different files/buffers with different
-project types. All the autoloads are kept in the variable
-@code{ede-project-class-files}.
-
-The next most important class to know is @code{ede-project}. This is
-the baseclass defines how all projects behave. The basic pattern for
-a project is that there is one project per directory, and the topmost
-project or directory defines the project as a whole.
-
-Key features of @code{ede-project} are things like name and version
-number. It also holds a list of @code{ede-target} objects and a list
-of sub projects, or more @code{ede-project} objects.
-
-New project types must subclass @code{ede-project} to add special
-behavior. New project types also need to subclass @code{ede-target} to
-add specialty behavior.
-
-In this way, the common @ede{} interface is designed to work against
-@code{ede-project}, and thus all subclasses.
-
-@code{ede-project} subclasses @code{ede-project-placeholder}. This is
-the minimum necessary project needed to be cached between runs of
-Emacs. This way, Emacs can track all projects ever seen, without
-loading those projects into memory.
-
-Here is a high-level UML diagram for the @ede{} system created with @cogre{}..
-
-@example
-+-----------------------+ +-----------------------+
-| | |ede-project-placeholder|
-|ede-project-class-files| +-----------------------+
-| | +-----------------------+
-+-----------------------+ +-----------------------+
- /\ ^
- \/ /_\
- | |
- +--------------------+ +-----------+ +----------+
- |ede-project-autoload| |ede-project| |ede-target|
- +--------------------+<>--------------+-----------+<>-------+----------+
- +--------------------+ +-----------+ +----------+
- +--------------------+ +-----------+ +----------+
- ^
- /_\
- |
- +---------------------+-----------------+
- | | |
- | | |
- | | |
- +----------------+ +-------------------+ +---------+
- |ede-proj-project| |project-am-makefile| |ede-emacs|
- +----------------+ +-------------------+ +---------+
- +----------------+ +-------------------+ +---------+
- +----------------+ +-------------------+ +---------+
-@end example
-
-
-@node Detecting a Project
-@section Detecting a Project
-
-Project detection happens with the list of @code{ede-project-autoload}
-instances stored in @code{ede-project-class-files}. The full project
-detection scheme works like this:
-
-@table @asis
-@item Step 1:
-@code{find-file-hook} calls @code{ede-turn-on-hook} on BUFFER.
-@item Step 2:
-@code{ede-turn-on-hook} turns on @code{ede-minor-mode}
-@item Step 3:
-@code{ede-minor-mode} looks to see if BUFFER is associated with any
-open projects. If not, it calls @code{ede-load-project-file} to find
-a project associated with the current directory BUFFER is in.
-@item Step 4:
-@code{ede-minor-mode} associates the found project with the current
-buffer with a series of variables, such as @code{ede-object}, and
-@code{ede-object-project} and @code{ede-object-root-project}.
-@end table
-
-Once a buffer is associated, @ede{} minor mode commands will operate
-on that buffer.
-
-The function @code{ede-load-project-file} is at the heart of detecting
-projects, and it works by looping over all the known project autoload
-types in @code{ede-project-autoload} using the utility
-@code{ede-directory-project-p}.
-
-The function @code{ede-directory-project-p} will call
-@code{ede-dir-to-projectfile} on every @code{ede-project-autoload}
-until one of them returns true. The method
-@code{ede-dir-to-projectfile} in turn gets the @code{:proj-file} slot
-from the autoload. If it is a string (i.e., a project file name), it
-checks to see if that exists in BUFFER's directory. If it is a
-function, then it calls that function and expects it to return a file
-name or @code{nil}. If the file exists, then this directory is assumed to be
-part of a project, and @code{ede-directory-project-p} returns the
-instance of @code{ede-project-autoload} that matched.
-
-If the current directory contains the file @code{.ede-ignore} then
-that directory is automatically assumed to contain no projects, even
-if there is a matching pattern. Use this type of file in a directory
-that may contain many other sub projects, but still has a Makefile of
-some sort.
-
-If the current directory is a project, then @ede{} scans upwards till
-it finds the top of the project. It does this by calling
-@code{ede-toplevel-project}. If this hasn't already been discovered,
-the directories as scanned upward one at a time until a directory with
-no project is found. The last found project becomes the project
-root. If the found instance of @code{ede-project-autoload} has a
-valid @code{proj-root} slot value, then that function is called instead
-of scanning the project by hand. Some project types have a short-cut
-for determining the root of a project, so this comes in handy.
-
-Getting back to @code{ede-load-project-file}, this now has an instance
-of @code{ede-project-autoload}. It uses the @code{load-type} slot to
-both autoload in the project type, and to create a new instance of the
-project type found for the root of the project. That project is added
-to the global list of all projects. All subprojects are then created
-and assembled into the project data structures.
-
-
-@node User interface methods
-@section User interface methods
-
-These methods are core behaviors associated with user commands.
-If you do not implement a method, there is a reasonable default that
-may do what you need.
-
-@table @code
-@item project-add-file
-Add a file to your project. Override this if you want to put new
-sources into different fields depending on extension, or other details.
-@item project-remove-file
-Reverse of project-add-file.
-@item project-compile-target
-Override this if you want to do something special when the user
-"compiles" this target.
-@item project-debug-target
-What to do when a user wants to debug your target.
-@item project-update-version
-Easily update the version number of your project.
-@item project-edit-file-target
-Edit the file the project's information is stored in.
-@item project-new-target
-Create a new target in a project.
-@item project-delete-target
-Delete a target from a project.
-@item project-make-dist
-Make a distribution (tar archive) of the project.
-@item project-rescan
-Rescan a project file, changing the data in the existing objects.
-@end table
-
-@node Base project methods
-@section Base project methods
-
-These methods are important for querying base information from project
-and target types:
-
-@table @code
-@item ede-name
-Return a string that is the name of this target.
-@item ede-target-name
-Return a string that is the name of the target used by a Make system.
-@item ede-description
-A brief description of the project or target. This is currently used
-by the @samp{ede-speedbar} interface.
-@item ede-want-file-p
-Return non-@code{nil} if a target will accept a given file.
-It is generally unnecessary to override this. See the section on source
-code.
-@item ede-buffer-mine
-Return non-@code{nil} if a buffer belongs to this target. Used during
-association when a file is loaded. It is generally unnecessary to
-override this unless you keep auxiliary files.
-@end table
-
-These methods are used by the semantic package extensions.
-@xref{Top,,, semantic, Semantic manual}.
-
-@table @code
-@item ede-buffer-header-file
-Return a header file belonging to a given buffer. Prototypes are place
-there when appropriate
-@item ede-buffer-documentation-files
-Return the documentation file information about this file would be
-stored in.
-@item ede-documentation
-List all documentation a project or target is responsible for.
-@end table
-
-@node Sourcecode objects
-@section Sourcecode objects
-
-@ede{} projects track source file / target associates via source code
-objects. The definitions for this is in @file{ede-source.el}. A source
-code object contains methods that know how to identify a file as being
-of that class, (i.e., a C file ends with @file{.c}). Some targets can
-handle many different types of sources which must all be compiled
-together. For example, a mixed C and C++ program would have
-instantiations of both sourcecode types.
-
-When a target needs to know if it will accept a source file, it
-references its list of source code objects. These objects then make
-that decision.
-
-Source code objects are stored in the target objects as a list of
-symbols, where the symbol's value is the object. This enables the
-project save file mechanism to work.
-
-Here is an example for an instantiation of an Emacs Lisp source code object:
-
-@example
-(defvar ede-source-emacs
- (ede-sourcecode "ede-emacs-source"
- :name "Emacs Lisp"
- :sourcepattern "\\.el$"
- :garbagepattern '("*.elc"))
- "Emacs Lisp source code definition.")
-@end example
-
-If you want to recycle parts of an existing sourcecode object, you can
-clone the original, and then just tweak the parts that are different.
-For example:
-
-@example
-(defvar ede-source-emacs-autoload
- (clone ede-source-emacs "ede-source-emacs-autoload"
- :name "Emacs Lisp Autoload"
- :sourcepattern "-loaddefs\\.el")
- "Emacs Lisp autoload source code.")
-@end example
-
-In this case, the garbage pattern is the same.
-
-@xref{Sourcecode}.
-
-@node Compiler and Linker objects
-@section Compiler and Linker objects
-
-In order for a target to create a @file{Makefile}, it must know how to
-compile the sources into the program or desired data file, and
-possibly link them together.
-
-A compiler object instantiation is used to associate a given target
-with a given source code type. Some targets can handle many types of
-sources, and thus has many compilers available to it. Some targets
-may have multiple compilers for a given type of source code.
-
-@ede{} will examine the actual source files in a target, cross reference
-that against the compiler list to come up with the final set of
-compilers that will be inserted into the Makefile.
-
-Compiler instantiations must also insert variables specifying the
-compiler it plans to use, in addition to creating Automake settings for
-@file{configure.ac} when appropriate.
-
-Compiler objects are stored in the target objects as a list of
-symbols, where the symbols value is the object. This enables the
-project output mechanism to work more efficiently.
-
-Targets will also have a special "compiler" slot which lets a user
-explicitly choose the compiler they want to use.
-
-Here is an example for texinfo:
-
-@example
-(defvar ede-makeinfo-compiler
- (ede-compiler
- "ede-makeinfo-compiler"
- :name "makeinfo"
- :variables '(("MAKEINFO" . "makeinfo"))
- :commands '("makeinfo -o $@ $<")
- :autoconf '(("AC_CHECK_PROG" . "MAKEINFO, makeinfo"))
- :sourcetype '(ede-makeinfo-source)
- )
- "Compile texinfo files into info files.")
-@end example
-
-@xref{Compilers}.
-
-When creating compiler instantiations, it may be useful to @code{clone}
-an existing compiler variable. Cloning allows you to only modify
-parts of the original, while keeping the rest of the same.
-Modification of the original will result in the clone also being
-changed for shared value slots.
-
-The second important object is the linker class. The linker is similar
-to the compiler, except several compilers might be used to create some
-object files, and only one linker is used to link those objects together.
-
-See @file{ede-proj-obj.el} for examples of the combination.
-
-@defindex pj
-@defindex tg
-@defindex sc
-@defindex cm
-
-@node Project
-@section Project
-
-@menu
-* ede-project-placeholder::
-* ede-project::
-* ede-cpp-root-project::
-* ede-simple-project::
-* ede-simple-base-project::
-* ede-proj-project::
-* project-am-makefile::
-* ede-step-project::
-@end menu
-
-@node ede-project-placeholder
-@subsection ede-project-placeholder
-@pjindex ede-project-placeholder
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-project-placeholder
-@table @asis
-@item Children:
-@xref{ede-project}.
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :name
-Type: @code{string} @*
-Default Value: @code{"Untitled"}
-
-The name used when generating distribution files.
-
-@item :version
-Type: @code{string} @*
-Default Value: @code{"1.0"}
-
-The version number used when distributing files.
-
-@item :directory
-Type: @code{string}
-
-Directory this project is associated with.
-
-@item :file
-Type: @code{string}
-
-File name where this project is stored.
-
-@end table
-
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method ede--project-inode :AFTER proj
-Get the inode of the directory project @var{PROJ} is in.
-@end deffn
-
-@deffn Method ede-project-root :AFTER this
-If a project knows its root, return it here.
-Allows for one-project-object-for-a-tree type systems.
-@end deffn
-
-@deffn Method ede-find-subproject-for-directory :AFTER proj dir
-Find a subproject of @var{PROJ} that corresponds to @var{DIR}.
-@end deffn
-
-@deffn Method ede-project-root-directory :AFTER this &optional file
-If a project knows its root, return it here.
-Allows for one-project-object-for-a-tree type systems.
-Optional @var{FILE} is the file to test. It is ignored in preference
-of the anchor file for the project.
-@end deffn
-
-@deffn Method ede-project-force-load :AFTER this
-Make sure the placeholder @var{THIS} is replaced with the real thing.
-Return the new object created in its place.
-@end deffn
-
-@deffn Method project-interactive-select-target :AFTER this prompt
-Make sure placeholder @var{THIS} is replaced with the real thing, and pass through.
-@end deffn
-
-@deffn Method project-add-file :AFTER this file
-Make sure placeholder @var{THIS} is replaced with the real thing, and pass through.
-@end deffn
-
-@node ede-project
-@subsection ede-project
-@pjindex ede-project
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-project-placeholder
-@xref{ede-project-placeholder}.
-@table @code
-@item ede-project
-@table @asis
-@item Children:
-@xref{ede-cpp-root-project}, @w{ede-emacs-project,} @w{ede-linux-project,} @w{ede-maven-project,} @xref{ede-simple-project}, @xref{ede-simple-base-project}, @xref{ede-proj-project}, @xref{project-am-makefile}, @xref{ede-step-project}.
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :targets
-Type: @code{list}
-
-List of top level targets in this project.
-
-@item :tool-cache
-Type: @code{list}
-
-List of tool cache configurations in this project.
-This allows any tool to create, manage, and persist project-specific settings.
-
-@item :web-site-url
-Type: @code{string} @*
-
-URL to this projects web site.
-This is a URL to be sent to a web site for documentation.
-
-@item :web-site-directory @*
-
-A directory where web pages can be found by Emacs.
-For remote locations use a path compatible with ange-ftp.
-You can also use TRAMP for use with rcp & scp.
-
-@item :web-site-file @*
-
-A file which contains the website for this project.
-This file can be relative to slot @code{web-site-directory}.
-This can be a local file, use ange-ftp or TRAMP.
-
-@item :ftp-site
-Type: @code{string} @*
-
-FTP site where this project's distribution can be found.
-This FTP site should be in Emacs form, as needed by @code{ange-ftp}, but can
-also be of a form used by TRAMP for use with scp, or rcp.
-
-@item :ftp-upload-site
-Type: @code{string} @*
-
-FTP Site to upload new distributions to.
-This FTP site should be in Emacs form as needed by @code{ange-ftp}.
-If this slot is @code{nil}, then use @code{ftp-site} instead.
-
-@item :configurations
-Type: @code{list} @*
-Default Value: @code{("debug" "release")}
-
-List of available configuration types.
-Individual target/project types can form associations between a configuration,
-and target specific elements such as build variables.
-
-@item :configuration-default @*
-Default Value: @code{"debug"}
-
-The default configuration.
-
-@item :local-variables @*
-Default Value: @code{nil}
-
-Project local variables
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-preprocessor-map :AFTER this
-Get the pre-processor map for project @var{THIS}.
-@end deffn
-
-@deffn Method ede-subproject-relative-path :AFTER proj &optional parent-in
-Get a path name for @var{PROJ} which is relative to the parent project.
-If PARENT is specified, then be relative to the PARENT project.
-Specifying PARENT is useful for sub-sub projects relative to the root project.
-@end deffn
-
-@deffn Method eieio-speedbar-description :AFTER obj
-Provide a speedbar description for @var{OBJ}.
-@end deffn
-
-@deffn Method ede-map-any-target-p :AFTER this proc
-For project @var{THIS}, map @var{PROC} to all targets and return if any non-@code{nil}.
-Return the first non-@code{nil} value returned by @var{PROC}.
-@end deffn
-
-@deffn Method ede-map-subprojects :AFTER this proc
-For object @var{THIS}, execute @var{PROC} on all direct subprojects.
-This function does not apply @var{PROC} to sub-sub projects.
-See also @dfn{ede-map-all-subprojects}.
-@end deffn
-
-@deffn Method ede-convert-path :AFTER this path
-Convert path in a standard way for a given project.
-Default to making it project relative.
-Argument @var{THIS} is the project to convert @var{PATH} to.
-@end deffn
-
-@deffn Method ede-name :AFTER this
-Return a short-name for @var{THIS} project file.
-Do this by extracting the lowest directory name.
-@end deffn
-
-@deffn Method ede-set-project-variables :AFTER project &optional buffer
-Set variables local to @var{PROJECT} in @var{BUFFER}.
-@end deffn
-
-@deffn Method eieio-speedbar-derive-line-path :AFTER obj &optional depth
-Return the path to @var{OBJ}.
-Optional @var{DEPTH} is the depth we start at.
-@end deffn
-
-@deffn Method ede-map-all-subprojects :AFTER this allproc
-For object @var{THIS}, execute PROC on @var{THIS} and all subprojects.
-This function also applies PROC to sub-sub projects.
-See also @dfn{ede-map-subprojects}.
-@end deffn
-
-@deffn Method project-update-version :AFTER ot
-The @code{:version} of the project @var{OT} has been updated.
-Handle saving, or other detail.
-@end deffn
-
-@deffn Method ede-buffer-header-file :AFTER this buffer
-Return @code{nil}, projects don't have header files.
-@end deffn
-
-@deffn Method ede-buffer-documentation-files :AFTER this buffer
-Return all documentation in project @var{THIS} based on @var{BUFFER}.
-@end deffn
-
-@deffn Method ede-map-targets :AFTER this proc
-For object @var{THIS}, execute @var{PROC} on all targets.
-@end deffn
-
-@deffn Method ede-buffer-mine :AFTER this buffer
-Return non-@code{nil} if object @var{THIS} lays claim to the file in @var{BUFFER}.
-@end deffn
-
-@deffn Method ede-object-keybindings :BEFORE this
-Retrieves the slot @code{keybindings} from an object of class @code{ede-project}
-@end deffn
-
-@deffn Method ede-description :AFTER this
-Return a description suitable for the minibuffer about @var{THIS}.
-@end deffn
-
-@deffn Method eieio-speedbar-object-children :AFTER this
-Return the list of speedbar display children for @var{THIS}.
-@end deffn
-
-@deffn Method project-make-dist :AFTER this
-Build a distribution for the project based on @var{THIS} project.
-@end deffn
-
-@deffn Method ede-system-include-path :AFTER this
-Get the system include path used by project @var{THIS}.
-@end deffn
-
-@deffn Method project-new-target-custom :AFTER proj
-Create a new target. It is up to the project @var{PROJ} to get the name.
-@end deffn
-
-@deffn Method ede-subproject-p :AFTER proj
-Return non-@code{nil} if @var{PROJ} is a sub project.
-@end deffn
-
-@deffn Method ede-expand-filename :AFTER this filename &optional force
-Return a fully qualified file name based on project @var{THIS}.
-@var{FILENAME} should be just a filename which occurs in a directory controlled
-by this project.
-Optional argument @var{FORCE} forces the default filename to be provided even if it
-doesn't exist.
-@end deffn
-
-@deffn Method ede-menu-items-build :AFTER obj &optional current
-Return a list of menu items for building project @var{OBJ}.
-If optional argument @var{CURRENT} is non-@code{nil}, return sub-menu code.
-@end deffn
-
-@deffn Method ede-update-version-in-source :AFTER this version
-Change occurrences of a version string in sources.
-In project @var{THIS}, cycle over all targets to give them a chance to set
-their sources to @var{VERSION}.
-@end deffn
-
-@deffn Method project-new-target :AFTER proj &rest args
-Create a new target. It is up to the project @var{PROJ} to get the name.
-@end deffn
-
-@deffn Method project-compile-project :AFTER obj &optional command
-Compile the entire current project @var{OBJ}.
-Argument @var{COMMAND} is the command to use when compiling.
-@end deffn
-
-@deffn Method eieio-speedbar-object-buttonname :AFTER object
-Return a string to use as a speedbar button for @var{OBJECT}.
-@end deffn
-
-@deffn Method ede-map-project-buffers :AFTER this proc
-For @var{THIS}, execute @var{PROC} on all buffers belonging to @var{THIS}.
-@end deffn
-
-@deffn Method ede-expand-filename-impl :AFTER this filename &optional force
-Return a fully qualified file name based on project @var{THIS}.
-@var{FILENAME} should be just a filename which occurs in a directory controlled
-by this project.
-Optional argument @var{FORCE} forces the default filename to be provided even if it
-doesn't exist.
-@end deffn
-
-@deffn Method eieio-done-customizing :AFTER proj
-Call this when a user finishes customizing @var{PROJ}.
-@end deffn
-
-@deffn Method ede-html-documentation :AFTER this
-Return a list of HTML files provided by project @var{THIS}.
-@end deffn
-
-@deffn Method ede-documentation :AFTER this
-Return a list of files that provides documentation.
-Documentation is not for object @var{THIS}, but is provided by @var{THIS} for other
-files in the project.
-@end deffn
-
-@deffn Method project-interactive-select-target :AFTER this prompt
-Interactively query for a target that exists in project @var{THIS}.
-Argument @var{PROMPT} is the prompt to use when querying the user for a target.
-@end deffn
-
-@deffn Method ede-target-in-project-p :AFTER proj target
-Is @var{PROJ} the parent of @var{TARGET}?
-If @var{TARGET} belongs to a subproject, return that project file.
-@end deffn
-
-@deffn Method ede-find-target :AFTER proj buffer
-Fetch the target in @var{PROJ} belonging to @var{BUFFER} or @code{nil}.
-@end deffn
-
-@deffn Method ede-add-subproject :AFTER proj-a proj-b
-Add into @var{PROJ-A}, the subproject @var{PROJ-B}.
-@end deffn
-
-@deffn Method ede-commit-project :AFTER proj
-Commit any change to @var{PROJ} to its file.
-@end deffn
-
-@deffn Method project-dist-files :AFTER this
-Return a list of files that constitutes a distribution of @var{THIS} project.
-@end deffn
-
-@deffn Method ede-object-menu :BEFORE this
-Retrieves the slot @code{menu} from an object of class @code{ede-project}
-@end deffn
-
-@deffn Method ede-commit-local-variables :AFTER proj
-Commit change to local variables in @var{PROJ}.
-@end deffn
-
-@node ede-cpp-root-project
-@subsection ede-cpp-root-project
-@pjindex ede-cpp-root-project
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-project-placeholder
-@xref{ede-project-placeholder}.
-@table @code
-@item ede-project
-@xref{ede-project}.
-@table @code
-@item ede-cpp-root-project
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-This class implements the @code{ede-cpp-root} project type.
-@xref{ede-cpp-root}, for information about using this project type.
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :include-path
-Type: @code{list} @*
-Default Value: @code{("/include" "../include/")}
-
-The default locate function expands filenames within a project.
-If a header file (.h, .hh, etc.)@: name is expanded, and
-the @code{:locate-fcn} slot is @code{nil}, then the include path is checked
-first, and other directories are ignored. For very large
-projects, this optimization can save a lot of time.
-
-Directory names in the path can be relative to the current
-buffer's @code{default-directory} (not starting with a /). Directories
-that are relative to the project's root should start with a /, such
-as "/include", meaning the directory @code{include} off the project root
-directory.
-
-@item :system-include-path
-Type: @code{list} @*
-Default Value: @code{nil}
-
-The system include path for files in this project.
-C files initialized in an ede-cpp-root-project have their semantic
-system include path set to this value. If this is @code{nil}, then the
-semantic path is not modified.
-
-@item :spp-table
-Type: @code{list} @*
-Default Value: @code{nil}
-
-C Preprocessor macros for your files.
-Preprocessor symbols will be used while parsing your files.
-These macros might be passed in through the command line compiler, or
-are critical symbols derived from header files. Providing header files
-macro values through this slot improves accuracy and performance.
-Use @code{:spp-files} to use these files directly.
-
-@item :spp-files
-Type: @code{list} @*
-Default Value: @code{nil}
-
-C header file with Preprocessor macros for your files.
-The PreProcessor symbols appearing in these files will be used while
-parsing files in this project.
-See @code{semantic-lex-c-preprocessor-symbol-map} for more on how this works.
-
-@item :header-match-regexp
-Type: @code{string} @*
-Default Value: @code{"\\.\\(h\\(h\\|xx\\|pp\\|\\+\\+\\)?\\|H\\)$\\|\\<\\w+$"}
-
-Regexp used to identify C/C++ header files.
-
-@item :locate-fcn
-Type: @code{(or null function)} @*
-Default Value: @code{nil}
-
-The locate function can be used in place of
-@dfn{ede-expand-filename} so you can quickly customize your custom target
-to use specialized local routines instead of the EDE routines.
-The function symbol must take two arguments:
- NAME - The name of the file to find.
- DIR - The directory root for this cpp-root project.
-
-It should return the fully qualified file name passed in from NAME@.
-If that file does not exist, it should return @code{nil}.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method initialize-instance :AFTER this &rest fields
-Make sure the @code{:file} is fully expanded.
-@end deffn
-
-@deffn Method ede-preprocessor-map :AFTER this
-Get the pre-processor map for project @var{this}.
-@end deffn
-
-@deffn Method ede-cpp-root-header-file-p :AFTER proj name
-Non-@code{nil} if in @var{proj} the filename @var{name} is a header.
-@end deffn
-
-@deffn Method ede-system-include-path :AFTER this
-Get the system include path used by project @var{this}.
-@end deffn
-
-@deffn Method ede-expand-filename-impl :AFTER proj name
-Within this project @var{proj}, find the file @var{name}.
-This knows details about or source tree.
-@end deffn
-
-@node ede-simple-project
-@subsection ede-simple-project
-@pjindex ede-simple-project
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-project-placeholder
-@xref{ede-project-placeholder}.
-@table @code
-@item ede-project
-@xref{ede-project}.
-@table @code
-@item ede-simple-project
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method ede-commit-project :AFTER proj
-Commit any change to @var{PROJ} to its file.
-@end deffn
-
-@node ede-simple-base-project
-@subsection ede-simple-base-project
-@pjindex ede-simple-base-project
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-project-placeholder
-@xref{ede-project-placeholder}.
-@table @code
-@item ede-project
-@xref{ede-project}.
-@table @code
-@item ede-simple-base-project
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
- EDE Simple project base class.
-This one project could control a tree of subdirectories.
-
-@table @asis
-@end table
-
-@node ede-proj-project
-@subsection ede-proj-project
-@pjindex ede-proj-project
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-project-placeholder
-@xref{ede-project-placeholder}.
-@table @code
-@item ede-project
-@xref{ede-project}.
-@table @code
-@item ede-proj-project
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :makefile-type
-Type: @code{symbol} @*
-Default Value: @code{Makefile}
-
-The type of Makefile to generate.
-Can be one of @code{'Makefile}, 'Makefile.in, or 'Makefile.am.
-If this value is NOT @code{'Makefile}, then that overrides the @code{:makefile} slot
-in targets.
-
-@item :variables
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Variables to set in this Makefile.
-
-@item :configuration-variables
-Type: @code{list} @*
-Default Value: @code{("debug" (("DEBUG" . "1")))}
-
-Makefile variables to use in different configurations.
-These variables are used in the makefile when a configuration becomes active.
-
-@item :inference-rules @*
-Default Value: @code{nil}
-
-Inference rules to add to the makefile.
-
-@item :include-file @*
-Default Value: @code{nil}
-
-Additional files to include.
-These files can contain additional rules, variables, and customizations.
-
-@item :automatic-dependencies
-Type: @code{boolean} @*
-Default Value: @code{t}
-
-Non-@code{nil} to do implement automatic dependencies in the Makefile.
-
-@item :metasubproject
-Type: @code{boolean} @*
-Default Value: @code{nil}
-
-Non-@code{nil} if this is a metasubproject.
-Usually, a subproject is determined by a parent project. If multiple top level
-projects are grouped into a large project not maintained by EDE, then you need
-to set this to non-@code{nil}. The only effect is that the @code{dist} rule will then avoid
-making a tar file.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-makefile-create :AFTER this mfilename
-Create a Makefile for all Makefile targets in @var{THIS}.
-@var{MFILENAME} is the makefile to generate.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-rules :AFTER this
-Insert rules needed by @var{THIS} target.
-@end deffn
-
-@deffn Method ede-proj-makefile-tags :AFTER this targets
-Insert into the current location rules to make recursive TAGS files.
-Argument @var{THIS} is the project to create tags for.
-Argument @var{TARGETS} are the targets we should depend on for TAGS.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-variables :AFTER this
-Insert variables needed by target @var{THIS}.
-@end deffn
-
-@deffn Method project-make-dist :AFTER this
-Build a distribution for the project based on @var{THIS} target.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-dist-rules :AFTER this
-Insert distribution rules for @var{THIS} in a Makefile, such as CLEAN and DIST.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-dist-dependencies :AFTER this
-Insert any symbols that the DIST rule should depend on.
-Argument @var{THIS} is the project that should insert stuff.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-subproj-rules :AFTER this
-Insert a rule for the project @var{THIS} which should be a subproject.
-@end deffn
-
-@deffn Method ede-proj-makefile-create-maybe :AFTER this mfilename
-Create a Makefile for all Makefile targets in @var{THIS} if needed.
-@var{MFILENAME} is the makefile to generate.
-@end deffn
-
-@deffn Method ede-proj-configure-test-required-file :AFTER this file
-For project @var{THIS}, test that the file @var{FILE} exists, or create it.
-@end deffn
-
-@deffn Method ede-proj-setup-buildenvironment :AFTER this &optional force
-Setup the build environment for project @var{THIS}.
-Handles the Makefile, or a Makefile.am configure.ac combination.
-Optional argument @var{FORCE} will force items to be regenerated.
-@end deffn
-
-@deffn Method ede-proj-makefile-garbage-patterns :AFTER this
-Return a list of patterns that are considered garbage to @var{THIS}.
-These are removed with make clean.
-@end deffn
-
-@deffn Method ede-proj-configure-synchronize :AFTER this
-Synchronize what we know about project @var{THIS} into configure.ac.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-variables-new :AFTER this
-Insert variables needed by target @var{THIS}.
-
-NOTE: Not yet in use! This is part of an SRecode conversion of
- EDE that is in progress.
-@end deffn
-
-@deffn Method ede-proj-makefile-configuration-variables :AFTER this configuration
-Return a list of configuration variables from @var{THIS}.
-Use @var{CONFIGURATION} as the current configuration to query.
-@end deffn
-
-@deffn Method eieio-done-customizing :AFTER proj
-Call this when a user finishes customizing this object.
-Argument @var{PROJ} is the project to save.
-@end deffn
-
-@deffn Method ede-proj-configure-recreate :AFTER this
-Delete project @var{THIS}'s configure script and start over.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-user-rules :AFTER this
-Insert user specified rules needed by @var{THIS} target.
-This is different from @dfn{ede-proj-makefile-insert-rules} in that this
-function won't create the building rules which are auto created with
-automake.
-@end deffn
-
-@deffn Method ede-proj-dist-makefile :AFTER this
-Return the name of the Makefile with the DIST target in it for @var{THIS}.
-@end deffn
-
-@deffn Method ede-proj-configure-file :AFTER this
-The configure.ac script used by project @var{THIS}.
-@end deffn
-
-@deffn Method ede-commit-project :AFTER proj
-Commit any change to @var{PROJ} to its file.
-@end deffn
-
-@deffn Method project-dist-files :AFTER this
-Return a list of files that constitutes a distribution of @var{THIS} project.
-@end deffn
-
-@deffn Method ede-commit-local-variables :AFTER proj
-Commit change to local variables in @var{PROJ}.
-@end deffn
-
-@node project-am-makefile
-@subsection project-am-makefile
-@pjindex project-am-makefile
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-project-placeholder
-@xref{ede-project-placeholder}.
-@table @code
-@item ede-project
-@xref{ede-project}.
-@table @code
-@item project-am-makefile
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method project-am-subtree :AFTER ampf subdir
-Return the sub project in @var{AMPF} specified by @var{SUBDIR}.
-@end deffn
-
-@deffn Method project-targets-for-file :AFTER proj
-Return a list of targets the project @var{PROJ}.
-@end deffn
-
-@deffn Method project-new-target :AFTER proj &optional name type
-Create a new target named @var{NAME}.
-Argument @var{TYPE} is the type of target to insert. This is a string
-matching something in @code{project-am-type-alist} or type class symbol.
-Despite the fact that this is a method, it depends on the current
-buffer being in order to provide a smart default target type.
-@end deffn
-
-@node ede-step-project
-@subsection ede-step-project
-@pjindex ede-step-project
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-project-placeholder
-@xref{ede-project-placeholder}.
-@table @code
-@item ede-project
-@xref{ede-project}.
-@table @code
-@item ede-step-project
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :init-variables
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Variables to set in this Makefile, at top of file.
-
-@item :additional-variables
-Type: @code{(or null list)} @*
-Default Value: @code{nil}
-
-Arbitrary variables needed from this project.
-It is safe to leave this blank.
-
-@item :additional-rules
-Type: @code{(or null list)} @*
-Default Value: @code{nil}
-
-Arbitrary rules and dependencies needed to make this target.
-It is safe to leave this blank.
-
-@item :installation-domain
-Type: @code{symbol} @*
-Default Value: @code{user}
-
-Installation domain specification.
-The variable GNUSTEP_INSTALLATION_DOMAIN is set at this value.
-
-@item :preamble
-Type: @code{(or null list)} @*
-Default Value: @code{("GNUmakefile.preamble")}
-
-The auxiliary makefile for additional variables.
-Included just before the specific target files.
-
-@item :postamble
-Type: @code{(or null list)} @*
-Default Value: @code{("GNUmakefile.postamble")}
-
-The auxiliary makefile for additional rules.
-Included just after the specific target files.
-
-@item :metasubproject
-Type: @code{boolean} @*
-Default Value: @code{nil}
-
-Non-@code{nil} if this is a metasubproject.
-Usually, a subproject is determined by a parent project. If multiple top level
-projects are grouped into a large project not maintained by EDE, then you need
-to set this to non-@code{nil}. The only effect is that the @code{dist} rule will then avoid
-making a tar file.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-makefile-create :AFTER this mfilename
-Create a GNUmakefile for all Makefile targets in @var{THIS}.
-@var{MFILENAME} is the makefile to generate.
-@end deffn
-
-@deffn Method project-make-dist :AFTER this
-Build a distribution for the project based on @var{THIS} target.
-@end deffn
-
-@deffn Method ede-proj-makefile-create-maybe :AFTER this mfilename
-Create a Makefile for all Makefile targets in @var{THIS} if needed.
-@var{MFILENAME} is the makefile to generate.
-@end deffn
-
-@deffn Method ede-proj-setup-buildenvironment :AFTER this &optional force
-Setup the build environment for project @var{THIS}.
-Handles the Makefile, or a Makefile.am configure.ac combination.
-Optional argument @var{FORCE} will force items to be regenerated.
-@end deffn
-
-@deffn Method eieio-done-customizing :AFTER proj
-Call this when a user finishes customizing this object.
-Argument @var{PROJ} is the project to save.
-@end deffn
-
-@deffn Method ede-proj-dist-makefile :AFTER this
-Return the name of the Makefile with the DIST target in it for @var{THIS}.
-@end deffn
-
-@deffn Method ede-commit-project :AFTER proj
-Commit any change to @var{PROJ} to its file.
-@end deffn
-
-@deffn Method project-dist-files :AFTER this
-Return a list of files that constitutes a distribution of @var{THIS} project.
-@end deffn
-
-@deffn Method ede-commit-local-variables :AFTER proj
-Commit change to local variables in @var{PROJ}.
-@end deffn
-
-@node Targets
-@section Targets
-
-@menu
-* ede-target::
-* ede-proj-target::
-* ede-proj-target-makefile::
-* semantic-ede-proj-target-grammar::
-* ede-proj-target-makefile-objectcode::
-* ede-proj-target-makefile-archive::
-* ede-proj-target-makefile-program::
-* ede-proj-target-makefile-shared-object::
-* ede-proj-target-elisp::
-* ede-proj-target-elisp-autoloads::
-* ede-proj-target-makefile-miscelaneous::
-* ede-proj-target-makefile-info::
-* ede-proj-target-scheme::
-* project-am-target::
-* project-am-objectcode::
-* project-am-program::
-* project-am-header-noinst::
-* project-am-header-inst::
-* project-am-lisp::
-* project-am-texinfo::
-* project-am-man::
-@end menu
-
-
-@node ede-target
-@subsection ede-target
-@tgindex ede-target
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@table @asis
-@item Children:
-@w{ede-cpp-root-target,} @w{ede-emacs-target-c,} @w{ede-emacs-target-el,} @w{ede-emacs-target-misc,} @w{ede-linux-target-c,} @w{ede-linux-target-misc,} @w{ede-maven-target-java,} @w{ede-maven-target-c,} @w{ede-maven-target-misc,} @w{ede-simple-target,} @xref{ede-proj-target}, @xref{project-am-target}.
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :name
-Type: @code{string}
-
-Name of this target.
-
-@item :path
-Type: @code{string}
-
-The path to the sources of this target.
-Relative to the path of the project it belongs to.
-
-@item :source
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Source files in this target.
-
-@item :versionsource
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Source files with a version string in them.
-These files are checked for a version string whenever the EDE version
-of the master project is changed. When strings are found, the version
-previously there is updated.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-preprocessor-map :AFTER this
-Get the pre-processor map for project @var{THIS}.
-@end deffn
-
-@deffn Method eieio-speedbar-description :AFTER obj
-Provide a speedbar description for @var{OBJ}.
-@end deffn
-
-@deffn Method project-compile-target :AFTER obj &optional command
-Compile the current target @var{OBJ}.
-Argument @var{COMMAND} is the command to use for compiling the target.
-@end deffn
-
-@deffn Method project-debug-target :AFTER obj
-Run the current project target @var{OBJ} in a debugger.
-@end deffn
-
-@deffn Method ede-convert-path :AFTER this path
-Convert path in a standard way for a given project.
-Default to making it project relative.
-Argument @var{THIS} is the project to convert @var{PATH} to.
-@end deffn
-
-@deffn Method ede-name :AFTER this
-Return the name of @var{THIS} target.
-@end deffn
-
-@deffn Method ede-target-buffer-in-sourcelist :AFTER this buffer source
-Return non-@code{nil} if object @var{THIS} is in @var{BUFFER} to a @var{SOURCE} list.
-Handles complex path issues.
-@end deffn
-
-@deffn Method eieio-speedbar-derive-line-path :AFTER obj &optional depth
-Return the path to @var{OBJ}.
-Optional @var{DEPTH} is the depth we start at.
-@end deffn
-
-@deffn Method ede-buffer-header-file :AFTER this buffer
-There are no default header files in EDE@.
-Do a quick check to see if there is a Header tag in this buffer.
-@end deffn
-
-@deffn Method project-remove-file :AFTER ot fnnd
-Remove the current buffer from project target @var{OT}.
-Argument @var{FNND} is an argument.
-@end deffn
-
-@deffn Method ede-buffer-documentation-files :AFTER this buffer
-Check for some documentation files for @var{THIS}.
-Also do a quick check to see if there is a Documentation tag in this @var{BUFFER}.
-@end deffn
-
-@deffn Method ede-map-target-buffers :AFTER this proc
-For @var{THIS}, execute @var{PROC} on all buffers belonging to @var{THIS}.
-@end deffn
-
-@deffn Method eieio-speedbar-child-description :AFTER obj
-Provide a speedbar description for a plain-child of @var{OBJ}.
-A plain child is a child element which is not an EIEIO object.
-@end deffn
-
-@deffn Method ede-object-keybindings :BEFORE this
-Retrieves the slot @code{keybindings} from an object of class @code{ede-target}
-@end deffn
-
-@deffn Method ede-description :AFTER this
-Return a description suitable for the minibuffer about @var{THIS}.
-@end deffn
-
-@deffn Method eieio-speedbar-object-children :AFTER this
-Return the list of speedbar display children for @var{THIS}.
-@end deffn
-
-@deffn Method ede-system-include-path :AFTER this
-Get the system include path used by project @var{THIS}.
-@end deffn
-
-@deffn Method ede-object-sourcecode :BEFORE this
-Retrieves the slot @code{sourcetype} from an object of class @code{ede-target}
-@end deffn
-
-@deffn Method ede-expand-filename :AFTER this filename &optional force
-Return a fully qualified file name based on target @var{THIS}.
-@var{FILENAME} should be a filename which occurs in a directory in which @var{THIS} works.
-Optional argument @var{FORCE} forces the default filename to be provided even if it
-doesn't exist.
-@end deffn
-
-@deffn Method ede-menu-items-build :AFTER obj &optional current
-Return a list of menu items for building target @var{OBJ}.
-If optional argument @var{CURRENT} is non-@code{nil}, return sub-menu code.
-@end deffn
-
-@deffn Method ede-want-file-p :AFTER this file
-Return non-@code{nil} if @var{THIS} target wants @var{FILE}.
-@end deffn
-
-@deffn Method ede-update-version-in-source :AFTER this version
-In sources for @var{THIS}, change version numbers to @var{VERSION}.
-@end deffn
-
-@deffn Method project-delete-target :AFTER ot
-Delete the current target @var{OT} from its parent project.
-@end deffn
-
-@deffn Method ede-target-sourcecode :AFTER this
-Return the sourcecode objects which @var{THIS} permits.
-@end deffn
-
-@deffn Method eieio-speedbar-child-make-tag-lines :AFTER this depth
-Create a speedbar tag line for a child of @var{THIS}.
-It has depth @var{DEPTH}.
-@end deffn
-
-@deffn Method eieio-speedbar-object-buttonname :AFTER object
-Return a string to use as a speedbar button for @var{OBJECT}.
-@end deffn
-
-@deffn Method eieio-done-customizing :AFTER target
-Call this when a user finishes customizing @var{TARGET}.
-@end deffn
-
-@deffn Method project-edit-file-target :AFTER ot
-Edit the target @var{OT} associated with this file.
-@end deffn
-
-@deffn Method ede-documentation :AFTER this
-Return a list of files that provides documentation.
-Documentation is not for object @var{THIS}, but is provided by @var{THIS} for other
-files in the project.
-@end deffn
-
-@deffn Method ede-want-file-source-p :AFTER this file
-Return non-@code{nil} if @var{THIS} target wants @var{FILE}.
-@end deffn
-
-@deffn Method ede-want-file-auxiliary-p :AFTER this file
-Return non-@code{nil} if @var{THIS} target wants @var{FILE}.
-@end deffn
-
-@deffn Method project-add-file :AFTER ot file
-Add the current buffer into project target @var{OT}.
-Argument @var{FILE} is the file to add.
-@end deffn
-
-@deffn Method ede-target-name :AFTER this
-Return the name of @var{THIS} target, suitable for make or debug style commands.
-@end deffn
-
-@deffn Method ede-object-menu :BEFORE this
-Retrieves the slot @code{menu} from an object of class @code{ede-target}
-@end deffn
-
-@node ede-proj-target
-@subsection ede-proj-target
-@tgindex ede-proj-target
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@table @asis
-@item Children:
-@xref{ede-proj-target-makefile}, @w{ede-proj-target-aux,} @xref{ede-proj-target-scheme}.
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :name
-Type: @code{string}
-
-Name of this target.
-
-@item :path
-Type: @code{string}
-
-The path to the sources of this target.
-Relative to the path of the project it belongs to.
-
-@item :auxsource
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Auxiliary source files included in this target.
-Each of these is considered equivalent to a source file, but it is not
-distributed, and each should have a corresponding rule to build it.
-
-@item :compiler
-Type: @code{(or null symbol)} @*
-Default Value: @code{nil}
-
-The compiler to be used to compile this object.
-This should be a symbol, which contains the object defining the compiler.
-This enables save/restore to do so by name, permitting the sharing
-of these compiler resources, and global customization thereof.
-
-@item :linker
-Type: @code{(or null symbol)} @*
-Default Value: @code{nil}
-
-The linker to be used to link compiled sources for this object.
-This should be a symbol, which contains the object defining the linker.
-This enables save/restore to do so by name, permitting the sharing
-of these linker resources, and global customization thereof.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method project-compile-target :AFTER obj &optional command
-Compile the current target @var{OBJ}.
-Argument @var{COMMAND} is the command to use for compiling the target.
-@end deffn
-
-@deffn Method project-debug-target :AFTER obj
-Run the current project target @var{OBJ} in a debugger.
-@end deffn
-
-@deffn Method ede-proj-configure-add-missing :AFTER this
-Query if any files needed by @var{THIS} provided by automake are missing.
-Results in --add-missing being passed to automake.
-@end deffn
-
-@deffn Method ede-proj-flush-autoconf :AFTER this
-Flush the configure file (current buffer) to accommodate @var{THIS}.
-By flushing, remove any cruft that may be in the file. Subsequent
-calls to @dfn{ede-proj-tweak-autoconf} can restore items removed by flush.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-rules :AFTER this
-Insert rules needed by @var{THIS} target.
-@end deffn
-
-@deffn Method project-remove-file :AFTER target file
-For @var{TARGET}, remove @var{FILE}.
-@var{FILE} must be massaged by @dfn{ede-convert-path}.
-@end deffn
-
-@deffn Method ede-proj-configure-create-missing :AFTER this
-Add any missing files for @var{THIS} by creating them.
-@end deffn
-
-@deffn Method ede-proj-makefile-sourcevar :AFTER this
-Return the variable name for @var{THIS}'s sources.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-variables :AFTER this &optional moresource
-Insert variables needed by target @var{THIS}.
-Optional argument @var{MORESOURCE} is a list of additional sources to add to the
-sources variable.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-automake-post-variables :AFTER this
-Insert variables needed by target @var{THIS} in Makefile.am after SOURCES.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-dist-dependencies :AFTER this
-Insert any symbols that the DIST rule should depend on.
-Argument @var{THIS} is the target that should insert stuff.
-@end deffn
-
-@deffn Method ede-proj-linkers :AFTER obj
-List of linkers being used by @var{OBJ}.
-If the @code{linker} slot is empty, concoct one on a first match found
-basis for any given type from the @code{availablelinkers} slot.
-Otherwise, return the @code{linker} slot.
-Converts all symbols into the objects to be used.
-@end deffn
-
-@deffn Method ede-proj-makefile-garbage-patterns :AFTER this
-Return a list of patterns that are considered garbage to @var{THIS}.
-These are removed with make clean.
-@end deffn
-
-@deffn Method ede-proj-tweak-autoconf :AFTER this
-Tweak the configure file (current buffer) to accommodate @var{THIS}.
-@end deffn
-
-@deffn Method ede-proj-compilers :AFTER obj
-List of compilers being used by @var{OBJ}.
-If the @code{compiler} slot is empty, concoct one on a first match found
-basis for any given type from the @code{availablecompilers} slot.
-Otherwise, return the @code{compiler} slot.
-Converts all symbols into the objects to be used.
-@end deffn
-
-@deffn Method project-delete-target :AFTER this
-Delete the current target @var{THIS} from its parent project.
-@end deffn
-
-@deffn Method ede-proj-makefile-target-name :AFTER this
-Return the name of the main target for @var{THIS} target.
-@end deffn
-
-@deffn Method eieio-done-customizing :AFTER target
-Call this when a user finishes customizing this object.
-Argument @var{TARGET} is the project we are completing customization on.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-user-rules :AFTER this
-Insert user specified rules needed by @var{THIS} target.
-@end deffn
-
-@deffn Method project-add-file :AFTER this file
-Add to target @var{THIS} the current buffer represented as @var{FILE}.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-automake-pre-variables :AFTER this
-Insert variables needed by target @var{THIS} in Makefile.am before SOURCES.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-dist-filepatterns :AFTER this
-Insert any symbols that the DIST rule should depend on.
-Argument @var{THIS} is the target that should insert stuff.
-@end deffn
-
-@deffn Method ede-proj-makefile-dependency-files :AFTER this
-Return a list of source files to convert to dependencies.
-Argument @var{THIS} is the target to get sources from.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-source-variables :AFTER this &optional moresource
-Insert the source variables needed by @var{THIS}.
-Optional argument @var{MORESOURCE} is a list of additional sources to add to the
-sources variable.
-@end deffn
-
-
-@node ede-proj-target-makefile
-@subsection ede-proj-target-makefile
-@tgindex ede-proj-target-makefile
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-makefile
-@table @asis
-@item Children:
-@xref{semantic-ede-proj-target-grammar}, @xref{ede-proj-target-makefile-objectcode}, @xref{ede-proj-target-elisp}, @xref{ede-proj-target-makefile-miscelaneous}, @xref{ede-proj-target-makefile-info}.
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :makefile
-Type: @code{string} @*
-Default Value: @code{"Makefile"}
-
-File name of generated Makefile.
-
-@item :partofall
-Type: @code{boolean} @*
-Default Value: @code{t}
-
-Non-@code{nil} means the rule created is part of the all target.
-Setting this to @code{nil} creates the rule to build this item, but does not
-include it in the @code{all:} rule.
-
-@item :configuration-variables
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Makefile variables appended to use in different configurations.
-These variables are used in the makefile when a configuration becomes active.
-Target variables are always renamed such as foo_CFLAGS, then included into
-commands where the variable would usually appear.
-
-@item :rules
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Arbitrary rules and dependencies needed to make this target.
-It is safe to leave this blank.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-makefile-dependencies :AFTER this
-Return a string representing the dependencies for @var{THIS}.
-Some compilers only use the first element in the dependencies, others
-have a list of intermediates (object files), and others don't care.
-This allows customization of how these elements appear.
-@end deffn
-
-@deffn Method project-compile-target :AFTER obj &optional command
-Compile the current target program @var{OBJ}.
-Optional argument @var{COMMAND} is the s the alternate command to use.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-rules :AFTER this
-Insert rules needed by @var{THIS} target.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-variables :AFTER this &optional moresource
-Insert variables needed by target @var{THIS}.
-Optional argument @var{MORESOURCE} is a list of additional sources to add to the
-sources variable.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-commands :AFTER this
-Insert the commands needed by target @var{THIS}.
-For targets, insert the commands needed by the chosen compiler.
-@end deffn
-
-@deffn Method ede-proj-makefile-configuration-variables :AFTER this configuration
-Return a list of configuration variables from @var{THIS}.
-Use @var{CONFIGURATION} as the current configuration to query.
-@end deffn
-
-@node semantic-ede-proj-target-grammar
-@subsection semantic-ede-proj-target-grammar
-@tgindex semantic-ede-proj-target-grammar
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-makefile
-@xref{ede-proj-target-makefile}.
-@table @code
-@item semantic-ede-proj-target-grammar
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method project-compile-target :AFTER obj
-Compile all sources in a Lisp target @var{OBJ}.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-rules :AFTER this
-Insert rules needed by @var{THIS} target.
-@end deffn
-
-@deffn Method ede-buffer-mine :AFTER this buffer
-Return @code{t} if object @var{THIS} lays claim to the file in @var{BUFFER}.
-Lays claim to all -by.el, and -wy.el files.
-@end deffn
-
-@deffn Method ede-proj-makefile-sourcevar :AFTER this
-Return the variable name for @var{THIS}'s sources.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-dist-dependencies :AFTER this
-Insert dist dependencies, or intermediate targets.
-This makes sure that all grammar lisp files are created before the dist
-runs, so they are always up to date.
-Argument @var{THIS} is the target that should insert stuff.
-@end deffn
-
-
-@node ede-proj-target-makefile-objectcode
-@subsection ede-proj-target-makefile-objectcode
-@tgindex ede-proj-target-makefile-objectcode
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-makefile
-@xref{ede-proj-target-makefile}.
-@table @code
-@item ede-proj-target-makefile-objectcode
-@table @asis
-@item Children:
-@xref{ede-proj-target-makefile-archive}, @xref{ede-proj-target-makefile-program}.
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :configuration-variables
-Type: @code{list} @*
-Default Value: @code{("debug" ("CFLAGS" . "-g") ("LDFLAGS" . "-g"))}
-
-@xref{ede-proj-target-makefile}.
-@end table
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-buffer-header-file :AFTER this buffer
-There are no default header files.
-@end deffn
-
-@deffn Method ede-proj-makefile-sourcevar :AFTER this
-Return the variable name for @var{THIS}'s sources.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-variables :AFTER this &optional moresource
-Insert variables needed by target @var{THIS}.
-Optional argument @var{MORESOURCE} is not used.
-@end deffn
-
-@deffn Method ede-proj-makefile-dependency-files :AFTER this
-Return a list of source files to convert to dependencies.
-Argument @var{THIS} is the target to get sources from.
-@end deffn
-
-
-@node ede-proj-target-makefile-archive
-@subsection ede-proj-target-makefile-archive
-@tgindex ede-proj-target-makefile-archive
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-makefile
-@xref{ede-proj-target-makefile}.
-@table @code
-@item ede-proj-target-makefile-objectcode
-@xref{ede-proj-target-makefile-objectcode}.
-@table @code
-@item ede-proj-target-makefile-archive
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-makefile-insert-rules :AFTER this
-Create the make rule needed to create an archive for @var{THIS}.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-source-variables :PRIMARY this
-Insert bin_PROGRAMS variables needed by target @var{THIS}.
-We aren't actually inserting SOURCE details, but this is used by the
-Makefile.am generator, so use it to add this important bin program.
-@end deffn
-
-
-@node ede-proj-target-makefile-program
-@subsection ede-proj-target-makefile-program
-@tgindex ede-proj-target-makefile-program
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-makefile
-@xref{ede-proj-target-makefile}.
-@table @code
-@item ede-proj-target-makefile-objectcode
-@xref{ede-proj-target-makefile-objectcode}.
-@table @code
-@item ede-proj-target-makefile-program
-@table @asis
-@item Children:
-@xref{ede-proj-target-makefile-shared-object}.
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :ldlibs
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Libraries, such as "m" or "Xt" which this program depends on.
-The linker flag "-l" is automatically prepended. Do not include a "lib"
-prefix, or a ".so" suffix.
-
-Note: Currently only used for Automake projects.
-
-@item :ldflags
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Additional flags to add when linking this target.
-Use ldlibs to add addition libraries. Use this to specify specific
-options to the linker.
-
-Note: Not currently used. This bug needs to be fixed.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method project-debug-target :AFTER obj
-Debug a program target @var{OBJ}.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-rules :AFTER this
-Insert rules needed by @var{THIS} target.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-automake-post-variables :AFTER this
-Insert bin_PROGRAMS variables needed by target @var{THIS}.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-automake-pre-variables :AFTER this
-Insert bin_PROGRAMS variables needed by target @var{THIS}.
-@end deffn
-
-
-@node ede-proj-target-makefile-shared-object
-@subsection ede-proj-target-makefile-shared-object
-@tgindex ede-proj-target-makefile-shared-object
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-makefile
-@xref{ede-proj-target-makefile}.
-@table @code
-@item ede-proj-target-makefile-objectcode
-@xref{ede-proj-target-makefile-objectcode}.
-@table @code
-@item ede-proj-target-makefile-program
-@xref{ede-proj-target-makefile-program}.
-@table @code
-@item ede-proj-target-makefile-shared-object
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-configure-add-missing :AFTER this
-Query if any files needed by @var{THIS} provided by automake are missing.
-Results in --add-missing being passed to automake.
-@end deffn
-
-@deffn Method ede-proj-makefile-sourcevar :AFTER this
-Return the variable name for @var{THIS}'s sources.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-automake-post-variables :AFTER this
-Insert bin_PROGRAMS variables needed by target @var{THIS}.
-We need to override -program which has an LDADD element.
-@end deffn
-
-@deffn Method ede-proj-makefile-target-name :AFTER this
-Return the name of the main target for @var{THIS} target.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-automake-pre-variables :AFTER this
-Insert bin_PROGRAMS variables needed by target @var{THIS}.
-We aren't actually inserting SOURCE details, but this is used by the
-Makefile.am generator, so use it to add this important bin program.
-@end deffn
-
-
-@node ede-proj-target-elisp
-@subsection ede-proj-target-elisp
-@tgindex ede-proj-target-elisp
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-makefile
-@xref{ede-proj-target-makefile}.
-@table @code
-@item ede-proj-target-elisp
-@table @asis
-@item Children:
-@xref{ede-proj-target-elisp-autoloads}.
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :aux-packages
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Additional packages needed.
-There should only be one toplevel package per auxiliary tool needed.
-These packages location is found, and added to the compile time
-load path.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method project-compile-target :AFTER obj
-Compile all sources in a Lisp target @var{OBJ}.
-Bonus: Return a cons cell: (COMPILED . UPTODATE).
-@end deffn
-
-@deffn Method ede-proj-flush-autoconf :AFTER this
-Flush the configure file (current buffer) to accommodate @var{THIS}.
-@end deffn
-
-@deffn Method ede-buffer-mine :AFTER this buffer
-Return @code{t} if object @var{THIS} lays claim to the file in @var{BUFFER}.
-Lays claim to all .elc files that match .el files in this target.
-@end deffn
-
-@deffn Method ede-proj-makefile-sourcevar :AFTER this
-Return the variable name for @var{THIS}'s sources.
-@end deffn
-
-@deffn Method ede-proj-tweak-autoconf :AFTER this
-Tweak the configure file (current buffer) to accommodate @var{THIS}.
-@end deffn
-
-@deffn Method ede-update-version-in-source :AFTER this version
-In a Lisp file, updated a version string for @var{THIS} to @var{VERSION}.
-There are standards in Elisp files specifying how the version string
-is found, such as a @code{-version} variable, or the standard header.
-@end deffn
-
-@node ede-proj-target-elisp-autoloads
-@subsection ede-proj-target-elisp-autoloads
-@tgindex ede-proj-target-elisp-autoloads
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-makefile
-@xref{ede-proj-target-makefile}.
-@table @code
-@item ede-proj-target-elisp
-@xref{ede-proj-target-elisp}.
-@table @code
-@item ede-proj-target-elisp-autoloads
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :aux-packages
-Type: @code{list} @*
-Default Value: @code{("cedet-autogen")}
-
-@xref{ede-proj-target-elisp}.
-@item :autoload-file
-Type: @code{string} @*
-Default Value: @code{"loaddefs.el"}
-
-The file that autoload definitions are placed in.
-There should be one load defs file for a given package. The load defs are created
-for all Emacs Lisp sources that exist in the directory of the created target.
-
-@item :autoload-dirs
-Type: @code{list} @*
-Default Value: @code{nil}
-
-The directories to scan for autoload definitions.
-If @code{nil} defaults to the current directory.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-makefile-dependencies :AFTER this
-Return a string representing the dependencies for @var{THIS}.
-Always return an empty string for an autoloads generator.
-@end deffn
-
-@deffn Method project-compile-target :AFTER obj
-Create or update the autoload target.
-@end deffn
-
-@deffn Method ede-proj-flush-autoconf :AFTER this
-Flush the configure file (current buffer) to accommodate @var{THIS}.
-@end deffn
-
-@deffn Method ede-buffer-mine :AFTER this buffer
-Return @code{t} if object @var{THIS} lays claim to the file in @var{BUFFER}.
-Lays claim to all .elc files that match .el files in this target.
-@end deffn
-
-@deffn Method ede-proj-makefile-sourcevar :AFTER this
-Return the variable name for @var{THIS}'s sources.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-dist-dependencies :AFTER this
-Insert any symbols that the DIST rule should depend on.
-Emacs Lisp autoload files ship the generated .el files.
-Argument @var{THIS} is the target which needs to insert an info file.
-@end deffn
-
-@deffn Method ede-proj-tweak-autoconf :AFTER this
-Tweak the configure file (current buffer) to accommodate @var{THIS}.
-@end deffn
-
-@deffn Method ede-update-version-in-source :AFTER this version
-In a Lisp file, updated a version string for @var{THIS} to @var{VERSION}.
-There are standards in Elisp files specifying how the version string
-is found, such as a @code{-version} variable, or the standard header.
-@end deffn
-
-@deffn Method ede-proj-compilers :AFTER obj
-List of compilers being used by @var{OBJ}.
-If the @code{compiler} slot is empty, get the car of the compilers list.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-dist-filepatterns :AFTER this
-Insert any symbols that the DIST rule should distribute.
-Emacs Lisp autoload files ship the generated .el files.
-Argument @var{THIS} is the target which needs to insert an info file.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-source-variables :AFTER this &optional moresource
-Insert the source variables needed by @var{THIS}.
-Optional argument @var{MORESOURCE} is a list of additional sources to add to the
-sources variable.
-@end deffn
-
-
-@node ede-proj-target-makefile-miscelaneous
-@subsection ede-proj-target-makefile-miscelaneous
-@tgindex ede-proj-target-makefile-miscelaneous
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-makefile
-@xref{ede-proj-target-makefile}.
-@table @code
-@item ede-proj-target-makefile-miscelaneous
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :submakefile
-Type: @code{string} @*
-Default Value: @code{""}
-
-Miscellaneous sources which have a specialized makefile.
-The sub-makefile is used to build this target.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-makefile-insert-rules :AFTER this
-Create the make rule needed to create an archive for @var{THIS}.
-@end deffn
-
-@deffn Method ede-proj-makefile-sourcevar :AFTER this
-Return the variable name for @var{THIS}'s sources.
-@end deffn
-
-@deffn Method ede-proj-makefile-dependency-files :AFTER this
-Return a list of files which @var{THIS} target depends on.
-@end deffn
-
-
-@node ede-proj-target-makefile-info
-@subsection ede-proj-target-makefile-info
-@tgindex ede-proj-target-makefile-info
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-makefile
-@xref{ede-proj-target-makefile}.
-@table @code
-@item ede-proj-target-makefile-info
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :mainmenu
-Type: @code{string} @*
-Default Value: @code{""}
-
-The main menu resides in this file.
-All other sources should be included independently.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-configure-add-missing :AFTER this
-Query if any files needed by @var{THIS} provided by automake are missing.
-Results in --add-missing being passed to automake.
-@end deffn
-
-@deffn Method object-write :AFTER this
-Before committing any change to @var{THIS}, make sure the mainmenu is first.
-@end deffn
-
-@deffn Method ede-proj-makefile-sourcevar :AFTER this
-Return the variable name for @var{THIS}'s sources.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-dist-dependencies :AFTER this
-Insert any symbols that the DIST rule should depend on.
-Texinfo files want to insert generated @file{.info} files.
-Argument @var{THIS} is the target which needs to insert an info file.
-@end deffn
-
-@deffn Method ede-proj-makefile-target-name :AFTER this
-Return the name of the main target for @var{THIS} target.
-@end deffn
-
-@deffn Method ede-documentation :AFTER this
-Return a list of files that provides documentation.
-Documentation is not for object @var{THIS}, but is provided by @var{THIS} for other
-files in the project.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-dist-filepatterns :AFTER this
-Insert any symbols that the DIST rule should depend on.
-Texinfo files want to insert generated @file{.info} files.
-Argument @var{THIS} is the target which needs to insert an info file.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-source-variables :AFTER this &optional moresource
-Insert the source variables needed by @var{THIS} info target.
-Optional argument @var{MORESOURCE} is a list of additional sources to add to the
-sources variable.
-Does the usual for Makefile mode, but splits source into two variables
-when working in Automake mode.
-@end deffn
-
-@node ede-proj-target-scheme
-@subsection ede-proj-target-scheme
-@tgindex ede-proj-target-scheme
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item ede-proj-target
-@xref{ede-proj-target}.
-@table @code
-@item ede-proj-target-scheme
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :interpreter
-Type: @code{string} @*
-Default Value: @code{"guile"}
-
-The preferred interpreter for this code.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-tweak-autoconf :AFTER this
-Tweak the configure file (current buffer) to accommodate @var{THIS}.
-@end deffn
-
-
-@node project-am-target
-@subsection project-am-target
-@tgindex project-am-target
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item project-am-target
-@table @asis
-@item Children:
-@xref{project-am-objectcode}, @w{project-am-header,} @xref{project-am-lisp}, @xref{project-am-texinfo}, @xref{project-am-man}.
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method project-compile-target-command :AFTER this
-Default target to use when compiling a given target.
-@end deffn
-
-@deffn Method project-make-dist :AFTER this
-Run the current project in the debugger.
-@end deffn
-
-@deffn Method project-edit-file-target :AFTER obj
-Edit the target associated with this file.
-@end deffn
-
-@node project-am-objectcode
-@subsection project-am-objectcode
-@tgindex project-am-objectcode
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item project-am-target
-@xref{project-am-target}.
-@table @code
-@item project-am-objectcode
-@table @asis
-@item Children:
-@xref{project-am-program}, @w{project-am-lib.}
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method project-am-macro :AFTER this
-Return the default macro to 'edit' for this object type.
-@end deffn
-
-@deffn Method project-debug-target :AFTER obj
-Run the current project target in a debugger.
-@end deffn
-
-@deffn Method project-compile-target-command :AFTER this
-Default target to use when compiling an object code target.
-@end deffn
-
-@deffn Method ede-buffer-header-file :AFTER this buffer
-There are no default header files.
-@end deffn
-
-@node project-am-program
-@subsection project-am-program
-@tgindex project-am-program
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item project-am-target
-@xref{project-am-target}.
-@table @code
-@item project-am-objectcode
-@xref{project-am-objectcode}.
-@table @code
-@item project-am-program
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :ldadd @*
-Default Value: @code{nil}
-
-Additional LD args.
-@end table
-@end table
-
-@node project-am-header-noinst
-@subsection project-am-header-noinst
-@tgindex project-am-header-noinst
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item project-am-target
-@xref{project-am-target}.
-@table @code
-@item @w{project-am-header.}
-@table @code
-@item project-am-header-noinst
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method project-am-macro :AFTER this
-Return the default macro to 'edit' for this object.
-@end deffn
-
-@node project-am-header-inst
-@subsection project-am-header-inst
-@tgindex project-am-header-inst
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item project-am-target
-@xref{project-am-target}.
-@table @code
-@item @w{project-am-header.}
-@table @code
-@item project-am-header-inst
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method project-am-macro :AFTER this
-Return the default macro to 'edit' for this object.
-@end deffn
-
-@node project-am-lisp
-@subsection project-am-lisp
-@tgindex project-am-lisp
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item project-am-target
-@xref{project-am-target}.
-@table @code
-@item project-am-lisp
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method project-am-macro :AFTER this
-Return the default macro to 'edit' for this object.
-@end deffn
-
-@node project-am-texinfo
-@subsection project-am-texinfo
-@tgindex project-am-texinfo
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item project-am-target
-@xref{project-am-target}.
-@table @code
-@item project-am-texinfo
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :include @*
-Default Value: @code{nil}
-
-Additional texinfo included in this one.
-
-@end table
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method project-am-macro :AFTER this
-Return the default macro to 'edit' for this object type.
-@end deffn
-
-@deffn Method project-compile-target-command :AFTER this
-Default target to use when compiling a texinfo file.
-@end deffn
-
-@deffn Method ede-documentation :AFTER this
-Return a list of files that provides documentation.
-Documentation is not for object @var{THIS}, but is provided by @var{THIS} for other
-files in the project.
-@end deffn
-
-@node project-am-man
-@comment node-name, next, previous, up
-@subsection project-am-man
-@tgindex project-am-man
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-speedbar
-@table @code
-@item eieio-speedbar-directory-button
-@table @code
-@item ede-target
-@xref{ede-target}.
-@table @code
-@item project-am-target
-@xref{project-am-target}.
-@table @code
-@item project-am-man
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method project-am-macro :AFTER this
-Return the default macro to 'edit' for this object type.
-@end deffn
-
-@node Sourcecode
-@section Sourcecode
-
-The source code type is an object designed to associated files with
-targets.
-
-@menu
-* ede-sourcecode::
-@end menu
-
-
-@node ede-sourcecode
-@subsection ede-sourcecode
-@scindex ede-sourcecode
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-instance-inheritor
-@table @code
-@item ede-sourcecode
-No children
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :parent-instance
-Type: @code{eieio-instance-inheritor-child}
-
-The parent of this instance.
-If a slot of this class is reference, and is unbound, then the parent
-is checked for a value.
-
-@item :name
-Type: @code{string}
-
-The name of this type of source code.
-Such as "C" or "Emacs Lisp"
-
-@item :sourcepattern
-Type: @code{string} @*
-Default Value: @code{".*"}
-
-Emacs regex matching sourcecode this target accepts.
-
-@item :auxsourcepattern
-Type: @code{(or null string)} @*
-Default Value: @code{nil}
-
-Emacs regex matching auxiliary source code this target accepts.
-Aux source are source code files needed for compilation, which are not compiled
-themselves.
-
-@item :enable-subdirectories
-Type: @code{boolean} @*
-Default Value: @code{nil}
-
-Non-@code{nil} if this sourcecode type uses subdirectores. If
-sourcecode always lives near the target creating it, this should be
-@code{nil}. If sourcecode can, or typically lives in a subdirectory
-of the owning target, set this to @code{t}.
-
-@item :garbagepattern
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Shell file regex matching files considered as garbage.
-This is a list of items added to an @code{rm} command when executing a @code{clean}
-type directive.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-want-any-files-p :AFTER this filenames
-Return non-@code{nil} if @var{THIS} will accept any files in @var{FILENAMES}.
-@end deffn
-
-@deffn Method ede-want-any-source-files-p :AFTER this filenames
-Return non-@code{nil} if @var{THIS} will accept any source files in @var{FILENAMES}.
-@end deffn
-
-@deffn Method ede-want-any-auxiliary-files-p :AFTER this filenames
-Return non-@code{nil} if @var{THIS} will accept any aux files in @var{FILENAMES}.
-@end deffn
-
-@deffn Method ede-buffer-header-file :AFTER this filename
-Return a list of file names of header files for @var{THIS} with @var{FILENAME}.
-Used to guess header files, but uses the auxsource regular expression.
-@end deffn
-
-@deffn Method ede-want-file-p :AFTER this filename
-Return non-@code{nil} if sourcecode definition @var{THIS} will take @var{FILENAME}.
-@end deffn
-
-@deffn Method ede-want-file-source-p :AFTER this filename
-Return non-@code{nil} if @var{THIS} will take @var{FILENAME} as an auxiliary .
-@end deffn
-
-@deffn Method ede-want-file-auxiliary-p :AFTER this filename
-Return non-@code{nil} if @var{THIS} will take @var{FILENAME} as an auxiliary .
-@end deffn
-
-@node Compilers
-@section Compilers
-
-The compiler object is designed to associate source code with
-compilers. The target then references the compilers it can use.
-When the makefile is created, this object type knows how to create
-compile commands.
-
-@menu
-* ede-compilation-program::
-* ede-compiler::
-* ede-object-compiler::
-* ede-linker::
-@end menu
-
-
-@node ede-compilation-program
-@subsection ede-compilation-program
-@cmindex ede-compilation-program
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-instance-inheritor
-@table @code
-@item ede-compilation-program
-@table @asis
-@item Children:
-@xref{ede-compiler}, @xref{ede-linker}.
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :parent-instance
-Type: @code{eieio-instance-inheritor-child}
-
-The parent of this instance.
-If a slot of this class is reference, and is unbound, then the parent
-is checked for a value.
-
-@item :name
-Type: @code{string}
-
-Name of this type of compiler.
-
-@item :variables
-Type: @code{list}
-
-Variables needed in the Makefile for this compiler.
-An assoc list where each element is (VARNAME . VALUE) where VARNAME
-is a string, and VALUE is either a string, or a list of strings.
-For example, GCC would define CC=gcc, and emacs would define EMACS=emacs.
-
-@item :sourcetype
-Type: @code{list}
-
-A list of @code{ede-sourcecode} @xref{ede-sourcecode}. objects this class will handle.
-This is used to match target objects with the compilers and linkers
-they can use, and which files this object is interested in.
-
-@item :rules
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Auxiliary rules needed for this compiler to run.
-For example, yacc/lex files need additional chain rules, or inferences.
-
-@item :commands
-Type: @code{list}
-
-The commands used to execute this compiler.
-The object which uses this compiler will place these commands after
-its rule definition.
-
-@item :autoconf
-Type: @code{list} @*
-Default Value: @code{nil}
-
-Autoconf function to call if this type of compiler is used.
-When a project is in Automake mode, this defines the autoconf function to
-call to initialize automake to use this compiler.
-For example, there may be multiple C compilers, but they all probably
-use the same autoconf form.
-
-@item :objectextention
-Type: @code{string}
-
-A string which is the extension used for object files.
-For example, C code uses .o on unix, and Emacs Lisp uses .elc.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-flush-autoconf :AFTER this
-Flush the configure file (current buffer) to accommodate @var{THIS}.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-rules :AFTER this
-Insert rules needed for @var{THIS} compiler object.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-variables :AFTER this
-Insert variables needed by the compiler @var{THIS}.
-@end deffn
-
-@deffn Method ede-proj-makefile-insert-commands :AFTER this
-Insert the commands needed to use compiler @var{THIS}.
-The object creating makefile rules must call this method for the
-compiler it decides to use after inserting in the rule.
-@end deffn
-
-@deffn Method ede-object-sourcecode :AFTER this
-Retrieves the slot @code{sourcetype} from an object of class @code{ede-compilation-program}
-@end deffn
-
-@deffn Method ede-proj-tweak-autoconf :AFTER this
-Tweak the configure file (current buffer) to accommodate @var{THIS}.
-@end deffn
-
-
-@node ede-compiler
-@subsection ede-compiler
-@cmindex ede-compiler
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-instance-inheritor
-@table @code
-@item ede-compilation-program
-@xref{ede-compilation-program}.
-@table @code
-@item ede-compiler
-@table @asis
-@item Children:
-@xref{ede-object-compiler}, @w{semantic-ede-grammar-compiler-class.}
-@end table
-
-@end table
-
-@end table
-
-@end table
-@end table
-
- Create a new object with name NAME of class type ede-compiler
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :parent-instance
-Type: @code{eieio-instance-inheritor-child}
-
-The parent of this instance.
-If a slot of this class is reference, and is unbound, then the parent
-is checked for a value.
-
-@item :name
-Type: @code{string}
-
-Name of this type of compiler.
-
-@item :variables
-Type: @code{list}
-
-Variables needed in the Makefile for this compiler.
-An assoc list where each element is (VARNAME . VALUE) where VARNAME
-is a string, and VALUE is either a string, or a list of strings.
-For example, GCC would define CC=gcc, and emacs would define EMACS=emacs.
-
-@item :sourcetype
-Type: @code{list}
-
-A list of @code{ede-sourcecode} @xref{ede-sourcecode}. objects this class will handle.
-This is used to match target objects with the compilers and linkers
-they can use, and which files this object is interested in.
-
-@item :commands
-Type: @code{list}
-
-The commands used to execute this compiler.
-The object which uses this compiler will place these commands after
-its rule definition.
-
-@item :objectextention
-Type: @code{string}
-
-A string which is the extension used for object files.
-For example, C code uses .o on unix, and Emacs Lisp uses .elc.
-
-@item :makedepends
-Type: @code{boolean} @*
-Default Value: @code{nil}
-
-Non-@code{nil} if this compiler can make dependencies.
-
-@item :uselinker
-Type: @code{boolean} @*
-Default Value: @code{nil}
-
-Non-@code{nil} if this compiler creates code that can be linked.
-This requires that the containing target also define a list of available
-linkers that can be used.
-
-@end table
-
-@end table
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-makefile-insert-object-variables :AFTER this targetname sourcefiles
-Insert an OBJ variable to specify object code to be generated for @var{THIS}.
-The name of the target is @var{TARGETNAME} as a string. @var{SOURCEFILES} is the list of
-files to be objectified.
-Not all compilers do this.
-@end deffn
-
-@deffn Method ede-compiler-intermediate-objects-p :AFTER this
-Return non-@code{nil} if @var{THIS} has intermediate object files.
-If this compiler creates code that can be linked together,
-then the object files created by the compiler are considered intermediate.
-@end deffn
-
-@deffn Method ede-compiler-intermediate-object-variable :AFTER this targetname
-Return a string based on @var{THIS} representing a make object variable.
-@var{TARGETNAME} is the name of the target that these objects belong to.
-@end deffn
-
-
-@node ede-object-compiler
-@subsection ede-object-compiler
-@cmindex ede-object-compiler
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-instance-inheritor
-@table @code
-@item ede-compilation-program
-@xref{ede-compilation-program}.
-@table @code
-@item ede-compiler
-@xref{ede-compiler}.
-@table @code
-@item ede-object-compiler
-No children
-@end table
-@end table
-@end table
-@end table
-@end table
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :uselinker
-Type: @code{boolean} @*
-Default Value: @code{t}
-
-@xref{ede-compiler}.
-@item :dependencyvar
-Type: @code{list}
-
-A variable dedicated to dependency generation.
-@end table
-@end table
-
-@subsubsection Specialized Methods
-
-@deffn Method ede-proj-makefile-insert-variables :AFTER this
-Insert variables needed by the compiler @var{THIS}.
-@end deffn
-
-@node ede-linker
-@subsection ede-linker
-@cmindex ede-linker
-
-@table @asis
-@item Inheritance Tree:
-@table @code
-@item eieio-instance-inheritor
-@table @code
-@item ede-compilation-program
-@xref{ede-compilation-program}.
-@table @code
-@item ede-linker
-No children
-@end table
-
-@end table
-
-@end table
-@end table
-
- Create a new object with name NAME of class type ede-linker
-
-@table @asis
-@item Slots:
-
-@table @code
-@item :name
-Type: @code{string}
-
-Name of this type of compiler.
-
-@item :variables
-Type: @code{list}
-
-Variables needed in the Makefile for this compiler.
-An assoc list where each element is (VARNAME . VALUE) where VARNAME
-is a string, and VALUE is either a string, or a list of strings.
-For example, GCC would define CC=gcc, and emacs would define EMACS=emacs.
-
-@item :sourcetype
-Type: @code{list}
-
-A list of @code{ede-sourcecode} @xref{ede-sourcecode}. objects this class will handle.
-This is used to match target objects with the compilers and linkers
-they can use, and which files this object is interested in.
-
-@item :commands
-Type: @code{list}
-
-The commands used to execute this compiler.
-The object which uses this compiler will place these commands after
-its rule definition.
-
-@item :objectextention
-Type: @code{string}
-
-A string which is the extension used for object files.
-For example, C code uses .o on unix, and Emacs Lisp uses .elc.
-
-@end table
-@end table
-
-@node GNU Free Documentation License
-@appendix GNU Free Documentation License
-@include doclicense.texi
-
-@bye
+++ /dev/null
-@c This is part of the Semantic manual.
-@c Copyright (C) 1999--2005, 2007, 2009--2024 Free Software Foundation,
-@c Inc.
-@c See file semantic.texi for copying conditions.
-
-You can begin using @semantic{} by enabling Semantic mode, a global
-minor mode: type @kbd{M-x semantic-mode}, or open the @samp{Tools}
-menu and click on the menu item named @samp{Source Code Parsers
-(Semantic)}. @xref{Semantic mode}.
-
-When Semantic mode is turned on, Emacs automatically parses each file
-you visit. You can then use @semantic{} user commands in those
-buffers (@pxref{Semantic mode user commands}). You can also choose to
-enable a number of ``helper'' minor modes for saving tags, displaying
-tag information, and so forth.
-
-To enable Semantic mode each time you start Emacs, add the line
-@code{(semantic-mode 1)} to your initialization file. @xref{Init
-File,,,emacs,Emacs manual}.
-
-@menu
-* Semantic mode:: Global minor mode for @semantic{}.
-* SemanticDB:: Caching parsed buffers between sessions.
-* Idle Scheduler:: @semantic{} actions that occur when idle.
-* Analyzer:: Semantic tools for analyzing code.
-* Speedbar:: Using @semantic{} with the Speedbar.
-* SymRef:: Interface to symbol reference tools.
-* MRU Bookmarks:: Managing tag "bookmarks".
-* Sticky Func Mode:: Showing declarations in the header line.
-* Highlight Func Mode:: Highlight the current function declaration.
-* Tag Decoration Mode:: Minor mode to decorate tags.
-@end menu
-
-@node Semantic mode
-@section Semantic mode
-@cindex Semantic mode
-
-Semantic mode is a global minor mode for @semantic{} as a whole. When
-enabled, each file you visit is automatically parsed, provided its
-major mode is specified in the variable
-@code{semantic-new-buffer-setup-functions} (the default value of this
-variable sets up parsing for all the parsers included with Emacs, but
-you may add to it if you install additional parsers).
-
-In each parser-enabled buffer, a number of @semantic{} commands are
-available for navigating, querying, and editing source code.
-@xref{Semantic mode user commands}. Enabling Semantic mode also
-installs a @samp{Development} menu on the menu-bar, with many of these
-commands.
-
-In addition, enabling Semantic mode turns on certain auxiliary global
-minor modes. The variable @code{semantic-default-submodes} determines
-which auxiliary modes are enabled; the defaults are SemanticDB mode
-(@pxref{SemanticDB}) and Global Semantic Idle Scheduler mode
-(@pxref{Idle Scheduler}). You can also toggle the auxiliary minor
-modes separately, using their mode functions (e.g., @kbd{M-x
-semanticdb-minor-mode}), or via the @samp{Development} menu. The
-various auxiliary minor modes are described in the following sections.
-
-@defvar semantic-new-buffer-setup-functions
-The value of this variable is an alist of functions to call for
-setting up @semantic{} parsing in the buffer. Each element has the
-form @code{(@var{mode} . @var{fn})}, where @var{mode} is a value of
-@code{major-mode} for the buffer and @var{fn} is the corresponding
-function for setting up the parser. @var{fn} is called, with no
-arguments, after the major mode is initialized (and after the mode
-hooks have been run).
-
-The default value enables @semantic{} for all supported major modes
-(i.e., C, C++, Scheme, Javascript, Java, HTML, SRecode, and Make), but
-you can remove modes from this list if you don't want to use
-@semantic{} with them.
-@end defvar
-
-@defvar semantic-default-submodes
-The value of this variable is a list of symbols, specifying the
-auxiliary minor modes to enable when enabling Semantic mode. The
-valid mode symbols are:
-
-@itemize
-@item @code{global-semantic-idle-scheduler-mode} (@pxref{Idle Scheduler}).
-@item @code{global-semanticdb-minor-mode} (@pxref{SemanticDB}).
-@item @code{global-semantic-idle-summary-mode} (@pxref{Idle Summary Mode}).
-@item @code{global-semantic-idle-completions-mode} (@pxref{Idle Completions Mode}).
-@item @code{global-semantic-highlight-func-mode} (@pxref{Highlight Func Mode}).
-@item @code{global-semantic-decoration-mode} (@pxref{Tag Decoration Mode}).
-@item @code{global-semantic-stickyfunc-mode} (@pxref{Sticky Func Mode}).
-@item @code{global-semantic-mru-bookmark-mode} (@pxref{MRU Bookmarks}).
-@end itemize
-@end defvar
-
-@menu
-* Semantic mode user commands::
-@end menu
-
-@node Semantic mode user commands
-@subsection Semantic mode user commands
-
-Semantic mode provides a number of commands for navigating, querying,
-and editing source code in a language-aware manner. These commands
-generally act on @dfn{tags}, which are the source-code units deemed
-``important'' by the present programming language (e.g., functions in
-the C programming language).
-
-These commands may be used in any buffer that has been parsed by
-@semantic{}. Several of them prompt for a tag name using the
-minibuffer; here, the @kbd{TAB} key can be used to complete tag names.
-Others act on the @dfn{current tag}, meaning the tag at (or around)
-point.
-
-@table @kbd
-@item C-c , j
-Prompt for a tag defined in the current file, and move point to it
-(@code{semantic-complete-jump-local}).
-
-@item C-c , J
-Prompt for a tag defined in any file that Emacs has parsed, and move
-point to it (@code{semantic-complete-jump}).
-
-@item C-c , l
-Display a list of the possible completions of the current tag
-(@code{semantic-analyze-possible-completions}).
-
-@item C-c , g
-Prompt for a tag, and display a list of tags that call it
-(@code{semantic-symref-symbol}). This relies on the presence of an
-external symbol reference tool. @xref{SymRef}.
-
-@item C-c , G
-Display a list of tags that call the current tag
-(@code{semantic-symref}). This relies on the presence of an external
-symbol reference tool. @xref{SymRef}.
-
-@item C-c , p
-Move point to the previous tag (@code{senator-previous-tag}).
-
-@item C-c , n
-Move point to the next tag (@code{senator-next-tag}).
-
-@item C-c , u
-Move point ``up'' one reference (@code{senator-go-to-up-reference}).
-The meaning of ``up'' is language-dependent; in C++, for instance,
-this means moving to the parent of the current tag.
-
-@item C-c , @key{SPC}
-Display a list of possible completions for the symbol at point
-(@code{semantic-complete-analyze-inline}). This also activates a
-special set of key bindings for choosing a completion: @key{RET}
-accepts the current completion, @kbd{M-n} and @kbd{M-p} cycle through
-possible completions, @key{TAB} completes as far as possible and then
-cycles, and @kbd{C-g} or any other key aborts the completion.
-@xref{Smart Completion}.
-
-@item C-c , C-w
-Kill the current tag (@code{senator-kill-tag}). This removes the text
-for that tag, placing it in the kill ring. You can retrieve the text
-with @kbd{C-y}. This also places the tag in the @dfn{tag ring}, so
-that you can yank it with @kbd{\C-c,\C-y}, below.
-
-@item C-c , M-w
-Copy the current tag into the kill ring as well as the tag ring
-(@code{senator-copy-tag}).
-
-@item C-c , C-y
-Yank a tag from the tag ring (@code{senator-yank-tag}).
-
-@item C-c , r
-Copy the current tag into a register
-(@code{senator-copy-tag-to-register}). With an optional argument,
-kill it as well. This allows you to insert or jump to that tag with
-the usual register commands. @xref{Registers,,,emacs,Emacs manual}.
-
-@item C-c , @kbd{up}
-Transpose the current tag with the previous one
-(@code{senator-transpose-tags-up}).
-
-@item C-c , @kbd{down}
-Transpose the current tag with the next one
-(@code{senator-transpose-tags-down}).
-@end table
-
-@node SemanticDB
-@section Semantic Database
-@cindex SemanticDB
-
-The Semantic Database (SemanticDB) caches the results of parsing
-source code files. This data can be saved to disk when you exit
-Emacs, and reloaded automatically when you subsequently revisit the
-same source code files. This saves time by eliminating the need to
-re-parse unmodified files.
-
-SemanticDB also provides an @acronym{API} that programs can use to
-acquire information about source code tags. This information can be
-accessed without loading the original the source files into memory.
-It can also be used to create alternate ``back-ends'' for storing tag
-information in alternative on-disk formats.
-
-By default, SemanticDB is enabled together with Semantic mode. To
-disable it, remove it from @code{semantic-default-submodes}
-(@pxref{Semantic mode}). You can also enable or disable SemanticDB
-with @kbd{M-x global-semanticdb-minor-mode}.
-
-@deffn Command global-semanticdb-minor-mode
-Toggle SemanticDB mode. When enabled, any source code parsed by
-@semantic{} is cached in a database.
-@end deffn
-
-SemanticDB offers a large number of customizable options, which are
-described in the following subsections.
-
-@menu
-* Semanticdb Tag Storage::
-* Semanticdb Search Configuration::
-* Changing Backends::
-* Create System Databases::
-@end menu
-
-@node Semanticdb Tag Storage
-@subsection Semanticdb Tag Storage
-
-Each time you exit Emacs, any data cached by SemanticDB is saved in
-the directory @file{.emacs.d/semanticdb/}, located in your home
-directory. Within this directory, the cache data is written into a
-set of files according to a SemanticDB-specific filename convention.
-If the SemanticDB directory does not exist, Emacs first asks if you
-want to create it.
-
-You can change the name of the SemanticDB directory by customizing the
-variable @code{semanticdb-default-save-directory}.
-
-@deffn Option semanticdb-default-save-directory
-The name of the directory where SemanticDB cache files are saved. If
-the value is @code{nil}, SemanticDB saves its data into a single file,
-in the current directory, whose filename is given by
-@code{semanticdb-default-file-name}.
-@end deffn
-
-@deffn Option semanticdb-default-file-name
-The name of a cache file in which to save SemanticDB, when
-@code{semanticdb-default-save-directory} is @code{nil}.
-@end deffn
-
-You can force SemanticDB to save the data from only certain files, or
-suppress saving altogether, by customizing
-@code{semanticdb-persistent-path}:
-
-@deffn Option semanticdb-persistent-path
-List of valid paths for SemanticDB to cache. Each element should be a
-directory name (a string); then the parse data from any file in that
-directory is saved.
-
-As a special exception, the value of this variable can be a list
-containing a single symbol: @code{never}, @code{always}, or
-@code{project}. The symbol @code{never} disables saving anywhere;
-@code{always} enables saving everywhere; and @code{project} enables
-saving directory based on the variable
-@code{semanticdb-project-predicate-functions}.
-
-The default value is @code{(always)}.
-@end deffn
-
-@defvar semanticdb-project-predicate-functions
-The value of this variable is a list of predicates for indicating that
-a directory belongs to a project. This list is used when the value of
-@code{semanticdb-persistent-path} is @code{(project)}. If the list is
-empty, all paths are considered valid.
-
-Project management packages, such as EDE (@pxref{Top,,,ede,EDE
-manual}), may add their own predicates with @dfn{add-hook} to this
-variable. This allows SemanticDB to save tag caches in directories
-controlled by them.
-@end defvar
-
-@deffn Option semanticdb-save-database-functions
-Abnormal hook run after a database is saved. Each function is called
-with one argument, the object representing the database recently
-written.
-@end deffn
-
-@node Semanticdb Search Configuration
-@subsection Semanticdb Search Configuration
-
- When another part of @semantic{} (or another Emacs package using
-@semantic{}) queries the SemanticDB library for a source code tag, the
-search need not be limited to tags defined within the current file.
-It can include tags defined elsewhere, such as @dfn{header files}
-referenced by the current file (e.g., via the C/C++ @code{#include}
-directive). While performing the search, the SemanticDB library may
-even automatically visit other files and parse them, if necessary.
-
- The variable @code{semanticdb-find-default-throttle} determines how
-aggressively SemanticDB searches for source code tags. @xref{Search
-Throttle}.
-
- The details of SemanticDB searches can vary from language to
-language. In C/C++ code, for example, SemanticDB distinguishes
-between @dfn{project header files} and @dfn{system header files},
-based on whether the @code{#include} directive uses the @code{""} or
-@code{<>} filename delimiter. SemanticDB looks for system header in
-the @dfn{system include path} (@pxref{Include paths}).
-
-@menu
-* Search Throttle:: Controlling how semanticdb searches occur.
-* Semanticdb Roots:: Specifying the root of different projects.
-* Include paths:: Specifying the directories to search.
-* Semanticdb search debugging commands::
-@end menu
-
-@node Search Throttle
-@subsubsection SemanticDB Search Throttle
-
-The SemanticDB @dfn{search throttle} determines how aggressive
-SemanticDB searches are. It is controlled by the variable
-@code{semanticdb-find-default-throttle}. The default value of this
-variable aims for maximum accuracy, at the expense of search time.
-
-Other parts of the @semantic{} package, particularly the different
-language parsers, may change the value of
-@code{semanticdb-find-default-throttle}. You can override its value,
-for a given major mode, like this:
-
-@example
-(setq-mode-local c-mode
- semanticdb-find-default-throttle
- '(project unloaded system recursive))
-@end example
-
-@defvar semanticdb-find-default-throttle
-The default throttle for @code{semanticdb-find} routines.
-The throttle controls how detailed the list of database
-tables is for a symbol lookup. The value is a list with
-the following keys:
-
-@table @code
-@item file
-The file the search is being performed from. This option is here for
-completeness only, and is assumed to always be on.
-@item local
-Tables from the same local directory are included. This includes
-files directly referenced by a file name which might be in a different
-directory.
-@item project
-Tables from the same local project are included If @code{project} is
-specified, then @code{local} is assumed.
-@item unloaded
-If a table is not in memory, load it. If it is not cached on disk
-either, get the source, parse it, and create the table.
-@item system
-Tables from system databases. These are specifically tables
-from system header files, or language equivalent.
-@item recursive
-For include based searches, includes tables referenced by included
-files.
-@item omniscience
-Included system databases which are omniscience, or somehow know
-everything. Omniscience databases are found in
-@code{semanticdb-project-system-databases}. The Emacs Lisp system
-@var{db} is an omniscience database.
-@end table
-@end defvar
-
-@node Semanticdb Roots
-@subsubsection SemanticDB project roots
-
-The @code{project} setting in the SemanticDB search throttle
-(@pxref{Search Throttle}) tells SemanticDB to search within the
-current single code project. For @semantic{}'s point of view,
-@dfn{projects} are determined by their top-level directories, or
-@dfn{project roots}; every subdirectory of a project root is
-considered part of the same project.
-
-If you use EDE for project management, it will set the project roots
-automatically. @xref{Top,,,ede,EDE manual}. You can also specify
-them yourself.
-
-@deffn Option semanticdb-project-roots
-The value of this variable is a list of directories (strings) that are
-project roots. All subdirectories of a project root are considered
-part of the same project. This variable can be overridden by
-@code{semanticdb-project-root-functions}.
-@end deffn
-
-@defvar semanticdb-project-root-functions
-The value of this variable is a list of functions to determine a given
-directory's project root. These functions are called, one at a time,
-with one argument (the directory name), and must return either
-@code{nil}, a string (the project root), or a list of strings
-(multiple project roots, for complex systems). The first
-non-@code{nil} return value, if any, is taken to be the project root,
-overriding @code{semanticdb-project-roots}.
-@end defvar
-
-@node Include paths
-@subsubsection Include Paths
-
-System include paths are standard locations to find source code tags,
-such as the @dfn{header files} in @file{/usr/include} and its
-subdirectories on Unix-like operating systems.
-
-You can add and remove system include paths using the following
-commands:
-
-@deffn Command semantic-add-system-include dir &optional mode
-Prompts for a directory, @var{dir}, and add it as a system include
-path for the current major mode. When called non-interactively, the
-major mode can be specified with the @var{mode} argument.
-@end deffn
-
-@deffn Command semantic-remove-system-include dir &optional mode
-Prompt for a directory, @var{dir}, and remove it from the system
-include path for the current major mode (or @var{mode}).
-@end deffn
-
-@deffn Command semantic-customize-system-include-path &optional mode
-Customize the system include path for the current major mode (or
-@var{mode}).
-@end deffn
-
-@defvar semanticdb-implied-include-tags
-Include tags implied for all files of a given mode. You can set this
-variable with @code{defvar-mode-local} for a particular mode so that
-any symbols that exist for all files for that mode are included.
-@end defvar
-
-@c @xref{Search Optimization}, for more information on include paths.
-
-@node Semanticdb search debugging commands
-@subsubsection Semanticdb search debugging commands
-
-You can use @kbd{M-x semanticdb-dump-all-table-summary} to see the
-list of databases that will be searched from a given buffer. You can
-follow up with @kbd{M-x semanticdb-find-test-translate-path} to then
-make sure specific tables from the path are discovered correctly.
-Alternately, you can get a list of include files @semantic{}
-encountered, but could not find on disk using @kbd{M-x
-semanticdb-find-adebug-lost-includes}.
-
-@deffn Command semanticdb-dump-all-table-summary
-Dump a list of all databases in Emacs memory.
-@end deffn
-
-@deffn Command semanticdb-find-test-translate-path &optional arg
-Call and output results of @dfn{semanticdb-find-translate-path}. In
-the displayed buffer, you can type @key{SPC} to expand items. With
-@var{arg} non-@code{nil}, specify a @var{brutish} translation.
-@end deffn
-
-@deffn Command semanticdb-find-adebug-lost-includes
-Translate the current path, then display the lost includes.
-Examines the variable @code{semanticdb-find-lost-includes}.
-@end deffn
-
-Lastly, you can test an explicit search term using this command:
-
-@deffn Command semantic-adebug-searchdb regex
-Search the semanticdb for @var{regex} for the current buffer.
-Display the results as a debug list.
-@end deffn
-
-@node Changing Backends
-@subsection Changing Backends
-
-If you want to use some other form of backend, you can use this
-variable to choose which back end class to use for your general tag
-storage.
-
-The default is to save databases in flat files. Alternatively, you
-could write a new database backend that stores tags into a database,
-or other storage system.
-
-@defvar semanticdb-new-database-class
-The default type of database created for new files. This can be
-changed on a per file basis, so that some directories are saved using
-one mechanism, and some directories via a different mechanism.
-@end defvar
-
-@node Create System Databases
-@subsection Create System Databases
-
-If your supported language stores the system libraries in readily
-available parsable source code, you can pre-generate database files
-for them once, which will be used over and over for tools such as
-summary-mode, or the analyzer.
-
-@deffn Command semanticdb-create-ebrowse-database dir
-Create an Ebrowse database for directory @var{dir}. The database file
-is stored in ~/.semanticdb, or whichever directory is specified by
-@code{semanticdb-default-system-save-directory}.
-@end deffn
-
-@node Idle Scheduler
-@section Idle Scheduler
-@cindex Idle Scheduler
-
-The @dfn{Semantic Idle Scheduler} is a part of @semantic{} that
-performs various operations while Emacs is waiting for user input
-(idle time). Its primary job is to perform buffer parsing during idle
-time. You can also use the Idle Scheduler to display function
-prototypes (@pxref{Idle Summary Mode}) or symbol completions
-(@pxref{Idle Completions Mode}).
-
-@deffn Command global-semantic-idle-scheduler-mode &optional arg
-This command toggles Semantic Idle Scheduler mode in every
-@semantic{}-enabled buffer. This minor mode ensures that the buffer
-is automatically reparsed whenever Emacs is idle. If there is
-additional idle time, it runs jobs scheduled by other parts of
-@semantic{}, such as Semantic Idle Summary mode (@pxref{Idle Summary
-Mode}) and Semantic Idle Completions mode (@pxref{Idle Completions
-Mode}).
-@end deffn
-
-@deffn Option semantic-idle-scheduler-idle-time
-The value of this variable is the amount of idle time, in seconds,
-before the Semantic idle scheduler activates. The default is 1.
-@end deffn
-
-@deffn Option semantic-idle-scheduler-verbose-flag
-If this variable is non-@code{nil}, the idle scheduler prints verbose
-messages while running, which are useful for debugging.
-@end deffn
-
-@menu
-* Reparsing Options:: Reparsing the current buffer in idle time.
-* Idle Working Options:: Options for extra work done at idle time.
-* Debugging Idle Time Issues:: How to produce good bug reports.
-* Idle Summary Mode:: Display prototype of symbol under cursor.
-* Idle Completions Mode:: Smart completion pop-up help.
-@end menu
-
-@node Reparsing Options
-@subsection Reparsing Options
-
-When activated during idle time, the Semantic idle scheduler
-automatically reparses all buffers that need it. Any arriving user
-input cancels this, returning Emacs to its normal editing behavior.
-
-@deffn Option semantic-idle-scheduler-max-buffer-size
-Maximum size in bytes of buffers automatically reparsed. If this
-value is less than or equal to @var{0}, buffers are automatically
-reparsed regardless of their size.
-@end deffn
-
-@deffn Option semantic-idle-scheduler-no-working-message
-If non-@code{nil}, disable display of working messages while reparsing.
-@end deffn
-
-@deffn Option semantic-idle-scheduler-working-in-modeline-flag
-If non-@code{nil}, show working messages in the mode line. Normally,
-re-parsing shows messages in the minibuffer; this moves the parse
-message to the modeline instead.
-@end deffn
-
-@defvar semantic-before-idle-scheduler-reparse-hook
-This normal hook is run just before the idle scheduler begins
-reparsing. If any hook function throws an error, the value of this
-variable is reset to @code{nil}. This hook is not protected from
-lexical errors.
-@end defvar
-
-@defvar semantic-after-idle-scheduler-reparse-hook
-
-This normal hook is run after the idle scheduler finishes reparsing.
-If any hook throws an error, this variable is reset to @code{nil}.
-This hook is not protected from lexical errors.
-@end defvar
-
-@node Idle Working Options
-@subsection Idle Working Options
-
-In addition to reparsing buffers, the Semantic idle scheduler performs
-additional operations, including the following:
-
-@itemize
-@item
-Creating the include path caches required for symbol lookup.
-@item
-Create data type caches.
-@item
-Saving SemanticDB caches to disk.
-@item
-Speculatively parsing the files in the same directory as the current
-buffer.
-@end itemize
-
-Because this extra work is quite time-consuming, it is only carried
-out after a longer idle delay. The following features control how the
-idle work is performed.
-
-@deffn Option semantic-idle-scheduler-work-idle-time
-The value of this variable is the amount of idle time, in seconds,
-before commencing idle work. The default is 60.
-@end deffn
-
-@deffn Option semantic-idle-work-parse-neighboring-files-flag
-If the value of this variable is non-@code{nil}, the Semantic idle
-scheduler uses idle work time to parse files in the same directory as
-the current buffer. This improves the accuracy of tag searches and
-saves time when visiting those files later, at the cost of doing a lot
-of parsing. The default is @code{t}.
-@end deffn
-
-@node Debugging Idle Time Issues
-@subsection Debugging Idle Time Issues
-
-If you see an error signaled during idle time, it could be an
-indication of a more serious issue elsewhere. It is not enough to
-enable @code{debug-on-error}, because the idle scheduler inhibits the
-debugger. Instead, use the following commands to debug the error:
-
-@deffn Command semantic-debug-idle-function
-Run the Semantic idle function with debugging turned on.
-@end deffn
-
-@deffn Command semantic-debug-idle-work-function
-Run the Semantic idle work function with debugging turned on.
-@end deffn
-
-@node Idle Summary Mode
-@subsection Idle Summary Mode
-
-Semantic Idle Summary mode is a minor mode that displays a short
-summary of the symbol at point, such as its function prototype, in the
-echo area. Its functionality is similar to what ElDoc mode provides
-for Emacs Lisp (@pxref{Programming Language Doc,,,emacs,Emacs manual}).
-
-@deffn global-semantic-idle-summary-mode &optional arg
-This command toggles Semantic Idle Summary mode in all
-@semantic{}-enabled buffers. You can also toggle it via the
-@samp{Show Tag Summaries} menu item in the @samp{Development} menu.
-@end deffn
-
-When Semantic Idle Summary mode is active, a summary of the tag at
-point is displayed in the echo area. This display takes place during
-the idle time, as given by @code{semantic-idle-scheduler-idle-time}
-(@pxref{Idle Scheduler}).
-
-You can override the method for getting the current tag to display by
-setting @code{idle-summary-current-symbol-info}.
-
-@deffn Option semantic-idle-summary-function
-The value of this variable should be a function to call to display tag
-information during idle time. See the variable
-@code{semantic-format-tag-functions} for a list of useful functions.
-@end deffn
-
-@defvar semantic-idle-summary-out-of-context-faces
-The value of this variable is a list of font-lock faces indicating
-useless summary contexts. These are generally faces used to highlight
-comments or strings. Semantic Idle Summary mode does not display its
-usual summary if the text at point has one of these faces.
-@end defvar
-
-@node Idle Completions Mode
-@subsection Idle Completions Mode
-
-Semantic Idle Completions mode is a minor mode for performing
-@dfn{code completions} during idle time. The completions are
-displayed inline, with key bindings that allow you to cycle through
-different alternatives.
-
-Semantic Idle Completions mode performs completion based on the
-Semantic Analyzer (@pxref{Analyzer}).
-
-@deffn global-semantic-idle-completions-mode &optional arg
-This command toggles Semantic Idle Completions mode in every
-@semantic{}-enabled buffer. You can also toggle it via the @samp{Show
-Tag Completions} menu item in the @samp{Development} menu.
-@end deffn
-
-If the tag at point has at least one completion, Semantic Idle
-Completions mode displays that completion inline---i.e., as part of
-the buffer text (you can change the display method by customizing
-@code{semantic-complete-inline-analyzer-idle-displayer-class}, as
-described below). The completed part is highlighted, to indicate that
-it is not yet properly inserted into the buffer. The echo area shows
-the completion, and whether there are other possible completions, like
-this:
-
-@example
-besselj [1 of 6 matches]
-@end example
-
-@noindent
-While the completion is being displayed, the following key bindings
-take effect:
-
-@table @kbd
-@item @key{RET}
-@itemx C-m
-Accept the current completion (@code{semantic-complete-inline-done}),
-placing it in the buffer and moving point to the end of the completed
-tag.
-@item M-n
-Select the next possible completion
-(@code{semantic-complete-inline-down}). The new completion is shown
-inline, replacing the old completion.
-@item M-p
-Select the previous possible completion
-(@code{semantic-complete-inline-up}).
-@item @key{TAB}
-@item C-i
-Accept as much of the completion as possible. If no additional
-completion can be accepted without ambiguity, select the next possible
-completion (@code{semantic-complete-inline-TAB}).
-@item C-g
-Quit without completing (@code{semantic-complete-inline-quit}).
-@end table
-
-@noindent
-You can also exit inline completion by issuing any other Emacs
-command. The completion text then disappears from the buffer.
-
-@deffn Command semantic-complete-analyze-inline-idle
-This is the command for performing inline code completion. It is
-called by Semantic Idle Completions mode during idle time, but you can
-also call it yourself. It returns immediately, leaving the buffer in
-a state for inline completion.
-@end deffn
-
-@deffn Option semantic-complete-inline-analyzer-idle-displayer-class
-The value of this variable determines how
-@code{semantic-complete-analyze-inline-idle} shows its completions.
-Possible values include:
-
-@table @code
-@item semantic-displayer-ghost
-Display completions ``inline'' with the buffer text, as described
-above. This is the default value.
-
-@item semantic-displayer-tooltip
-Display completions in a tooltip.
-
-@item semantic-displayer-traditional
-Display completions in a separate window.
-@end table
-@end deffn
-
-@node Analyzer
-@section Analyzer
-@cindex Analyzer
-
-The Semantic Analyzer is a library for performing context analysis on
-source code. It provides user commands for displaying, completing,
-and navigating through source code.
-
-@menu
-* Smart Completion:: Performing code completion.
-* Smart Summary:: Displaying help on a symbol.
-* Smart Jump:: Jumping to the definition of a tag.
-* Analyzer Debug:: Debugging problems with the analyzer.
-@end menu
-
-@node Smart Completion
-@subsection Smart Completion
-
-The Semantic Analyzer can be used to perform code completion in a
-manner that takes the local context into account. (In addition to the
-user commands in this section, Semantic Idle Completions mode also
-uses the Semantic Analyzer. @xref{Idle Completions Mode}.)
-
-@deffn Command semantic-analyze-possible-completions context
-This is the most basic command for Semantic Analyzer-based completion.
-Called interactively, it displays a list of the possible completions
-for the symbol at point.
-
-When called from a Lisp program,
-@code{semantic-analyze-possible-completions} does not display a
-completions list. The argument @var{context} should be either a
-buffer position, or a context object. The return value is a list of
-@semantic{} tag objects that complete the symbol for @var{context},
-based on the following criteria:
-
-@itemize
-@item Elements currently in scope.
-@item Constants currently in scope.
-@item Elements matching the context's @code{:prefix}.
-@item Type of the completion matching the type of the context.
-@end itemize
-
-Most of the other commands documented in this section call
-@code{semantic-analyze-possible-completions} internally.
-@end deffn
-
-@deffn Command semantic-complete-analyze-inline
-This command is bound to @kbd{C-c , @key{SPC}} when Semantic mode is
-enabled (@pxref{Semantic mode user commands}). It displays a list of
-possible completions for the symbol at point, and activates a special
-set of key bindings for choosing a completion.
-
-You can type @key{RET} to accept the current completion, @kbd{M-n} and
-@kbd{M-p} to cycle through the possible completions, @key{TAB} to
-complete as far as possible and then cycle through completions, and
-either @kbd{C-g} or any other key to abort the completion.
-
-This command is similar to the completion performed by Semantic Idle
-Completions mode. The main difference is that it is called
-explicitly, whereas Semantic Idle Completions mode completes during
-idle time (@pxref{Idle Completions Mode}).
-@end deffn
-
-@deffn Option semantic-complete-inline-analyzer-idle-displayer-class
-The value of this variable determines how
-@code{semantic-complete-analyze-inline} shows its completions.
-Possible values include:
-
-@table @code
-@item semantic-displayer-traditional
-Display completions in a separate window. This is the default value.
-
-@item semantic-displayer-ghost
-Display completions ``inline'' with the buffer text, similar to the
-default behavior of Semantic Idle Completions mode (@pxref{Idle
-Completions Mode}).
-
-@item semantic-displayer-tooltip
-Display completions in a tooltip.
-@end table
-@end deffn
-
-In addition to @code{semantic-complete-analyze-inline}, you can use
-the simpler command @code{semantic-ia-complete-symbol point}. This
-behaves like the usual @kbd{M-@key{TAB}} (@code{complete-symbol})
-command (@pxref{Symbol Completion,,,emacs,Emacs manual}), except it
-uses the Semantic Analyzer.
-
-@deffn Command semantic-ia-complete-symbol point
-Complete the current symbol at @var{point}.
-@end deffn
-
-@node Smart Summary
-@subsection Smart Summary
-
-You can use the following commands to obtain information about the
-code at point:
-
-@deffn Command semantic-ia-show-summary pos
-Display a summary for the symbol at @var{pos}. Called interactively,
-@var{pos} defaults to point.
-@end deffn
-
-@deffn Command semantic-ia-show-doc pos
-Display the code-level documentation for the symbol at @var{pos}.
-Called interactively, @var{pos} defaults to point.
-@end deffn
-
-@deffn Command semantic-ia-describe-class typename
-Prompt for the name of a data type, @var{typename}, and display its
-components. For instance, if the type in question is a class, this
-displays the methods and member variables.
-@end deffn
-
-You can also use Semantic Idle Summary mode to show information about
-the current symbol in the echo area during idle time. @xref{Idle
-Summary Mode}.
-
-@node Smart Jump
-@subsection Smart Jump
-
-The Semantic Analyzer can be used to jump directly to the definition
-for a code symbol.
-
-@deffn Command semantic-ia-fast-jump pos
-Jump to the definition for the symbol at @var{pos}. Called
-interactively, @var{pos} defaults to point.
-@end deffn
-
-@defun semantic-ia-fast-mouse-jump event
-Jump to the definition for the symbol at the position of the mouse
-event @var{event}. This command is meant to be bound to a mouse
-command, like this:
-
-@example
-(global-set-key '[(S-mouse-1)] semantic-ia-fast-mouse-jump)
-@end example
-@end defun
-
-These commands are often more accurate than the @code{xref-find-definitions}
-command (@pxref{Looking Up Identifiers,,,emacs,Emacs manual}), because
-the Semantic Analyzer is context-sensitive.
-
-You can also use @kbd{C-c , j} (@code{semantic-complete-jump-local})
-and @kbd{C-c , J} (@code{semantic-complete-jump}) to navigate tags.
-@xref{Semantic mode user commands}. Those commands do not make use of
-the Semantic Analyzer.
-
-@node Analyzer Debug
-@subsection Debugging the Semantic Analyzer
-
-If the Semantic Analyzer does not analyze your code properly, you can
-take steps to identify and solve the problem. This section was
-written with C/C++ in mind, but should be relevant for any typed
-language.
-
-@subsubsection Step 1: Check the context
-
-To check the current context, type @kbd{M-x
-semantic-analyze-current-context}.
-
-@deffn Command semantic-analyze-current-context pos
-Analyze the context at @var{pos}. This function is used by most of
-the other Semantic Analyzer commands to obtain the context of the code
-at a given buffer position. The return value is an EIEIO object
-describing the context at @var{pos} (@pxref{Top,,,eieio,EIEIO
-manual}).
-
-When called interactively, this displays a @file{*Semantic Context
-Analysis*} buffer containing a summary of the context at point.
-@end deffn
-
-@noindent
-The Prefix section of the @file{*Semantic Context Analysis*} buffer
-lists the tags based on the text at point. If it shows only a simple
-string, the Semantic was unable to identify what the data type was.
-
-The first item in the list of the prefix is the first lookup failure
-in the chain, and that is the item to focus debugging effort on. For
-example:
-
-@example
-Context Type: #<semantic-analyze-context context>
-Bounds: (182 . 185)
-Prefix: Foo* bar
- int bbb (const char* y)
-Prefix Types: class Foo @{@}
---------
--> Local Vars: int argc
- char** argv
-@end example
-
-In this example you can see that the prefix has two fully found tags.
-In the following example, the symbol ``bbb'' is incomplete, and could
-not be found:
-
-@example
-Context Type: #<semantic-analyze-context context>
-Bounds: (182 . 184)
-Prefix: Foo* bar
- "bb"
-Prefix Classes: 'function
- 'variable
-Prefix Types: class Foo @{@}
---------
--> Local Vars: int argc
- char** argv
-@end example
-
-@subsubsection Step 2 : Check your include path
-
-Once you know the missing symbol, check your include path. The header
-or include file containing the needed definition may not be in the
-list of headers @semantic{} is searching through. To get a basic
-list, you can use @kbd{M-x semanticdb-find-test-translate-path}.
-@xref{Semanticdb search debugging commands}.
-
-If items should be loaded but aren't, or if you see some tables that
-have no tags in them, then you may have an incorrectly-set search
-throttle (@pxref{Search Throttle}). For example,
-
-@example
-*#<semanticdb-table main.cpp (4 tags DIRTY)>
-*#<semanticdb-table foo.hh (0 tags DIRTY)>
-@end example
-
-Here, @semantic{} found @file{foo.hh}, but there are 0 tags. This may
-be because you had set the throttle to avoid reading and parsing files
-that Emacs has not visited. To fix this, visit the file and let
-@semantic{} parse it.
-
-For C++, check also that the @samp{#include} statements for your
-project-level files use quotes, not angle brackets; angle brackets are
-for system files.
-
-@subsubsection Step 3: Check the local scope
-
-If your data type is somehow abbreviated based on scope, such as from
-a @code{using} statement, you should make sure that the symbol you
-want is in the local scope. Examine the scope with @kbd{M-x
-semantic-calculate-scope}. The scope structure is displayed in ADEBUG
-mode, so use @kbd{SPC} to expand different elements and looking for
-your symbol.
-
-If your symbol should be in the scope, but you cannot find it, then
-you may have found a language support bug in the local-variable
-parser, or using statement parser.
-
-Calling @kbd{M-x bovinate} should force a reset on the scope in case
-there is merely some bad state.
-
-@example
- ] Name: Cache
- ] Class: #'semantic-scope-cache
- ] :table #<semanticdb-table testsubclass.cpp (13 tags DIRTY)>
- ] tag createMoose : class moose
- ] scopetypes 'nil
- ] parents #<TAG LIST: 1 entries>
- ] scope #<TAG LIST: 22 entries>
- ] fullscope #<TAG LIST: 23 entries>
- ] localvar #<TAG LIST: 6 entries>
-@end example
-
-In the above sample output, the @code{tag} slot specifies where within
-you source this scope is relevant. @code{Parents} should contain any
-in scope parents, such as the class a method belongs to.
-@code{Localvar} should contain your local variables. @code{Scope}
-should contain datatypes in scope due to a @code{using} statement or
-the like.
-
-@subsubsection Step 4: Check the typecache
-
-For complex typed languages like C++, @semantic{} creates a typecache,
-or an optimized search table with all the various data types in it.
-Elements in the typecache do not obey local scope. It only contains
-fully qualified names. You can examine the typecache with
-@kbd{M-x semanticdb-typecache-dump}.
-
-If your data types are not in the typecache, there may be some parsing
-error or other bug. Calling @kbd{M-x bovinate} should force a reset on
-the typecache in case there is merely some bad state.
-
-@example
-]#<semanticdb-typecache /home/zappo/cedet/semantic/tests/testsubclass.cpp>
- ] Name: /home/zappo/cedet/semantic/tests/testsubclass.cpp
- ] Class: #'semanticdb-typecache
- ] filestream 'nil
- ] includestream #<TAG LIST: 84 entries>
- ] stream 'nil
- ] dependants 'nil
-@end example
-
-In the above example, the output of @kbd{M-x semanticdb-typecache-dump}
-was expanded one level. The @code{filestream} slot should contain
-datatypes in the current file. The @code{includestream} should
-contain all the datatypes in all included header files.
-
-The @code{dependants} slot will specify other files that depend on
-this one.
-
-@subsubsection Step 5: Check the parser
-
-Go to the location where your unfound tag should be. You can call
-@kbd{M-x bovinate}, and see a dump of the raw tag structure. To see a
-navigable tree, use @kbd{M-x semantic-adebug-bovinate} instead. You
-can then look to make sure your tag has been properly parsed.
-
-If it has not, then you may have found a parser bug. To get a feel
-how @semantic{} treats your file, type @kbd{M-x
-global-semantic-show-unmatched-syntax-mode}. This causes any syntax
-it cannot parse to be underlined in red.
-
-If your type is not parsable, it could be for a couple of reasons:
-
-@enumerate
-@item
-If there is a MACRO keyword used in the definition of the type, you
-may need to update the @code{semantic-lex-c-preprocessor-symbol-map}
-to account for it.
-
-@item
-Or perhaps the parser needs to be fixed.
-@end enumerate
-
-@node Speedbar
-@section Speedbar
-@cindex speedbar
-
-You can integrate @semantic{} with the Speedbar.
-@xref{Speedbar,,,emacs,Emacs manual}. To do this, add the following
-line to your init file:
-
-@example
-(with-eval-after-load 'speedbar (require 'semantic/sb))
-@end example
-
-@noindent
-Or, alternatively:
-
-@example
-(require 'semantic/sb)
-@end example
-
-Once installed, the Speedbar will use @semantic{} to find and display
-tags. Tags from @semantic{} are displayed with more details than
-ordinary Speedbar tags, such as function arguments and return type.
-
-In addition, you can use the Speedbar to show the output of the
-Semantic Analyzer (@pxref{Analyzer}). To do this, go to the
-@samp{Display} menu item on the Speedbar menu and select
-@samp{Analyze}; or type @kbd{M-x semantic-speedbar-analysis}.
-
-@deffn Command semantic-speedbar-analysis
-Start the Speedbar in Semantic Analysis mode.
-@end deffn
-
-In Semantic Analysis mode, the Speedbar displays information about the
-local context, such as the current function, local arguments and
-variables, and details on the prefix (the current symbol). Each entry
-has an @samp{<i>} button; clicking on this shows a summary of what
-@semantic{} knows about that variable or type. The Speedbar also
-displays a list of possible completions at point.
-
-@node SymRef
-@section Symbol References
-@cindex symref
-
-@semantic{} can interface with external @dfn{symbol reference tools},
-such as GNU Global and GNU Idutils. These tools provide information
-about where different tags or symbols appear.
-
-By default, @semantic{} tries to look for the best external symbol
-reference tool that can be used. The supported tools are GNU Global,
-GNU Idutils, CScope, and Grep (the fallback method). For best
-results, use GNU Global. However, @semantic{} does not manage your
-GNU Global tables for you; you must manage them yourself.
-
-@defvar semantic-symref-tool
-The value of this variable is a symbol that determines the external
-symbol reference tool to use. The default value, @code{detect}, says
-to look for the best available tool. Other possible values are
-@code{global}, @code{idutils}, @code{cscope}, and @code{grep}. Note
-that @code{grep} is much slower than the others.
-@end defvar
-
-The commands to display symbol references are @kbd{C-c , g}
-(@code{semantic-symref-symbol} and @kbd{C-c , G}
-(@code{semantic-symref}). These key bindings are available whenever
-Semantic mode is enabled (@pxref{Semantic mode user commands}).
-
-@deffn Command semantic-symref-symbol sym
-This command (normally bound to @kbd{C-c , g}) prompts for a symbol
-name, and uses an external reference tool to find references to that
-tag.
-@end deffn
-
-@deffn Command semantic-symref
-This command (normally bound to @kbd{C-c , G}) uses an external
-reference tool to find references to the current tag.
-@end deffn
-
-Both @code{semantic-symref-symbol} and @code{semantic-symref} display
-a list of symbol references in a separate buffer. The entries are
-organized by file, and by function name. Typing @key{RET} on the
-@samp{[+]} next to each function name ``expands'' that entry, listing
-all references to the target symbol occurring within that function.
-Typing @kbd{RET} on a reference line jumps to that reference.
-
-@node MRU Bookmarks
-@section MRU Bookmarks mode
-@cindex @code{semantic-mru-bookmark-mode}
-
-Semantic MRU Bookmarks mode is a minor mode that keeps track of the
-tags you have edited, allowing you to quickly return to them later
-(MRU stands for ``Most Recently Used'').
-
-@deffn Command global-semantic-mru-bookmark-mode &optional arg
-Toggle Semantic MRU Bookmarks mode globally. The minor mode can be
-turned on only if the current buffer was set up for parsing. With
-argument @var{arg}, turn the minor mode if @var{arg} is positive, and
-off otherwise.
-@end deffn
-
-Semantic MRU Bookmarks mode takes note of each tag you edit.
-Afterwards, you can type @kbd{C-x B}
-(@code{semantic-mrub-switch-tags}) to return to a tag. This command
-prompts for a tag name, completing with the names of edited tags; at
-the prompt, you can use @kbd{M-p} and @kbd{M-n} to cycle through tags
-in order of last modification time.
-
-@node Sticky Func Mode
-@section Sticky Function mode
-
-Semantic Sticky Function minor mode displays a header line that shows
-the declaration line of the function or tag on the topmost line in the
-text area. This allows you to keep that declaration line in view at
-all times, even if it is scrolls off the ``top'' of the screen.
-
-In addition, clicking @kbd{mouse-1} on the header line opens a context
-menu that contains menu items for copying, killing, or narrowing to
-that tag.
-
-@deffn Command global-semantic-stickyfunc-mode &optional arg
-Toggle Semantic Sticky Function mode in all Semantic-enabled buffers.
-With an optional argument @var{arg}, enable if @var{arg} is positive,
-and disable otherwise.
-@end deffn
-
-@defvar semantic-stickyfunc-sticky-classes
-The value of this variable is a list of tag classes that Semantic
-Sticky Function mode makes ``sticky''. The default is
-@code{'(function type)}, meaning function declarations and type
-declarations. Other possible tag classes are @code{variable},
-@code{include}, and @code{package}.
-@end defvar
-
-@node Highlight Func Mode
-@section Highlight Func Mode
-@cindex @code{semantic-highlight-func-mode}
-
-Semantic Highlight Function minor mode highlights the declaration line
-of the current function or tag (that is to say, the first line that
-describes the rest of the construct).
-
-In addition, clicking @kbd{mouse-3} on the highlighted declaration
-line opens a context menu that contains menu items for copying,
-killing, or narrowing to that tag.
-
-The tag classes highlighted by Semantic Highlight Function mode are
-the same ones given by @code{semantic-stickyfunc-sticky-classes}.
-@xref{Sticky Func Mode}.
-
-@defun global-semantic-highlight-func-mode &optional arg
-Toggle Semantic Highlight Function mode in all Semantic-enabled
-buffers. With an optional argument @var{arg}, enable if @var{arg} is
-positive, and disable otherwise.
-@end defun
-
-@deffn Face semantic-highlight-func-current-tag-face
-This face is used to highlight declaration lines in Semantic Highlight
-Func mode.
-@end deffn
-
-@node Tag Decoration Mode
-@section Tag Decoration Mode
-@cindex @code{semantic-decoration-mode}
-
-Semantic Tag Decoration mode ``decorates'' each tag based on certain
-arbitrary features of that tag. Decorations are specified using the
-variable @code{semantic-decoration-styles}.
-
-@deffn Command global-semantic-decoration-mode &optional arg
-Toggle Semantic Tag Decoration mode in all Semantic-enabled buffers.
-With an optional argument @var{arg}, enable if @var{arg} is positive,
-and disable otherwise.
-@end deffn
-
-@defvar semantic-decoration-styles
-The value of this variable is a list of decoration styles for Semantic
-Tag Decoration mode. Each element in this list should have the form
-@code{(@var{name} . @var{flag})}, where @var{name} is a style name (a
-symbol) and @var{flag} is non-@code{nil} if the style is enabled.
-
-The following styles are available:
-
-@table @code
-@item semantic-tag-boundary
-Place an overline in front of each long tag (excluding prototypes).
-
-@item semantic-decoration-on-private-members
-Highlight class members that are designated as private.
-
-@item semantic-decoration-on-protected-members
-Highlight class members that are designated as protected.
-
-@item semantic-decoration-on-includes
-Highlight class members that are includes. Clicking on the
-highlighted include statements opens a context menu for configuring
-@semantic{} includes.
-@end table
-@end defvar
-
-To enable or disable specific decorations, use this function:
-
-@deffn Command semantic-toggle-decoration-style name &optional arg
-Prompt for a decoration style, @var{name}, and turn it on or off.
-With prefix argument @var{arg}, turn on if positive, otherwise off.
-Return non-@code{nil} if the decoration style is enabled.
-@end deffn
-
-@deffn Face semantic-tag-boundary-face
-Face for long tags in the @code{semantic-tag-boundary} decoration
-style.
-@end deffn
-
-@deffn Face semantic-decoration-on-private-members-face
-Face for privately-scoped tags in the
-@code{semantic-decoration-on-private-members} decoration style.
-@end deffn
-
-@deffn Face semantic-decoration-on-protected-members-face
-Face for protected tags in the
-@code{semantic-decoration-on-protected-members} decoration style.
-@end deffn
-
-@deffn Face semantic-decoration-on-includes
-Face for includes that are not in some other state, in the
-@code{semantic-decoration-on-includes} decoration style.
-@end deffn
-
-@deffn Face semantic-decoration-on-unknown-includes
-Face for includes that cannot be found, in the
-@code{semantic-decoration-on-includes} decoration style.
-@end deffn
-
-@deffn Face semantic-decoration-on-unparsed-includes
-Face for includes that have not yet been parsed, in the
-@code{semantic-decoration-on-includes} decoration style.
-@end deffn
-
-@subsection Creating New Decoration Modes
-
-You can create new types of decorations using the following function:
-
-@defun define-semantic-decoration-style name doc &rest flags
-Define a new decoration style with @var{name}.
-@var{doc} is a documentation string describing the decoration style @var{name}.
-It is appended to auto-generated doc strings.
-An optional list of @var{flags} can also be specified. Flags are:
- @code{:enabled} <value> - specify the default enabled value for @var{name}.
-
-
-This defines two new overload functions respectively called @code{NAME-p}
-and @code{NAME-highlight}, for which you must provide a default
-implementation in respectively the functions @code{NAME-p-default} and
-@code{NAME-highlight-default}. Those functions are passed a tag. @code{NAME-p}
-must return non-@code{nil} to indicate that the tag should be decorated by
-@code{NAME-highlight}.
-
-To put primary decorations on a tag @code{NAME-highlight}, use
-functions like @dfn{semantic-set-tag-face},
-@dfn{semantic-set-tag-intangible}, etc., found in the
-semantic-decorate library.
-
-To add other kind of decorations on a tag, @code{NAME-highlight} must use
-@dfn{semantic-decorate-tag}, and other functions of the semantic
-decoration @var{api} found in this library.
-@end defun
+++ /dev/null
-\input texinfo
-@setfilename ../../info/semantic.info
-@set TITLE Semantic Manual
-@set AUTHOR Eric M. Ludlam, David Ponce, and Richard Y. Kim
-@settitle @value{TITLE}
-@include docstyle.texi
-
-@c *************************************************************************
-@c @ Header
-@c *************************************************************************
-
-@c Merge all indexes into a single index for now.
-@c We can always separate them later into two or more as needed.
-@syncodeindex vr cp
-@syncodeindex fn cp
-@syncodeindex ky cp
-@syncodeindex pg cp
-@syncodeindex tp cp
-
-@c @footnotestyle separate
-@c @paragraphindent 2
-@c @@smallbook
-@c %**end of header
-
-@copying
-This manual documents the Semantic library and utilities.
-
-Copyright @copyright{} 1999--2024 Free Software Foundation, Inc.
-
-@quotation
-Permission is granted to copy, distribute and/or modify this document
-under the terms of the GNU Free Documentation License, Version 1.3 or
-any later version published by the Free Software Foundation; with no
-Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''
-and with the Back-Cover Texts as in (a) below. A copy of the license
-is included in the section entitled ``GNU Free Documentation License.''
-
-(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and
-modify this GNU manual.''
-@end quotation
-@end copying
-
-@dircategory Emacs misc features
-@direntry
-* Semantic: (semantic). Source code parser library and utilities.
-@end direntry
-
-@titlepage
-@center @titlefont{Semantic}
-@sp 4
-@center by @value{AUTHOR}
-@page
-@vskip 0pt plus 1filll
-@insertcopying
-@end titlepage
-@page
-
-@macro semantic{}
-@i{Semantic}
-@end macro
-
-@macro keyword{kw}
-@anchor{\kw\}
-@b{\kw\}
-@end macro
-
-@c *************************************************************************
-@c @ Document
-@c *************************************************************************
-@contents
-
-@node top
-@top @value{TITLE}
-
-@semantic{} is a suite of Emacs libraries and utilities for parsing
-source code. At its core is a lexical analyzer and two parser
-generators (@code{bovinator} and @code{wisent}) written in Emacs Lisp.
-@semantic{} provides a variety of tools for making use of the parser
-output, including user commands for code navigation and completion, as
-well as enhancements for imenu, speedbar, whichfunc, eldoc,
-hippie-expand, and several other parts of Emacs.
-
-To send bug reports, or participate in discussions about semantic,
-use the mailing list cedet-semantic@@sourceforge.net via the URL:
-@url{https://lists.sourceforge.net/lists/listinfo/cedet-semantic}
-
-@ifnottex
-@insertcopying
-@end ifnottex
-
-@menu
-* Introduction::
-* Using Semantic::
-* Semantic Internals::
-* Glossary::
-* GNU Free Documentation License::
-* Index::
-@end menu
-
-@node Introduction
-@chapter Introduction
-
-This chapter gives an overview of @semantic{} and its goals.
-
-Ordinarily, Emacs uses regular expressions (and syntax tables) to
-analyze source code for purposes such as syntax highlighting. This
-approach, though simple and efficient, has its limitations: roughly
-speaking, it only ``guesses'' the meaning of each piece of source code
-in the context of the programming language, instead of rigorously
-``understanding'' it.
-
-@semantic{} provides a new infrastructure to analyze source code using
-@dfn{parsers} instead of regular expressions. It contains two
-built-in parser generators (an @acronym{LL} generator named
-@code{Bovine} and an @acronym{LALR} generator named @code{Wisent},
-both written in Emacs Lisp), and parsers for several common
-programming languages. It can also make use of @dfn{external
-parsers}---programs such as GNU Global and GNU IDUtils.
-
-@semantic{} provides a uniform, language-independent @acronym{API} for
-accessing the parser output. This output can be used by other Emacs
-Lisp programs to implement ``syntax-aware'' behavior. @semantic{}
-itself includes several such utilities, including user-level Emacs
-commands for navigating, searching, and completing source code.
-
-The following diagram illustrates the structure of the @semantic{}
-package:
-
-@table @strong
-@item Please Note:
-The words in all-capital are those that @semantic{} itself provides.
-Others are current or future languages or applications that are not
-distributed along with @semantic{}.
-@end table
-
-@example
- Applications
- and
- Utilities
- -------
- / \
- +---------------+ +--------+ +--------+
- C --->| C PARSER |--->| | | |
- +---------------+ | | | |
- +---------------+ | COMMON | | COMMON |<--- SPEEDBAR
- Java --->| JAVA PARSER |--->| PARSE | | |
- +---------------+ | TREE | | PARSE |<--- SEMANTICDB
- +---------------+ | FORMAT | | API |
- Scheme --->| SCHEME PARSER |--->| | | |<--- ecb
- +---------------+ | | | |
- +---------------+ | | | |
- Texinfo --->| TEXI. PARSER |--->| | | |
- +---------------+ | | | |
-
- ... ... ... ...
-
- +---------------+ | | | |
- Lang. Y --->| Y Parser |--->| | | |<--- app. ?
- +---------------+ | | | |
- +---------------+ | | | |<--- app. ?
- Lang. Z --->| Z Parser |--->| | | |
- +---------------+ +--------+ +--------+
-@end example
-
-@menu
-* Semantic Components::
-@end menu
-
-@node Semantic Components
-@section Semantic Components
-
-In this section, we provide a more detailed description of the major
-components of @semantic{}, and how they interact with one another.
-
-The first step in parsing a source code file is to break it up into
-its fundamental components. This step is called lexical analysis:
-
-@example
- syntax table, keywords list, and options
- |
- |
- v
- input file ----> Lexer ----> token stream
-@end example
-
-@noindent
-The output of the lexical analyzer is a list of tokens that make up
-the file. The next step is the actual parsing, shown below:
-
-@example
- parser tables
- |
- v
- token stream ---> Parser ----> parse tree
-@end example
-
-@noindent
-The end result, the parse tree, is @semantic{}'s internal
-representation of the language grammar. @semantic{} provides an
-@acronym{API} for Emacs Lisp programs to access the parse tree.
-
-Parsing large files can take several seconds or more. By default,
-@semantic{} automatically caches parse trees by saving them in your
-@file{.emacs.d} directory. When you revisit a previously-parsed file,
-the parse tree is automatically reloaded from this cache, to save
-time. @xref{SemanticDB}.
-
-@node Using Semantic
-@chapter Using Semantic
-
-@include sem-user.texi
-
-@node Semantic Internals
-@chapter Semantic Internals
-
-This chapter provides an overview of the internals of @semantic{}.
-This information is usually not needed by application developers or
-grammar developers; it is useful mostly for the hackers who would like
-to learn more about how @semantic{} works.
-
-@menu
-* Parser code:: Code used for the parsers
-* Tag handling:: Code used for manipulating tags
-* Semanticdb Internals:: Code used in the semantic database
-* Analyzer Internals:: Code used in the code analyzer
-* Tools:: Code used in user tools
-@ignore
-* Tests:: Code used for testing
-@end ignore
-@end menu
-
-@node Parser code
-@section Parser code
-
-@semantic{} parsing code is spread across a range of files.
-
-@table @file
-@item semantic.el
-The core infrastructure sets up buffers for parsing, and has all the
-core parsing routines. Most parsing routines are overloadable, so the
-actual implementation may be somewhere else.
-
-@item semantic/edit.el
-Incremental reparse based on user edits.
-
-@item semantic/grammar.el
-@itemx semantic-grammar.wy
-Parser for the different grammar languages, and a major mode for
-editing grammars in Emacs.
-
-@item semantic/lex.el
-Infrastructure for implementing lexical analyzers. Provides macros
-for creating individual analyzers for specific features, and a way to
-combine them together.
-
-@item semantic/lex-spp.el
-Infrastructure for a lexical symbolic preprocessor. This was written
-to implement the C preprocessor, but could be used for other lexical
-preprocessors.
-
-@item semantic/grammar.el
-@itemx semantic/bovine/grammar.el
-The ``bovine'' grammar. This is the first grammar mode written for
-@semantic{} and is useful for creating simple parsers.
-
-@item semantic/wisent.el
-@itemx semantic/wisent/wisent.el
-@itemx semantic/wisent/grammar.el
-A port of bison to Emacs. This infrastructure lets you create LALR
-based parsers for @semantic{}.
-
-@item semantic/debug.el
-Infrastructure for debugging grammars.
-
-@item semantic/util.el
-Various utilities for manipulating tags, such as describing the tag
-under point, adding labels, and the all important
-@code{semantic-something-to-tag-table}.
-
-@end table
-
-@node Tag handling
-@section Tag handling
-
-A tag represents an individual item found in a buffer, such as a
-function or variable. Tag handling is handled in several source
-files.
-
-@table @file
-@item semantic/tag.el
-Basic tag creation, queries, cloning, binding, and unbinding.
-
-@item semantic/tag-write.el
-Write a tag or tag list to a stream. These routines are used by
-@file{semanticdb-file.el} when saving a list of tags.
-
-@item semantic/tag-file.el
-Files associated with tags. Goto-tag, file for include, and file for
-a prototype.
-
-@item semantic/tag-ls.el
-Language dependent features of a tag, such as parent calculation, slot
-protection, and other states like abstract, virtual, static, and leaf.
-
-@item semantic/dep.el
-Include file handling. Contains the include path concepts, and
-routines for looking up file names in the include path.
-
-@item semantic/format.el
-Convert a tag into a nicely formatted and colored string. Use
-@code{semantic-test-all-format-tag-functions} to test different output
-options.
-
-@item semantic/find.el
-Find tags matching different conditions in a tag table.
-These routines are used by @file{semanticdb-find.el} once the database
-has been converted into a simpler tag table.
-
-@item semantic/sort.el
-Sorting lists of tags in different ways. Includes sorting a plain
-list of tags forward or backward. Includes binning tags based on
-attributes (bucketize), and tag adoption for multiple references to
-the same thing.
-
-@item semantic/doc.el
-Capture documentation comments from near a tag.
-
-@end table
-
-@node Semanticdb Internals
-@section Semanticdb Internals
-
-@acronym{Semanticdb} complexity is certainly an issue. It is a rather
-hairy problem to try and solve.
-
-@table @file
-@item semantic/db.el
-Defines a @dfn{database} and a @dfn{table} base class. You can
-instantiate these classes, and use them, but they are not persistent.
-
-This file also provides support for @code{semanticdb-minor-mode},
-which automatically associates files with tables in databases so that
-tags are @emph{saved} while a buffer is not in memory.
-
-The database and tables both also provide applicable cache information,
-and cache flushing system. The semanticdb search routines use caches
-to save data structures that are complex to calculate.
-
-Lastly, it provides the concept of @dfn{project root}. It is a system
-by which a file can be associated with the root of a project, so if
-you have a tree of directories and source files, it can find the root,
-and allow a tag-search to span all available databases in that
-directory hierarchy.
-
-@item semantic/db-file.el
-Provides a subclass of the basic table so that it can be saved to
-disk. Implements all the code needed to unbind/rebind tags to a
-buffer and writing them to a file.
-
-@item semantic/db-el.el
-Implements a special kind of @dfn{system} database that uses Emacs
-internals to perform queries.
-
-@item semantic/db-ebrowse.el
-Implements a system database that uses Ebrowse to parse files into a
-table that can be queried for tag names. Successful tag hits during a
-find causes @semantic{} to pick up and parse the reference files to
-get the full details.
-
-@item semantic/db-find.el
-Infrastructure for searching groups @semantic{} databases, and dealing
-with the search results format.
-
-@item semantic/db-ref.el
-Tracks crossreferences. Cross references are needed when buffer is
-reparsed, and must alert other tables that any dependent caches may
-need to be flushed. References are in the form of include files.
-
-@end table
-
-@node Analyzer Internals
-@section Analyzer Internals
-
-The @semantic{} analyzer is a complex engine which has been broken
-down across several modules. When the @semantic{} analyzer fails,
-start with @code{semantic-analyze-debug-assist}, then dive into some
-of these files.
-
-@table @file
-@item semantic/analyze.el
-The core analyzer for defining the @dfn{current context}. The
-current context is an object that contains references to aspects of
-the local context including the current prefix, and a tag list
-defining what the prefix means.
-
-@item semantic/analyze/complete.el
-Provides @code{semantic-analyze-possible-completions}.
-
-@item semantic/analyze/debug.el
-The analyzer debugger. Useful when attempting to get everything
-configured.
-
-@item semantic/analyze/fcn.el
-Various support functions needed by the analyzer.
-
-@item semantic/ctxt.el
-Local context parser. Contains overloadable functions used to move
-around through different scopes, get local variables, and collect the
-current prefix used when doing completion.
-
-@item semantic/scope.el
-Calculate @dfn{scope} for a location in a buffer. The scope includes
-local variables, and tag lists in scope for various reasons, such as
-C++ using statements.
-
-@item semantic/db-typecache.el
-The typecache is part of @code{semanticdb}, but is used primarily by
-the analyzer to look up datatypes and complex names. The typecache is
-bound across source files and builds a master lookup table for data
-type names.
-
-@item semantic/ia.el
-Interactive Analyzer functions. Simple routines that do completion or
-lookups based on the results from the Analyzer. These routines are
-meant as examples for application writers, but are quite useful as
-they are.
-
-@item semantic/ia-sb.el
-Speedbar support for the analyzer, displaying context info, and
-completion lists.
-
-@end table
-
-@node Tools
-@section Tools
-
-These files contain various tools for users.
-
-@table @file
-@item semantic/idle.el
-Idle scheduler for @semantic{}. Manages reparsing buffers after
-edits, and large work tasks in idle time. Includes modes for showing
-summary help and pop-up completion.
-
-@item semantic/senator.el
-The @semantic{} navigator. Provides many ways to move through a
-buffer based on the active tag table.
-
-@item semantic/decorate.el
-A minor mode for decorating tags based on details from the parser.
-Includes overlines for functions, or coloring class fields based on
-protection.
-
-@item semantic/decorate/include.el
-A decoration mode for include files, which assists users in setting up
-parsing for their includes.
-
-@item semantic/complete.el
-Advanced completion prompts for reading tag names in the minibuffer, or
-inline in a buffer.
-
-@item semantic/imenu.el
-Imenu support for using @semantic{} tags in imenu.
-
-@item semantic/mru-bookmark.el
-Automatic bookmarking based on tags. Jump to locations you've been
-before based on tag name.
-
-@item semantic/sb.el
-Support for @semantic{} tag usage in Speedbar.
-
-@item semantic/util-modes.el
-A bunch of small minor-modes that exposes aspects of the semantic
-parser state. Includes @code{semantic-stickyfunc-mode}.
-
-@item semantic/chart.el
-Draw some charts from stats generated from parsing.
-
-@end table
-
-@c These files seem to not have been imported from CEDET.
-@ignore
-@node Tests
-@section Tests
-
-@table @file
-
-@item semantic-utest.el
-Basic testing of parsing and incremental parsing for most supported
-languages.
-
-@item semantic-ia-utest.el
-Test the semantic analyzer's ability to provide smart completions.
-
-@item semantic-utest-c.el
-Tests for the C parser's lexical pre-processor.
-
-@item semantic-regtest.el
-Regression tests from the older Semantic 1.x API.
-
-@end table
-@end ignore
-
-@node Glossary
-@appendix Glossary
-
-@table @asis
-@item BNF
-In semantic 1.4, a BNF file represented ``Bovine Normal Form'', the
-grammar file used for the 1.4 parser generator. This was a play on
-Backus-Naur Form which proved too confusing.
-
-@item bovinate
-A verb representing what happens when a bovine parser parses a file.
-
-@item bovine lambda
-In a bovine, or LL parser, the bovine lambda is a function to execute
-when a specific set of match rules has succeeded in matching text from
-the buffer.
-
-@item bovine parser
-A parser using the bovine parser generator. It is an LL parser
-suitable for small simple languages.
-
-@item context
-
-@item LALR
-
-@item lexer
-A program which converts text into a stream of tokens by analyzing
-them lexically. Lexers will commonly create strings, symbols,
-keywords and punctuation, and strip whitespaces and comments.
-
-@item LL
-
-@item nonterminal
-A nonterminal symbol or simply a nonterminal stands for a class of
-syntactically equivalent groupings. A nonterminal symbol name is used
-in writing grammar rules.
-
-@item overloadable
-Some functions are defined via @code{define-overload}.
-These can be overloaded via ....
-
-@item parser
-A program that converts @b{tokens} to @b{tags}.
-
-@item tag
-A tag is a representation of some entity in a language file, such as a
-function, variable, or include statement. In semantic, the word tag is
-used the same way it is used for the etags or ctags tools.
-
-A tag is usually bound to a buffer region via overlay, or it just
-specifies character locations in a file.
-
-@item token
-A single atomic item returned from a lexer. It represents some set
-of characters found in a buffer.
-
-@item token stream
-The output of the lexer as well as the input to the parser.
-
-@item wisent parser
-A parser using the wisent parser generator. It is a port of bison to
-Emacs Lisp. It is an LALR parser suitable for complex languages.
-@end table
-
-
-@node GNU Free Documentation License
-@appendix GNU Free Documentation License
-@include doclicense.texi
-
-@node Index
-@unnumbered Index
-@printindex cp
-
-@iftex
-@contents
-@summarycontents
-@end iftex
-
-@bye
-
-@c Following comments are for the benefit of ispell.
-
-@c LocalWords: alist API APIs arg argc args argv asis assoc autoload Wisent
-@c LocalWords: bnf bovinate bovinates LALR
-@c LocalWords: bovinating bovination bovinator bucketize
-@c LocalWords: cb cdr charquote checkcache cindex CLOS
-@c LocalWords: concat concocting const ctxt Decl defcustom
-@c LocalWords: deffn deffnx defun defvar destructor's dfn diff dir
-@c LocalWords: doc docstring EDE EIEIO elisp emacsman emph enum
-@c LocalWords: eq Exp EXPANDFULL expression fn foo func funcall
-@c LocalWords: ia ids ifinfo imenu imenus init int isearch itemx java kbd
-@c LocalWords: keymap keywordtable lang languagemode lexer lexing Ludlam
-@c LocalWords: menubar metaparent metaparents min minibuffer Misc mode's
-@c LocalWords: multitable NAvigaTOR noindent nomedian nonterm noselect
-@c LocalWords: nosnarf obarray OLE OO outputfile paren parsetable POINT's
-@c LocalWords: popup positionalonly positiononly positionormarker pre
-@c LocalWords: printf printindex Programmatically pt quotemode
-@c LocalWords: ref regex regexp Regexps reparse resetfile samp sb
-@c LocalWords: scopestart SEmantic semanticdb setfilename setq
-@c LocalWords: settitle setupfunction sexp sp SPC speedbar speedbar's
-@c LocalWords: streamorbuffer struct subalist submenu submenus
-@c LocalWords: subsubsection sw sym texi texinfo titlefont titlepage
-@c LocalWords: tok TOKEN's toplevel typemodifiers uml unset untar
-@c LocalWords: uref usedb var vskip xref yak
+++ /dev/null
-\input texinfo
-@c %**start of header
-@setfilename ../../info/srecode.info
-@set TITLE SRecoder Manual
-@set AUTHOR Eric M. Ludlam
-@settitle @value{TITLE}
-@include docstyle.texi
-
-@c Merge all indexes into a single index for now.
-@c We can always separate them later into two or more as needed.
-@syncodeindex vr cp
-@syncodeindex fn cp
-@syncodeindex ky cp
-@syncodeindex pg cp
-@syncodeindex tp cp
-@c %**end of header
-
-@copying
-Copyright @copyright{} 2007--2024 Free Software Foundation, Inc.
-
-@quotation
-Permission is granted to copy, distribute and/or modify this document
-under the terms of the GNU Free Documentation License, Version 1.3 or
-any later version published by the Free Software Foundation; with no
-Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''
-and with the Back-Cover Texts as in (a) below. A copy of the license
-is included in the section entitled ``GNU Free Documentation License''.
-
-(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and
-modify this GNU manual.''
-@end quotation
-@end copying
-
-@dircategory Emacs misc features
-@direntry
-* SRecode: (srecode). Semantic template code generator.
-@end direntry
-
-@titlepage
-@sp 10
-@center @titlefont{SRecode}
-@vskip 0pt plus 1 fill
-@center by @value{AUTHOR}
-@page
-@vskip 0pt plus 1filll
-@insertcopying
-@end titlepage
-
-@macro semantic{}
-@i{Semantic}
-@end macro
-
-@macro EIEIO{}
-@i{EIEIO}
-@end macro
-
-@macro srecode{}
-@i{SRecode}
-@end macro
-
-@node Top
-@top @value{TITLE}
-
-@srecode{} is the @i{Semantic Recoder}. Where @semantic{} will parse
-source files into lists of tags, the @i{Semantic Recoder} will aid in
-converting @semantic{} tags and various other information back into
-various types of code.
-
-While the @srecode{} tool provides a template language, templates for
-several languages, and even a sequence of heuristics that aid the user
-in choosing a template to insert, this is not the main goal of
-@srecode{}.
-
-The goal of @srecode{} is to provide an application framework where
-someone can write a complex code generator, and the underlying
-template commonality allows it to work in multiple languages with
-ease.
-
-@ifnottex
-@insertcopying
-@end ifnottex
-
-@menu
-* Quick Start:: Basic Setup for template insertion.
-* User Templates:: Custom User Templates
-* Parts of SRecode:: Parts of the system
-* SRecode Minor Mode:: A minor mode for using templates
-* Template Writing:: How to write a template
-* Dictionaries:: How dictionaries work
-* Developing Template Functions:: How to write your own template insert functions.
-* Template Naming Conventions:: Creating a set of core templates
-* Inserting Tag Lists:: Inserting Semantic tags via templates
-* Application Writing:: Writing an @srecode{}r application
-* GNU Free Documentation License:: The license for this documentation.
-* Index::
-@end menu
-
-
-@node Quick Start
-@chapter Quick Start
-
-When you install CEDET and enable @srecode{}, an @code{SRecoder} menu
-item should appear.
-
-To toggle @srecode{} minor mode on and off use:
-
-@example
-M-x srecode-minor-mode @key{RET}
-@end example
-or
-@example
-M-x global-srecode-minor-mode @key{RET}
-@end example
-
-or add
-
-@example
-(srecode-minor-mode 1)
-@end example
-
-into a language hook function to force it on (which is the default) or
-pass in @code{-1} to force it off.
-
-See @ref{SRecode Minor Mode} for more on using the minor mode.
-
-Use the menu to insert templates into the current file.
-
-You can add your own templates in @file{~/.srecode}, or update the
-template map path:
-
-@deffn Option srecode-map-load-path
-@anchor{srecode-map-load-path}
-Global load path for SRecode template files.
-@end deffn
-
-
-Once installed, you can start inserting templates using the menu, or
-the command:
-
-@deffn Command srecode-insert template-name &rest dict-entries
-@anchor{srecode-insert}
-Insert the template @var{template-name} into the current buffer at point.
-@var{dict-entries} are additional dictionary values to add.
-@end deffn
-
-SRecode Insert will prompt for a template name. Template names are
-specific to each major mode. A typical name is of the form:
-@code{CONTEXT:NAME} where a @var{CONTEXT} might be something like
-@code{file} or @code{declaration}. The same @var{NAME} can occur in
-multiple contexts.
-
-@node User Templates
-@chapter User Templates
-
-@srecode{} builds and maintains a map of all template files. The root
-template files resides in the @srecode{} distribution. User written
-templates files are saved in @file{~/.srecode}, along with the
-@srecode{} map file.
-
-@defvar srecode-map-save-file
-@anchor{srecode-map-save-file}
-The save location for SRecode's map file.
-@end defvar
-
-Template files end with a @file{.srt} extension. Details on how to
-write templates are in @ref{Template Writing}.
-
-Each template file you write is dedicated to a single major mode. In
-it, you can write templates within the same context and with the same
-name as core templates. You can force your templates to override the
-core templates for a particular major mode by setting the
-priority. See @ref{Special Variables}.
-
-To get going quickly, open a new @file{.srt} file. It will start in
-the @srecode{} template writing mode. Use the @srecode{} minor mode
-menu to insert the @code{empty} file template.
-
-When using templates in other modes (such as C++ or Emacs Lisp
-templates), use the ``Edit Template'' menu to find a template you
-would like to update. Copy it into your user template file, and
-change it.
-
-If you were to update @code{declaration:function} in your user
-template file, then you would get this new template instead of the one
-that comes with @srecode{}. Higher level applications should always
-use @code{declaration:function} when generating their own code, so
-higher level templates will then adopt your changes to
-@code{declaration:function} into themselves.
-
-You can also override variables. Core variables are stored in the
-@srecode{} root template file @file{default.srt}, and that contains
-the copyright usually used, and some basic file setup formats.
-Override variables like this by specifying a @code{mode} of
-@code{default} like this:
-
-@example
-set mode "default"
-@end example
-
-@node Parts of SRecode
-@chapter Parts of SRecode
-
-The @srecode{} system is made up of several layers which work together
-to generate code.
-
-@section Template Layer
-The template layer provides a way to write, and compile templates. The
-template layer is the scheme used to insert text into an Emacs buffer.
-
-The @srecode{} template layer is more advanced than other modes like the
-Emacs packages @code{skeleton} or @code{tempo} in that it allows
-multiple layers of templates to be created with the same names. This
-means that @srecode{} can provide a wide range of templates, and users
-can override only the small sections they want, instead of either
-accepting someone else's template, or writing large new templates of
-their own.
-
-Templates are written in @file{.srt} files. You can learn how to
-author new @file{.srt} files @ref{Template Writing}.
-
-While the template system was designed for @srecode{} based
-applications it can also be used independently for simple template
-insertion during typical coding.
-
-@section Template Manager
-Once templates have been written, a scheme for loading and selecting
-templates is needed. The template manager has a loader for finding
-template files, and determining which templates are relevant to the
-current buffer. Template files are sorted by priority, with user
-templates being found first, and system level default templates last.
-Templates are also sorted by application. Each application has its
-own templates, and are kept separate from the generic templates.
-
-@section Dictionary
-Dictionaries contain values associated with variable. Variables are
-used in macros in a template. Variables are what allows a generic
-template such as a function to be made specific, such as a function
-named foo. The value of a variable can be one of three things; a
-string, a list of more dictionaries, or a special
-@code{srecode-dictionary-compound-value} object subclass. See
-@ref{Variables} for more.
-
-@section Template Insertion
-The template insertion layer involves extensions to the basic template
-layer. A wide range of custom variables are available for mixing derived
-data as macros into the plain text of a template.
-
-In addition, templates can be declared with arguments. These
-arguments represent predetermined sets of dictionary values, such as
-features of the current file name, user name, time, etc.
-
-Some arguments are major-mode specific, such as the @code{:el} or
-@code{:cpp} arguments.
-
-@section Template Insertion Context
-A context can be provided for templates in a file. This helps
-auto-selection of templates by name, or allows templates in different
-contexts to have the same name. Some standard contexts are
-@code{file}, @code{declaration}, and @code{classdecl}.
-
-A context can be automatically derived as well based on the parsing
-state from @i{Semantic}. @xref{Top, Semantic Manual,, semantic}.
-
-@section Applications
-Commands that do a particular user task which involves also writing
-Emacs Lisp code. Applications are at the top layer. These
-applications have their own template files and logic needed to fill in
-dictionaries or position a cursor. SRecode comes with an example
-@code{srecode-document} application for creating comments for Semantic
-tags. The CEDET application @i{EDE} has a project type that is an
-@srecode{} application.
-
-@section Field Editing
-If the variable @code{srecode-insert-ask-variable-method} is set to
-'field, then variables that would normally ask a question, will
-instead create ``fields'' in the buffer. A field-editing layer
-provides simple interaction through the fields. Typing in a field
-will cause all variable locations that are the same to edit at the
-same time. Pressing @kbd{@key{TAB}} on a field will move you to the
-next field.
-
-@node SRecode Minor Mode
-@chapter SRecode Minor Mode
-
-The Semantic Recode minor mode enables a keymap and menu that provides
-simple access to different templates or template applications.
-
-The key prefix is @kbd{C-c /}.
-
-If the variable @code{srecode-takeover-INS-key} is set, then the key
-@kbd{@key{INSERT}} can also be used.
-
-The most important key is bound to @code{srecode-insert} which is
-@kbd{C-c / /}, or @kbd{@key{INSERT} @key{INSERT}}. @ref{Quick Start}.
-
-Major key bindings are:
-
-@table @kbd
-@item C-c / /
-Insert a template whose name is typed into the minibuffer.
-@item C-c / <lower case letter>
-Reserved for direct binding of simple templates to keys using a
-key binding command in the template file.
-@item C-c / <upper case letter>
-Reserved for template applications (Such as comment or get/set inserter.)
-@item C-c / E
-Edit the code of a template.
-@item C-c / .
-Insert template again. This will cause the previously inserted
-template to be inserted again.
-@end table
-
-@section Field Editing
-
-By default, when inserting a template, if the user needs to enter text
-to fill in a part of the template, then the minibuffer is used to
-query for that information. SRecode also supports a field-editing mode
-that can be used instead. To enable it set:
-
-@defun srecode-insert-ask-variable-method
-@anchor{srecode-insert-ask-variable-method}
-Determine how to ask for a dictionary value when inserting a template.
-Only the @var{ASK} style inserter will query the user for a value.
-Dictionary value references that ask begin with the ? character.
-Possible values are:
-@table @code
-@item ask
-Prompt in the minibuffer as the value is inserted.
-@item field
-Use the dictionary macro name as the inserted value,
-and place a field there. Matched fields change together.
-@end table
-@end defun
-
-Field editing mode is supported in newer versions of Emacs. You
-will not be prompted to fill in values while the template is
-inserted. Instead, short regions will be highlighted, and the cursor
-placed in a field. Typing in the field will then fill in the value.
-Several fields might be linked together. In that case, typing in one
-area will modify the other linked areas. Pressing @key{TAB} will move
-between editable fields in the template.
-
-Once the cursor moves out of the are inserted by the template, all the
-fields are canceled.
-
-@b{NOTE}: Some conveniences in templates, such as completion, or
-character restrictions are lost when using field editing mode.
-
-@node Template Writing
-@chapter Template Writing
-@anchor{@code{SRecode-template-mode}}
-
-@code{srecode-template-mode} is the major mode used for designing new
-templates. @srecode{} files (Extension @file{.srt}) are made up of
-variable settings and template declarations.
-
-Here is an overview of the terminology you will need for the next few
-sections:
-
-@table @asis
-@item template file
-A file with a @file{.srt} extension which contains settings,
-variables, and templates.
-@item template
-One named entity which represents a block of text that will be
-inserted. The text is compiled into a sequence of insertable
-entities. The entities are string constants, and macros.
-@item macro
-A macro is a text sequence within template text that is replaced with
-some other value.
-@item dictionary
-A table of variable names and values.
-@item subdictionary
-A dictionary that is subordinate under another dictionary as a value
-to some variable.
-@item variable
-A variable is an entry in a dictionary which has a value.
-@end table
-
-@menu
-* Variables:: Creating special and regular variables.
-* Templates:: Creating templates
-* Contexts:: Templates are grouped by context
-* Prompts:: Setting prompts for interactive insert macros
-@end menu
-
-@node Variables
-@section Variables
-
-Variables can be set up and used in templates. Many variables you may
-use are set up via template arguments, but some may be preferences a
-user can set up that are used in system templates.
-
-When expanding a template, variables are stored in a @dfn{dictionary}.
-Dictionary entries are variables. Variables defined in templates can
-have string like values.
-
-A variable can be set like this:
-@example
-set VARNAME "some value"
-@end example
-
-Note that a VARIABLE is a name in a dictionary that can be used in a
-MACRO in a template. The macro references some variable by name.
-
-@menu
-* String Values:: Basic Variable values
-* Multi-string Values:: Complex variable values
-* Section Show:: Enabling the display of a named section.
-* Special Variables:: Variables with special names
-* Automatic Loop Variables:: Variables automatically set in section loops.
-* Compound Variable Values:: Compound Variable Values
-@end menu
-
-@node String Values
-@subsection String Values
-
-Variables can be set to strings. Strings may contain newlines or any
-other characters. Strings are interpreted by the Emacs Lisp reader so
-@code{\n}, @code{\t}, and @code{\"} work.
-
-When a string is inserted as part of a template, nothing within the
-string is interpreted, such as template escape characters.
-
-@node Multi-string Values
-@subsection Multi-string Values
-
-A variable can be set to multiple strings. A compound value is
-usually used when you want to use dictionary entries as part of a
-variable later on.
-
-Multi-string variable values are set like string values except there
-are more than one. For example
-
-@example
-set NAME "this" "-mode"
-@end example
-
-These two strings will be concatenated together.
-
-A more useful thing is to include dictionary variables and concatenate
-those into the string. Use the ``macro'' keyword to include the name
-of a variable. This is like macros in a template. For example:
-
-@example
-set NAME macro "MODE" "-mode"
-@end example
-
-will extract the value of the dictionary variable MODE and append
-``-mode'' to the end.
-
-@node Section Show
-@subsection Section Show
-
-To set a variable to show a template section, use the @code{show}
-command. Sections are blocks of a template wrapped in section macros.
-If there is a section macro using @var{NAME} it will be shown for each
-dictionary associated with the @var{NAME} macro.
-
-@example
-show NAME
-@end example
-
-This will enable that section.
-
-
-NOTE: May 11, 2008: I haven't used this yet, so I don't know if it works.
-
-
-@node Special Variables
-@subsection Special Variables
-
-Some variables have special meaning that changes attributes when
-templates are compiled, including:
-
-@table @code
-@item escape-start
-This is the character sequence that escapes from raw text to template
-macro names. The ability to change the escape characters are key for
-enabling @srecode{} templates to work across many kinds of languages.
-@item escape-end
-This is the character sequence that escapes the end of a template
-macro name.
-
-Example:
-@example
-set escape_start "$"
-set escape_end "$"
-@end example
-@item mode
-This is the major mode, as a string with the full Emacs Lisp symbol in
-it. All templates in this file will be installed into the template
-table for this major mode.
-
-Multiple template files can use the same mode, and all those templates
-will be available in buffers of that mode.
-
-Example:
-@example
-set mode "emacs-lisp-mode"
-@end example
-
-@item priority
-The priority of a file is a number in a string constant that
-indicates where it lies in the template search order. System
-templates default to low priority numbers. User templates default to
-high priority numbers. You can specify the priority of your template
-to insert it anywhere in the template search list.
-
-If there are multiple templates with the same context and name, the
-template with the highest priority number will be used.
-
-If multiple files have the same priority, then the sort order is
-unpredictable. If no template names match, then it doesn't matter.
-
-Example:
-@example
-set priority "35"
-@end example
-
-@item application
-If a template file contains templates only needed for a particular
-application, then specify an application. Template files for an
-application are stored in the template repository, but are not used in
-the generic template insertion case.
-
-The application with a particular name will access these templates
-from Lisp code.
-
-Example:
-@example
-set application "document"
-@end example
-
-@item project
-If a template file contains templates, or template overrides specific
-to a set of files under a particular directory, then that template
-file can specify a ``project'' that it belongs to.
-
-Set the ``project'' special variable to a directory name. Only files
-under that directory will be able to access the templates in that
-file.
-
-Any template file that has a project specified will get have a
-priority that is set between SRecode base templates, and user defined
-templates.
-
-Templates can be compiled via a project system, such as EDE@. EDE
-loaded templates will get a @var{project} set automatically.
-
-Example:
-@example
-set project "/tmp/testproject"
-@end example
-
-@end table
-
-If you need to insert the characters that belong to the variables
-@code{escape_start} or @code{escape_end}, then place those into
-a variable. For example
-
-@example
-set escape_start "$"
-set escape_end "$"
-set DOLLAR "$"
-@end example
-
-@node Automatic Loop Variables
-@subsection Automatic Loop Variables
-
-When section macros are used, that section is repeated for each
-subdictionary bound to the loop variable.
-
-Each dictionary added will automatically get values for positional
-macros which will enable different @var{sections}. The automatic
-section variables are.
-
-@itemize @bullet
-@item @var{first}---The first entry in the table.
-@item @var{notfirst}---Not the first entry in the table.
-@item @var{last}---The last entry in the table
-@item @var{notlast}---Not the last entry in the table.
-@end itemize
-
-@node Compound Variable Values
-@subsection Compound Variable Values
-
-A variable can also have a compound value. This means the value of
-the variable is an @EIEIO{} object, which is a subclass of
-@code{srecode-dictionary-compound-value}.
-
-New compound variables can only be setup from Lisp code. See
-@ref{Compound Dictionary Values} for details on setting up compound
-variables from Lisp.
-
-@node Templates
-@section Templates
-
-A template represents a text pattern that can be inserted into
-a buffer.
-
-A basic template is declared like this:
-
-@example
-template TEMPLATENAME :arg1 :arg2
-"Optional documentation string"
-----
-The text to your template goes here.
-----
-bind "a"
-@end example
-
-Templates are stored in a template table by name, and are inserted by
-the @var{templatename} provided.
-
-The documentation string is optional. This documentation string will
-be used to aid users in selecting which template they want to use.
-
-The code that makes up the raw template occurs between the lines that
-contain the text "-----".
-
-@menu
-* Template Section Dictionaries:: Template Scoped Macro values
-* Template Macros:: Macros occurring in template patterns
-@end menu
-
-@node Template Section Dictionaries
-@subsection Template Section Dictionaries
-
-To add variable values to section dictionaries used within a specific
-template, you can add them to the beginning of the template
-declaration like this:
-
-@example
-template TEMPLATENAME :arg1 :arg2
-"Optional documentation string"
-sectiondictionary "A"
-set NAME "foo"
-----
-A beginning line @{@{NAME@}@}
-@{@{#A@}@}Optional string @{@{NAME@}@} here@{@{/A@}@}
-An end line
-----
-@end example
-
-In this example, the @var{NAME} variable gets the value ``foo'', but
-only while it is inside section macro A@. The outer scoped NAME will
-be empty.
-
-This is particularly useful while using an include macro to pull in a
-second template. In this way, you can pass values known from one
-template to a subordinate template where some value is not known.
-
-From the Emacs Lisp default template file, a syntax table is just a
-variable with a specialized value.
-
-If a variable is declared like this (where $ is the escape character):
-
-@example
-template variable :el
-"Insert a variable.
-DOC is optional."
-----
-(defvar $?NAME$ $^$
- "$DOC$")
-----
-@end example
-
-then you can see that there is a NAME and DOC that is needed.
-The @code{^} point inserter is also a handy key here.
-
-The syntax table wants a variable, but knows the values of some of
-these variables, and can recast the problem like this by using
-template specific @code{sectiondictionary} macro declarations.
-
-@example
-template syntax-table
-"Create a syntax table."
-sectiondictionary "A"
-set NAME macro "?MODESYM" "-mode-syntax-table"
-set DOC "Syntax table used in " macro "?MODESYM" " buffers."
-----
-$<A:variable$
- (let ((table (make-syntax-table (standard-syntax-table))))
- (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
- ;; ...
- table)
-$/A$
-----
-@end example
-
-In this way, @var{NAME} can be set as a user posed question for
-@var{MODESYM} with ``-mode-syntax-table'' appended. A simplified doc
-string will also be inserted.
-
-Lastly, the @var{A} section contains more macro text which is inserted
-at the @code{^} point marker.
-
-By creating useful base templates for things like function or variable
-declarations, and recycling them in higher-order templates, an end
-user can override the basic declarator, and the higher order templates
-will then obey the new format, or perhaps even work in more than one
-major mode.
-
-@node Template Macros
-@subsection Template Macros
-
-Template macros occur in the template text. The default escape
-characters are ``@{@{`` and ``@}@}'', though they can be changed
-in the top-level variables. See @ref{Variables}.
-
-Thus, if you have the template code that looks like this:
-
-@example
-;; Author: @{@{AUTHOR@}@}
-@end example
-
-Then the text between @{@{ and @}@} are a macro, and substituted by
-the value of the variable @var{AUTHOR}.
-
-Macros can be specialized to be more than just a text string. For
-example, the macro above could be augmented with an Emacs Lisp
-function.
-
-@example
-;; Author: @{@{AUTHOR:upcase@}@}
-@end example
-
-In this case, the Emacs Lisp function @code{upcase} will be called on
-the text value of the @var{AUTHOR} variable.
-
-Macros can also be specialized to have different behaviors by using a
-prefix, non-alpha character or symbol. For example:
-
-@example
-@{@{! This is a comment inside macro escape characters @}@}
-@end example
-
-shows that the ``!'' symbol is for comments.
-
-Alternately, a macro could query the user during insertion:
-
-@example
-(defun @{@{?NAME@}@} ()
- @{@{^@}@}
- ) ;; End of @{@{NAME@}@}
-@end example
-
-the ``?'' symbol indicates that if the symbol @var{NAME} isn't in the
-dictionary, then the user should be queried for the @var{NAME}
-variable. If @var{NAME} appears again in the template, the original
-value specified by the user will be inserted again.
-
-If the text from a dictionary value is to be placed in column format,
-you can use the ``|'' symbol to indicate you want column control. For
-example:
-
-@example
- | this | that |@{@{#A@}@}
- | @{@{|THIS:4@}@} | @{@{|THAT:4@}@} |@{@{/A@}@}
-@end example
-
-For each repeated section ``#A'' the dictionary values for @var{THIS}
-and @var{THAT} will be inserted and either trimmed to, or expanded to
-4 characters in width.
-
-Macros that are prefixed with the ``#'' symbol denote a section. A
-macro of the same name with a ``/'' prefix denotes the end of that
-section.
-
-@example
-@{@{#MOOSE@}@}
-Here is some text describing moose.
-@{@{/MOOSE@}@}
-@end example
-
-In this example if the section MOOSE was ``shown'' in the active
-dictionary, then the text between the # and / macros will also be
-inserted.
-
-All the text and macros within a section are either not shown at all
-(if that section is not 'visible') or the section is shown one time
-for each dictionary added to that symbol.
-@xref{Developing Template Functions}.
-
-Macros prefixed with ``>'' will include another template. Include
-macros would look like this:
-
-@example
-@{@{>FOO:defun@}@}
-@end example
-
-where @code{FOO} is the dictionary variable for the sub-dictionary used for
-expanding the template @code{defun}. The @code{defun} template will
-be looked up in the template repository for the current mode, or in
-any inherited modes.
-
-Another way to include another template is with an include macro that
-will also wrap section text. The includewrap insertion method looks
-like this:
-
-@example
-@{@{<FOO:defun@}@}Handy Text goes here@{@{/FOO@}@}
-@end example
-
-In this case, @code{defun} is included just as above. If the
-@code{defun} template has a @{@{^@}@} macro in it, then the
-section text ``Handy Text goes here'' will be inserted at that point,
-and that location will not be saved as the cursor location.
-
-If there is no @{@{^@}@}, then the text will not be inserted.
-
-For both kinds of include macros, you may need to include a template
-from a different context. You can use @code{:} separate the context
-from the name, like this:
-
-@example
-@{@{>FOO:declaration:function@}@}
-@end example
-
-@node Contexts
-@section Context
-
-Each template belongs to a context. When prompting for a template by
-name, such as with @kbd{C-c / /}, the name is prefixed by the current
-context. If there is no context, it defaults to @code{declaration}.
-
-You can change context like this:
-
-@example
-context NAME
-@end example
-
-where @var{name} is some symbol that represents any context.
-
-A context resides over all templates that come after it until the next
-context statement. Thus:
-
-@example
-context C1
-
-template foo
-"Foo template in C1"
-----
-----
-
-context C2
-
-template foo
-"Foo template in C2"
-----
-----
-@end example
-
-creates two @code{foo} templates. The first one is when in context
-C1. The second is available in context C2.
-
-This is useful if there are multiple ways to declare something like a
-function or variable that differ only by where it is in the syntax of
-the language. The name @code{foo} is not ambiguous because each is in
-a different context.
-
-@node Prompts
-@section Prompt
-
-Some templates use prompting macro insertion. A macro that needs a
-prompt looks like this:
-
-@example
-@{@{?NAME@}@}
-@end example
-
-where ? comes after the first escape character.
-
-by default, it will use a prompt like this when it is encountered:
-
-@example
-Specify NAME:
-@end example
-
-For such macros, you can pre-define prompts for any dictionary entry.
-When that dictionary entry is first encountered, the user is prompted,
-and subsequent occurrences of that dictionary entry use the same value.
-
-To get a different prompt, use a prompt command like this:
-
-@example
-prompt VARNAME "Nice Way to ask for VARNAME: "
-@end example
-
-Now, if you put this in a template:
-
-@example
-template variable
-----
-(defvar @{@{?VARNAME@}@} nil
- "")
-----
-@end example
-
-when VARNAME is encountered, it will use the nice prompt.
-
-Prompts can be extended as well. For example:
-
-@example
-prompt VARNAME "VARNAME: " default "srecode" read y-or-n-p
-@end example
-
-In this case, the @code{default} keyword indicates that
-@code{"srecode"} is the default string to use, and @code{y-or-n-p} is
-the function to use to ask the question.
-
-For @code{y-or-n-p} if you type ``y'' it inserts the default string,
-otherwise it inserts empty.
-
-For any other symbol that occurs after the @code{read} token, it is
-expected to take the same argument list as @code{read-string}. As
-such, you can create your own prompts that do completing reads on
-deterministic values.
-
-To have the default be calculated later from a dictionary entry, you
-need to use the @code{defaultmacro} keyword instead.
-
-@example
-prompt VARNAME "Varname: " defaultmacro "PREFIX"
-@end example
-
-now, when it attempts to read in VARNAME, it will pre-populate the text
-editing section with whatever the value of PREFIX is.
-
-Some language arguments may supply possible prefixes for prompts.
-Look for these when creating your prompts.
-
-@node Dictionaries
-@chapter Dictionaries
-
-Dictionaries are a set of variables. The values associated with the
-variable names could be anything, but how it is handled is dependent
-on the type of macro being inserted.
-
-Most of this chapter is for writing Lisp programs that use @srecode{}.
-If you only want to write template files, then you only need to read
-the @ref{Template Argument Dictionary Entries} section.
-
-@menu
-* Create a Dictionary::
-* Setting Dictionary Values:: Basic dictionary values
-* Compound Dictionary Values:: Complex dictionary values
-* Argument Resolution:: Automatic template argument resolution
-* Creating new Arguments:: Create new arguments for use in templates
-* Querying a Dictionary:: Querying a dictionary for values.
-* Template Argument Dictionary Entries:: Catalog of arguments
-@end menu
-
-@node Create a Dictionary
-@section Create a Dictionary
-
-@defun srecode-create-dictionary &optional buffer
-@anchor{srecode-create-dictionary}
-Create a dictionary for @var{buffer}.
-If @var{buffer} is not specified, use the current buffer.
-The dictionary is initialized with no variables or enabled sections.
-Any variables defined with @code{set} in the template, however,
-becomes a name in the dictionary.
-@end defun
-
-@node Setting Dictionary Values
-@section Setting Dictionary Values
-
-When building an @srecode{} based application, you will need to setup
-your dictionary values yourself. There are several utility functions
-for this.
-
-In the simplest form, you can associate a string with a variable.
-
-@defun srecode-dictionary-set-value dict name value
-@anchor{srecode-dictionary-set-value}
-In dictionary @var{dict}, set @var{name} to have @var{value}.
-@end defun
-
-For section macros, you can have alternate values. A section can
-either be toggled as visible, or it can act as a loop.
-
-@defun srecode-dictionary-show-section dict name
-@anchor{srecode-dictionary-show-section}
-In dictionary @var{dict}, indicate that the section @var{name} should be exposed.
-@end defun
-
-
-@defun srecode-dictionary-add-section-dictionary dict name show-only
-@anchor{srecode-dictionary-add-section-dictionary}
-In dictionary @var{DICT}, add a section dictionary for section macro @var{NAME}.
-Return the new dictionary.
-
-You can add several dictionaries to the same section entry.
-For each dictionary added to a variable, the block of codes in
-the template will be repeated.
-
-If optional argument @var{SHOW-ONLY} is non-@code{nil}, then don't add
-a new dictionary if there is already one in place. Also, don't add
-@var{FIRST}/@var{LAST} entries.
-These entries are not needed when we are just showing a section.
-
-Each dictionary added will automatically get values for positional macros
-which will enable @var{SECTIONS} to be enabled.
-
-@table @var
-@item first
-The first entry in the table.
-@item notfirst
-Not the first entry in the table.
-@item last
-The last entry in the table
-@item notlast
-Not the last entry in the table.
-@end table
-
-Adding a new dictionary will alter these values in previously
-inserted dictionaries.
-@end defun
-
-@node Compound Dictionary Values
-@section Compound Dictionary Values
-
-If you want to associate a non-string value with a dictionary
-variable, then you will need to use a compound value. Compound
-dictionary values are derived using @EIEIO{} from a base class for
-handling arbitrary data in a macro.
-
-@deffn Type srecode-dictionary-compound-value
-@anchor{srecode-dictionary-compound-value}
-A compound dictionary value.
-Values stored in a dictionary must be a @var{string},
-a dictionary for showing sections, or an instance of a subclass
-of this class.
-
-Compound dictionary values derive from this class, and must
-provide a sequence of method implementations to convert into
-a string.
-@end deffn
-
-Your new subclass of the compound value needs to implement these
-methods:
-
-@defun srecode-compound-toString cp function dictionary
-@anchor{srecode-compound-toString}
-Convert the compound dictionary value @var{cp} to a string.
-If @var{function} is non-@code{nil}, then @var{function} is somehow applied to an aspect
-of the compound value. The @var{function} could be a fraction
-of some function symbol with a logical prefix excluded.
-@end defun
-
-The next method is for dumping out tables during debugging.
-
-@defun srecode-dump cp &optional indent
-@anchor{srecode-dump}
-Display information about this compound value.
-@end defun
-
-
-Here is an example of wrapping a semantic tag in a compound value:
-
-@example
-(defclass srecode-semantic-tag (srecode-dictionary-compound-value)
- ((prime :initarg :prime
- :type semantic-tag
- :documentation
- "This is the primary insertion tag.")
- )
- "Wrap up a collection of semantic tag information.
-This class will be used to derive dictionary values.")
-
-(cl-defmethod srecode-compound-toString ((cp srecode-semantic-tag)
- function
- dictionary)
- "Convert the compound dictionary value CP to a string.
-If FUNCTION is non-nil, then FUNCTION is somehow applied to an
-aspect of the compound value."
- (if (not function)
- ;; Just format it in some handy dandy way.
- (semantic-format-tag-prototype (oref cp :prime))
- ;; Otherwise, apply the function to the tag itself.
- (funcall function (oref cp :prime))
- ))
-@end example
-
-@node Argument Resolution
-@section Argument Resolution
-
-Some dictionary entries can be set via template arguments in the
-template declaration. For examples of template arguments, see
-@ref{Template Argument Dictionary Entries}.
-
- You can resolve an argument list into a dictionary with:
-
-@defun srecode-resolve-arguments temp dict
-@anchor{srecode-resolve-arguments}
-Resolve all the arguments needed by the template @var{temp}.
-Apply anything learned to the dictionary @var{dict}.
-@end defun
-
-@node Creating new Arguments
-@section Creating new Arguments
-
-You can create new arguments for use in template files by writing new
-Emacs Lisp functions. Doing so is easy. Here is an example for the
-@code{:user} argument:
-
-@example
-(defun srecode-semantic-handle-:user (dict)
- "Add macros into the dictionary DICT based on the current :user."
- (srecode-dictionary-set-value dict "AUTHOR" (user-full-name))
- (srecode-dictionary-set-value dict "LOGIN" (user-login-name))
- ;; ...
- )
-@end example
-
-In this case, a function with the name prefix
-@code{srecode-semantic-handle-} that ends in @code{:user} creates a
-new argument @code{:user} that can be used in a template.
-
-Your argument handler must take one argument @var{dict}, which is the
-dictionary to fill in. Inside your function, you can do whatever you
-want, but adding dictionary values is the right thing.
-
-@node Querying a Dictionary
-@section Querying a Dictionary
-
-When creating a new argument, it may be useful to ask the dictionary
-what entries are already set there, and conditionally create new
-entries based on those.
-
-In this way, a template author can get additional logic through more
-advanced arguments.
-
-@defun srecode-dictionary-lookup-name dict name
-@anchor{srecode-dictionary-lookup-name}
-Return information about the current @var{DICT}'s value for @var{NAME}.
-@var{DICT} is a dictionary, and @var{NAME} is a string that is the name of
-a symbol in the dictionary.
-This function derives values for some special NAMEs, such as @var{FIRST}
-and '@var{LAST}'.
-@end defun
-
-
-
-@node Template Argument Dictionary Entries
-@section Template Argument Dictionary Entries
-
-When a dictionary is initialized for a template, then the dictionary
-will be initialized with a predefined set of macro values.
-
-A template of the form:
-
-@example
-template template-name :arg1 :arg2
-----
-Your template goes here
-----
-@end example
-
-specifies two arguments :arg1, and :arg2.
-
-The following built-in simple arguments are available:
-
-@menu
-* Base Arguments::
-* Semantic Arguments::
-* Language Arguments::
-@end menu
-
-@node Base Arguments
-@subsection Base Arguments
-
-@subsubsection Argument :indent
-
-Supplies the @code{INDENT} macro. When @code{INDENT} is non-@code{nil}, then
-each line is individually indented with
-@code{indent-according-to-mode} during macro processing.
-
-@subsubsection Argument :blank
-
-Specifying this argument adds a special @code{:blank} handler at the
-beginning and end of the template. This handler will insert @code{\n}
-if the insertion point is not on a line by itself.
-
-@subsubsection Argument :region
-
-If there is an active region via @code{transient-mark-mode}, or
-@code{mouse-drag-region}, then the @code{REGION} section will be
-enabled.
-
-In addition, @code{REGIONTEXT} will be set to the text in the region,
-and that region of text will be ``killed'' from the current buffer.
-
-If standard-output is NOT the current buffer, then the region will not
-be deleted. In this way, you can safely use @code{:region} using
-templates in arbitrary output streams.
-
-@subsubsection Argument :user
-
-Sets up variables about the current user.
-
-@table @code
-@item AUTHOR
-Value of the Emacs function @code{user-full-name}
-@item EMAIL
-Current Emacs user's email address.
-@item LOGIN
-Current Emacs user's login name.
-@item UID
-Current Emacs user's login ID.
-@item EMACSINITFILE
-This Emacs sessions' init file.
-@end table
-
-@subsubsection Argument :time
-
-Sets up variables with the current date and time.
-
-@table @code
-@item YEAR
-The current year.
-@item MONTH
-The current month as a number.
-@item MONTHNAME
-The current month name, unabbreviated.
-@item DAY
-The current day as a number.
-@item WEEKDAY
-The current day of the week as an abbreviated name
-@item HOUR
-The current hour in 24 hour format.
-@item HOUR12
-The current hour in 12 hour format.
-@item AMPM
-Locale equivalent of AM or PM@. Useful with HOUR12.
-@item MINUTE
-The current minute.
-@item SECOND
-The current second.
-@item TIMEZONE
-The timezone string.
-@item DATE
-The Locale supported date (%D).
-@item TIME
-The Locale supported time format (%X).
-@end table
-
-@subsubsection Argument :file
-
-Sets up variables with details about the current file.
-
-@table @code
-@item FILENAME
-The filename without the directory part of the current buffer.
-@item FILE
-The filename without the directory or extension
-@item EXTENSION
-The filename extension.
-@item DIRECTORY
-The directory in which the current buffer resides.
-@item MODE
-Major mode of this buffer.
-@item SHORTMODE
-Major mode of this buffer without ``-mode''.
-Useful for inserting the Emacs mode specifier.
-@item section RCS
-Show the section RCS if there is a CVS or RCS directory here.
-@end table
-
-@subsubsection Argument :system
-
-Sets up variables with computer system information.
-
-@table @code
-@item SYSTEMCONF
-The ``system-configuration''.
-@item SYSTEMTYPE
-The ``system-type''.
-@item SYSTEMNAME
-The ``system-name''.
-@item MAILHOST
-The name of the machine Emacs derived mail ``comes from''.
-@end table
-
-@subsubsection Argument :kill
-
-@table @code
-@item KILL
-The top-most item from the kill ring.
-@item KILL2
-The second item in the kill ring.
-@item KILL3
-The third item in the kill ring.
-@item KILL4
-The fourth item in the kill ring.
-@end table
-
-@node Semantic Arguments
-@subsection Semantic Arguments
-
-@subsubsection Argument :tag
-
-The :tag argument is filled in with information from Semantic.
-The tag in question is queried from the senator tag ring, or passed
-in from @srecode{} utilities that use tags in templates.
-
-@table @code
-@item TAG
-This is a compound value for the tag in the current senator kill ring,
-or something handled via the variable
-@code{srecode-semantic-selected-tag}.
-
-@defvar srecode-semantic-selected-tag
-@anchor{srecode-semantic-selected-tag}
-The tag selected by a @code{:tag} template argument.
-If this is @code{nil}, then @code{senator-tag-ring} is used.
-@end defvar
-
-Use the function part of a macro insert to extract obscure parts
-of the tag.
-@item NAME
-The name of the tag as a string.
-@item TYPE
-The data type of the tag as a string.
-@end table
-
-If @var{tag} is a function, you will get these additional dictionary
-entries.
-
-@table @code
-@item ARGS
-A Loop macro value. Each argument is inserted in ARGS@. To create a
-comma separated list of arguments, you might do this:
-
-@example
-@{@{#ARGS@}@}@{@{TYPE@}@} @{@{NAME@}@}@{@{#NOTLAST@}@},@{@{/NOTLAST@}@}@{@{/ARGS@}@}
-@end example
-
-Within the section dictionaries for each argument, you will find both
-@var{NAME} and @var{TYPE}, in addition to the automatic section values
-for @var{FIRST}, @var{LAST}, @var{NOTFIRST}, and @var{NOTLAST}.
-@item PARENT
-The string name of the parent of this function, if the function is a
-method of some class.
-@item THROWS
-In each @var{THROWS} entry, the @var{NAME} of the signal thrown is specified.
-@end table
-
-If @var{tag} is a variable, you will get these dictionary entries.
-
-@table @code
-@item DEFAULTVALUE
-Enabled if there is a @var{VALUE}.
-@item VALUE
-An entry in the @var{HAVEDEFAULT} subdictionary that represents the
-textual representation of the default value of this variable.
-@end table
-
-If @var{tag} is a datatype, you will get these dictionary entries.
-
-@table @code
-@item PARENTS
-Section dictionaries for the parents of this class. Each parent will
-have a @var{NAME}.
-@item INTERFACES
-Section dictionaries for all the implemented interfaces of this
-class. Each interface will have a @var{NAME}.
-@end table
-
-Note that data type templates should always have a @code{@{@{^@}@}}
-macro in it where the core contents of that type will go. This is why
-data types don't have subdictionaries full of the slots in the classes
-or structs.
-
-@node Language Arguments
-@subsection language Arguments
-
-Each language typically has its own argument. These arguments can be
-used to fill in language specific values that will be useful.
-
-@subsubsection Argument :srt
-
-Used for SRecoder template files.
-
-@table @code
-@item ESCAPE_START
-The characters used for an escape start
-@item ESCAPE_END
-The characters used for an escape end
-@end table
-
-@subsubsection Argument :cpp
-
-@table @code
-@item HEADER
-Shows this section if the current file is a header file.
-@item NOTHEADER
-The opposite of @code{HEADER}.
-@item FILENAME_SYMBOL
-The current filename reformatted as a C friendly symbol.
-@end table
-
-@subsection Argument :java
-
-@table @code
-@item FILENAME_AS_PACKAGE
-Converts the filename into text that would be suitable as a package
-name.
-@item FILENAME_AS_CLASS
-Converts the filename into text that would be suitable as a class-name
-for the main class in the file.
-@item CURRENT_PACKAGE
-Finds the occurrence of ``package'' and gets its value.
-@end table
-
-@subsubsection Argument :el
-
-Sets @code{PRENAME}. This would be a common prefix from all the
-tags in the current buffer.
-
-Most Emacs Lisp packages have some common prefix used in a way similar
-to namespaces in other languages.
-
-@subsubsection Argument :el-custom
-
-@table @code
-@item GROUP
-The name of the Emacs Custom group that instances of @code{defcustom}
-ought to use.
-@item FACEGROUP
-The name of the Emacs Custom group that faces declared with
-@code{defface} ought to use.
-@end table
-
-@subsubsection Argument :texi
-
-@table @code
-@item LEVEL
-The current section level, such as @code{chapter} or @code{section}.
-@item NEXTLEVEL
-The next level down, so if @code{LEVEL} is @code{chapter}, then
-@code{NEXTLEVEL} would be @code{section}.
-@end table
-
-@subsubsection Argument :texitag
-
-The @code{:texitag} argument is like the @code{:tag} argument, except that
-additional variable @code{TAGDOC} is provided for each tag.
-
-The @code{TAGDOC} is filled with derived documentation from the tag in
-question, and that documentation is also reformatted to be mostly
-texinfo compatible.
-
-@subsection Argument :android
-
-The @code{:android} argument pulls in information from your current
-project.
-
-@@TODO - add more here.
-
-@node Developing Template Functions
-@chapter Developing Template Functions
-
-You can develop your own custom template insertion functions.
-Doing so is relatively simple, and requires that you write an Emacs
-Lisp command.
-
-If the built in commands don't provide enough options, you will need
-to write your own function in order to provide your dictionaries with
-the values needed for custom templates.
-
-In this way, you can build your own code generator for any language
-based on a set of predefined macros whose values you need to derive
-from Emacs Lisp code yourself.
-
-For example:
-
-@example
-(defun my-srecode-insert (template-name)
- "Insert the template TEMPLATE-NAME into the current buffer at point."
-
- ;; Read in a template name.
- (interactive (list (srecode-read-template-name "Template Name: ")))
- (if (not (srecode-table))
- (error "No template table found for mode %s" major-mode))
- (let ((temp (srecode-template-get-table (srecode-table) template-name))
-
- ;; Create a new dictionary
- (newdict (srecode-create-dictionary)))
-
- (if (not temp)
- (error "No Template named %s" template-name))
-
- ;; Add some values into the dictionary!
- (srecode-dictionary-set-value newdict "FOO" (my-get-value-of-foo))
- ;; Optionally show a section
- (srecode-dictionary-show-section newdict "BLARG")
-
- ;; Add in several items over a loop
- (let ((my-stuff (get-my-stuff-list)))
- (while my-stuff
- (let ((subdict (srecode-dictionary-add-section-dictionary
- newdict "LOOP")))
- (srecode-dictionary-set-value subdict "NAME" (nth 0 my-stuff))
- (srecode-dictionary-set-value subdict "ARG" (nth 1 my-stuff))
- (srecode-dictionary-set-value subdict "MOOSE" (nth 2 my-stuff))
- )
- (setq my-stuff (cdr my-stuff)))
-
- ;; Some templates have arguments that need to be resolved.
- (srecode-resolve-arguments temp newdict)
-
- ;; Do the expansion
- (srecode-insert-fcn temp newdict)
- ))
-@end example
-
-Lets look at the key functions involved above:
-
-@section Interactive Completion:
-
-@defun srecode-read-template-name prompt
-@anchor{srecode-read-template-name}
-Completing read for Semantic Recoder template names.
-@var{prompt} is used to query for the name of the template desired.
-@end defun
-
-@section Template Lookup
-
-Even if your program does not query the user for a template name, you
-will need to locate a template. First, you need to locate the table
-to look the template up in.
-
-@defun srecode-table &optional mode
-@anchor{srecode-table}
-Return the currently active Semantic Recoder table for this buffer.
-Optional argument @var{MODE} specifies the mode table to use.
-@end defun
-
-
-@defun srecode-template-get-table tab template-name &optional context application
-@anchor{srecode-template-get-table}
-Find in the template in mode table @var{TAB}, the template with @var{TEMPLATE-NAME}.
-Optional argument @var{CONTEXT} specifies a context a particular template
-would belong to.
-Optional argument @var{APPLICATION} restricts searches to only template tables
-belonging to a specific application. If @var{APPLICATION} is @code{nil}, then only
-tables that do not belong to an application will be searched.
-@end defun
-
-For purposes of an @srecode{} application, it is important to decide
-what to call your application, and use that with this method call.
-
-@section Creating dictionaries
-
-Several dictionary calls are made in this example, including:
-@table @code
-@item srecode-create-dictionary
-@item srecode-dictionary-set-value
-@item srecode-dictionary-show-section
-@item srecode-dictionary-add-section-dictionary
-@end table
-
-These are documented more fully @ref{Dictionaries}.
-
-Also used is @code{srecode-resolve-arguments}. To learn more about
-that, see @ref{Argument Resolution}.
-
-@section Template Insertion Commands
-
-There are several ways to insert a template. It is easiest to just
-start with the main entry point.
-
-@defun srecode-insert-fcn template dictionary &optional stream
-@anchor{srecode-insert-fcn}
-Insert @var{template} using @var{dictionary} into @var{stream}.
-If @var{stream} is @code{nil}, then use the current buffer.
-@end defun
-
-@node Template Naming Conventions
-@chapter Template Naming Conventions
-
-For @srecode{} to work across languages reliably, templates need to
-follow a predictable pattern. For every language of similar nature
-(OO, functional, doc based) if they all provide the same base
-templates, then an application can be written against the base
-templates, and it will work in each of the supported language.
-
-Having consistent templates also makes it easy to use those templates
-from a user perspective during basic interactive insertion via
-@code{srecode-minor-mode}.
-
-
-NOTES ON THIS CHAPTER:
-
-These conventions are being worked on. Check with CEDET-DEVEL mailing
-list if you want to support a language, or write an application and
-provide your opinions on this topic. Any help is appreciated.
-
-
-@section Context: File
-
-Each language should support the @code{file:empty} template. This
-will generally use the default copyright insertion mechanism.
-
-@section Context: Declaration
-
-Functional languages should attempt to support the following:
-
-@table @code
-@item function
-A standalone function. Not a method, external method, or other.
-@item method
-A method belonging to some class declared outside the textual bounds
-of that class' declaration.
-@item variable
-A global variable.
-@item type
-A data type. If the language supports several types of datatypes
-then do not use this, use more specific ones instead.
-@item class
-For OO languages, use this instead of @code{type}.
-@item include
-Include files.
-@end table
-
-For any @semantic{} tag class in your language, you will likely want
-to have a corresponding template.
-
-In order for the @srecode{} function
-@code{srecode-semantic-insert-tag} to work, you can create templates
-similar to those mentioned above, except with @code{-tag} appended to
-the end. This lets a template like @code{function} have user
-conveniences when referencing @code{function-tag}, while also
-allowing the tag inserter to do its job with a simpler template.
-
-@section Context: Classdef
-
-Inside a class definition. These are to be inserted inside the
-textual bounds of a class declaration.
-
-@table @code
-@item function
-This would be a method of the class being inserted into.
-@item constructor
-@itemx destructor
-Like @code{function} but specific to alloc/delete of an object.
-@item variable
-This would be a field of the class being inserted into.
-@end table
-
-@section Context: Code
-
-Inside a body of code, such as a function or method body.
-
- ---no conventions yet.
-
-@section Standard Dictionary Values
-
-For these variables to be useful, standard names should be used.
-These values could be provided directly from a Semantic tag, or by an
-application.
-
-@table @var
-@item NAME
-The name of the declaration being created.
-@item PARENT
-If the item belongs to some parent type, it would be the full name of
-that type, including namespaces.
-@item TYPE
-A datatype name for a variable, or the return value of a function.
-@item DOC
-If there is some documentation associated with the item, then DOC
-should contain the value. (Optional)
-@item ARGS
-The ARGS variable defines a section for 0 or more arguments to a function
-or method. Each entry in ARGS will follow the rest of these naming
-conventions, such as for NAME and TYPE.
-@end table
-
-For templates used by @code{srecode-semantic-insert-tag}, there is
-also the following useful dictionary values.
-
-@table @var
-@item TAG
-A special insertion value TAG@. You can use semantic functions to turn
-the tag into a string.
-@item HAVEDEFAULT
-@itemx DEFAULT
-Default value for a variable.
-@end table
-
-@node Inserting Tag Lists
-@chapter Inserting Tag Lists
-
-Since @srecode{} is the @i{Semantic Recoder}, the ultimate goal for
-@srecode{} is to convert lists of tags, as produced by @semantic{}
-back into code.
-
-A single function provides the interface for programs to do this, but
-it requires any particular language to have provided the correct
-templates to make it work.
-
-@defun srecode-semantic-insert-tag tag &optional style-option point-insert-fcn &rest dict-entries
-@anchor{srecode-semantic-insert-tag}
-Insert @var{tag} into a buffer using srecode templates at point.
-
-Optional @var{style-option} is a list of minor configuration of styles,
-such as the symbol @code{'prototype} for prototype functions, or
-@code{'system} for system includes, and @code{'doxygen}, for a doxygen style
-comment.
-
-Optional third argument @var{point-insert-fcn} is a hook that is run after
-@var{tag} is inserted that allows an opportunity to fill in the body of
-some thing. This hook function is called with one argument, the @var{tag}
-being inserted.
-
-The rest of the arguments are @var{dict-entries}. @var{dict-entries}
-is of the form ( @var{name1} @var{value1} @var{name2} @var{value2} @dots{} NAMEn VALUEn).
-
-The exact template used is based on the current context.
-The template used is found within the toplevel context as calculated
-by @dfn{srecode-calculate-context}, such as @code{declaration}, @code{classdecl},
-or @code{code}.
-
-For various conditions, this function looks for a template with
-the name @var{class}-tag, where @var{class} is the tag class. If it cannot
-find that, it will look for that template in the
-@code{declaration}context (if the current context was not @code{declaration}).
-
-If @var{prototype} is specified, it will first look for templates with
-the name @var{class}-tag-prototype, or @var{class}-prototype as above.
-
-See @dfn{srecode-semantic-apply-tag-to-dict} for details on what is in
-the dictionary when the templates are called.
-
-This function returns to location in the buffer where the
-inserted tag @var{ends}, and will leave point inside the inserted
-text based on any occurrence of a point-inserter. Templates such
-as @dfn{function} will leave point where code might be inserted.
-@end defun
-
-
-@node Application Writing
-@chapter Application Writing
-
-The main goal of @srecode{} is to provide a strong platform for
-writing code generating applications.
-
-Any templates that are application specific should make an application
-declaration for each template file they use. This prevents those
-templates from being used outside of that application.
-
-For example, add this to a file:
-@example
-set application "getset"
-@end example
-
-In your application Emacs Lisp code, you would then load those
-templates. A typical initialization would look like this:
-
-@example
- (srecode-load-tables-for-mode major-mode)
- (srecode-load-tables-for-mode major-mode 'getset)
-@end example
-
-These two lines will load in the base templates for the major mode,
-and then the application specific templates.
-
-@defun srecode-load-tables-for-mode mmode &optional appname
-@anchor{srecode-load-tables-for-mode}
-Load all the template files for @var{mmode}.
-Templates are found in the SRecode Template Map.
-See @dfn{srecode-get-maps} for more.
-@var{appname} is the name of an application. In this case,
-all template files for that application will be loaded.
-@end defun
-
-
- todo: Add examples. Most core stuff is already described above.
-
-
-@node GNU Free Documentation License
-@appendix GNU Free Documentation License
-@include doclicense.texi
-
-
-@node Index
-@unnumbered Index
-@printindex cp
-
-@iftex
-@contents
-@summarycontents
-@end iftex
-
-@bye
+++ /dev/null
-\input texinfo @c -*-texinfo-*-
-@c %**start of header
-@setfilename ../../info/wisent.info
-@set TITLE Wisent Parser Development
-@set AUTHOR Eric M. Ludlam, David Ponce, and Richard Y. Kim
-@settitle @value{TITLE}
-@include docstyle.texi
-
-@c *************************************************************************
-@c @ Header
-@c *************************************************************************
-
-@c Merge all indexes into a single index for now.
-@c We can always separate them later into two or more as needed.
-@syncodeindex vr cp
-@syncodeindex fn cp
-@syncodeindex ky cp
-@syncodeindex pg cp
-@syncodeindex tp cp
-
-@c @footnotestyle separate
-@c @paragraphindent 2
-@c @@smallbook
-@c %**end of header
-
-@copying
-Copyright @copyright{} 1988--1993, 1995, 1998--2004, 2007, 2012--2024
-Free Software Foundation, Inc.
-
-@c Since we are both GNU manuals, we do not need to ack each other here.
-@ignore
-Some texts are borrowed or adapted from the manual of Bison version
-1.35. The text in section entitled ``Understanding the automaton'' is
-adapted from the section ``Understanding Your Parser'' in the manual
-of Bison version 1.49.
-@end ignore
-
-@quotation
-Permission is granted to copy, distribute and/or modify this document
-under the terms of the GNU Free Documentation License, Version 1.3 or
-any later version published by the Free Software Foundation; with no
-Invariant Sections, with the Front-Cover Texts being ``A GNU Manual,''
-and with the Back-Cover Texts as in (a) below. A copy of the license
-is included in the section entitled ``GNU Free Documentation License''.
-
-(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and
-modify this GNU manual.''
-@end quotation
-@end copying
-
-@dircategory Emacs misc features
-@direntry
-* Wisent: (wisent). Semantic Wisent parser development.
-@end direntry
-
-@iftex
-@finalout
-@end iftex
-
-@c @setchapternewpage odd
-@c @setchapternewpage off
-
-@titlepage
-@sp 10
-@title @value{TITLE}
-@author by @value{AUTHOR}
-@page
-@vskip 0pt plus 1 fill
-@insertcopying
-@end titlepage
-@page
-
-@macro semantic{}
-@i{Semantic}
-@end macro
-
-@c *************************************************************************
-@c @ Document
-@c *************************************************************************
-@contents
-
-@node top
-@top @value{TITLE}
-
-Wisent (the European Bison ;-) is an Emacs Lisp implementation of the
-GNU Compiler Compiler Bison.
-
-This manual describes how to use Wisent to develop grammars for
-programming languages, and how to use grammars to parse language
-source in Emacs buffers.
-
-It also describes how Wisent is used with the @semantic{} tool set
-described in the @ref{Top, Semantic Manual, Semantic Manual, semantic}.
-
-@ifnottex
-@insertcopying
-@end ifnottex
-
-@menu
-* Wisent Overview::
-* Wisent Grammar::
-* Wisent Parsing::
-* Wisent Semantic::
-* GNU Free Documentation License::
-* Index::
-@end menu
-
-@node Wisent Overview
-@chapter Wisent Overview
-
-@dfn{Wisent} (the European Bison) is an implementation in Emacs Lisp
-of the GNU Compiler Compiler Bison. Its code is a port of the C code
-of GNU Bison 1.28 & 1.31.
-
-For more details on the basic concepts for understanding Wisent, it is
-worthwhile to read the @ref{Top, Bison Manual, , bison}.
-
-Wisent can generate compilers compatible with the @semantic{} tool set.
-See the @ref{Top, Semantic Manual, , semantic}.
-
-It benefits from these Bison features:
-
-@itemize @bullet
-@item
-It uses a fast but not so space-efficient encoding for the parse
-tables, described in Corbett's PhD thesis from Berkeley:
-@quotation
-@cite{Static Semantics in Compiler Error Recovery}@*
-June 1985, Report No. UCB/CSD 85/251.
-@end quotation
-
-@item
-For generating the lookahead sets, Wisent uses the well-known
-technique of F. DeRemer and T. Pennello described in:
-@quotation
-@cite{Efficient Computation of LALR(1) Look-Ahead Sets}@*
-October 1982, ACM TOPLAS Vol 4 No 4, 615--49,
-@uref{https://doi.org/10.1145/69622.357187}.
-@end quotation
-
-@item
-Wisent resolves shift/reduce conflicts using operator precedence and
-associativity.
-
-@item
-Parser error recovery is accomplished using rules which match the
-special token @code{error}.
-@end itemize
-
-Nevertheless there are some fundamental differences between Bison and
-Wisent.
-
-@itemize
-@item
-Wisent is intended to be used in Emacs. It reads and produces Emacs
-Lisp data structures. All the additional code used in grammars is
-Emacs Lisp code.
-
-@item
-Contrary to Bison, Wisent does not generate a parser which combines
-Emacs Lisp code and grammar constructs. They exist separately.
-Wisent reads the grammar from a Lisp data structure and then generates
-grammar constructs as tables. Afterward, the derived tables can be
-included and byte-compiled in separate Emacs Lisp files, and be used
-at a later time by the Wisent's parser engine.
-
-@item
-Wisent allows multiple start nonterminals and allows a call to the
-parsing function to be made for a particular start nonterminal. For
-example, this is particularly useful to parse a region of an Emacs
-buffer. @semantic{} heavily depends on the availability of this feature.
-@end itemize
-
-@node Wisent Grammar
-@chapter Wisent Grammar
-
-@cindex context-free grammar
-@cindex rule
-In order for Wisent to parse a language, it must be described by a
-@dfn{context-free grammar}. That is a grammar specified as rules that
-can be applied regardless of context. For more information, see
-@ref{Language and Grammar, , , bison}, in the Bison manual.
-
-@cindex terminal
-@cindex nonterminal
-The formal grammar is formulated using @dfn{terminal} and
-@dfn{nonterminal} items. Terminals can be Emacs Lisp symbols or
-characters, and nonterminals are symbols only.
-
-@cindex token
-Terminals (also known as @dfn{tokens}) represent the lexical
-elements of the language like numbers, strings, etc..
-
-For example @samp{PLUS} can represent the operator @samp{+}.
-
-Nonterminal symbols are described by rules:
-
-@example
-@group
-RESULT @equiv{} COMPONENTS@dots{}
-@end group
-@end example
-
-@samp{RESULT} is a nonterminal that this rule describes and
-@samp{COMPONENTS} are various terminals and nonterminals that are put
-together by this rule.
-
-For example, this rule:
-
-@example
-@group
-exp @equiv{} exp PLUS exp
-@end group
-@end example
-
-Says that two groupings of type @samp{exp}, with a @samp{PLUS} token
-in between, can be combined into a larger grouping of type @samp{exp}.
-
-@menu
-* Grammar format::
-* Example::
-* Compiling a grammar::
-* Conflicts::
-@end menu
-
-@node Grammar format
-@section Grammar format
-
-@cindex grammar format
-To be acceptable by Wisent a context-free grammar must respect a
-particular format. That is, must be represented as an Emacs Lisp list
-of the form:
-
-@code{(@var{terminals} @var{assocs} . @var{non-terminals})}
-
-@table @var
-@item terminals
-Is the list of terminal symbols used in the grammar.
-
-@cindex associativity
-@item assocs
-Specify the associativity of @var{terminals}. It is @code{nil} when
-there is no associativity defined, or an alist of
-@w{@code{(@var{assoc-type} . @var{assoc-value})}} elements.
-
-@var{assoc-type} must be one of the @code{default-prec},
-@code{nonassoc}, @code{left} or @code{right} symbols. When
-@var{assoc-type} is @code{default-prec}, @var{assoc-value} must be
-@code{nil} or @code{t} (the default). Otherwise it is a list of
-tokens which must have been previously declared in @var{terminals}.
-
-For details, see @ref{Contextual Precedence, , , bison}, in the
-Bison manual.
-
-@item non-terminals
-Is the list of nonterminal definitions. Each definition has the form:
-
-@code{(@var{nonterm} . @var{rules})}
-
-Where @var{nonterm} is the nonterminal symbol defined and
-@var{rules} the list of rules that describe this nonterminal. Each
-rule is a list:
-
-@code{(@var{components} [@var{precedence}] [@var{action}])}
-
-Where:
-
-@table @var
-@item components
-Is a list of various terminals and nonterminals that are put together
-by this rule.
-
-For example,
-
-@example
-@group
-(exp ((exp ?+ exp)) ;; exp: exp '+' exp
- ) ;; ;
-@end group
-@end example
-
-Says that two groupings of type @samp{exp}, with a @samp{+} token in
-between, can be combined into a larger grouping of type @samp{exp}.
-
-@cindex grammar coding conventions
-By convention, a nonterminal symbol should be in lower case, such as
-@samp{exp}, @samp{stmt} or @samp{declaration}. Terminal symbols
-should be upper case to distinguish them from nonterminals: for
-example, @samp{INTEGER}, @samp{IDENTIFIER}, @samp{IF} or
-@samp{RETURN}. A terminal symbol that represents a particular keyword
-in the language is conventionally the same as that keyword converted
-to upper case. The terminal symbol @code{error} is reserved for error
-recovery.
-
-@cindex middle-rule actions
-Scattered among the components can be @dfn{middle-rule} actions.
-Usually only @var{action} is provided (@pxref{action}).
-
-If @var{components} in a rule is @code{nil}, it means that the rule
-can match the empty string. For example, here is how to define a
-comma-separated sequence of zero or more @samp{exp} groupings:
-
-@smallexample
-@group
-(expseq (nil) ;; expseq: ;; empty
- ((expseq1)) ;; | expseq1
- ) ;; ;
-
-(expseq1 ((exp)) ;; expseq1: exp
- ((expseq1 ?, exp)) ;; | expseq1 ',' exp
- ) ;; ;
-@end group
-@end smallexample
-
-@cindex precedence level
-@item precedence
-Assign the rule the precedence of the given terminal item, overriding
-the precedence that would be deduced for it, that is the one of the
-last terminal in it. Notice that only terminals declared in
-@var{assocs} have a precedence level. The altered rule precedence
-then affects how conflicts involving that rule are resolved.
-
-@var{precedence} is an optional vector of one terminal item.
-
-Here is how @var{precedence} solves the problem of unary minus.
-First, declare a precedence for a fictitious terminal symbol named
-@code{UMINUS}. There are no tokens of this type, but the symbol
-serves to stand for its precedence:
-
-@example
-@dots{}
-((default-prec t) ;; This is the default
- (left '+' '-')
- (left '*')
- (left UMINUS))
-@end example
-
-Now the precedence of @code{UMINUS} can be used in specific rules:
-
-@smallexample
-@group
-(exp @dots{} ;; exp: @dots{}
- ((exp ?- exp)) ;; | exp '-' exp
- @dots{} ;; @dots{}
- ((?- exp) [UMINUS]) ;; | '-' exp %prec UMINUS
- @dots{} ;; @dots{}
- ) ;; ;
-@end group
-@end smallexample
-
-If you forget to append @code{[UMINUS]} to the rule for unary minus,
-Wisent silently assumes that minus has its usual precedence. This
-kind of problem can be tricky to debug, since one typically discovers
-the mistake only by testing the code.
-
-Using @code{(default-prec nil)} declaration makes it easier to
-discover this kind of problem systematically. It causes rules that
-lack a @var{precedence} modifier to have no precedence, even if the
-last terminal symbol mentioned in their components has a declared
-precedence.
-
-If @code{(default-prec nil)} is in effect, you must specify
-@var{precedence} for all rules that participate in precedence conflict
-resolution. Then you will see any shift/reduce conflict until you
-tell Wisent how to resolve it, either by changing your grammar or by
-adding an explicit precedence. This will probably add declarations to
-the grammar, but it helps to protect against incorrect rule
-precedences.
-
-The effect of @code{(default-prec nil)} can be reversed by giving
-@code{(default-prec t)}, which is the default.
-
-For more details, see @ref{Contextual Precedence, , , bison}, in the
-Bison manual.
-
-It is important to understand that @var{assocs} declarations defines
-associativity but also assign a precedence level to terminals. All
-terminals declared in the same @code{left}, @code{right} or
-@code{nonassoc} association get the same precedence level. The
-precedence level is increased at each new association.
-
-On the other hand, @var{precedence} explicitly assign the precedence
-level of the given terminal to a rule.
-
-@cindex semantic actions
-@anchor{action}
-@item action
-An action is an optional Emacs Lisp function call, like this:
-
-@code{(identity $1)}
-
-The result of an action determines the semantic value of a rule.
-
-From an implementation standpoint, the function call will be embedded
-in a lambda expression, and several useful local variables will be
-defined:
-
-@table @code
-@vindex $N
-@item $@var{n}
-Where @var{n} is a positive integer. Like in Bison, the value of
-@code{$@var{n}} is the semantic value of the @var{n}th element of
-@var{components}, starting from 1. It can be of any Lisp data
-type.
-
-@vindex $region@var{n}
-@item $regionN
-Where @var{n} is a positive integer. For each @code{$@var{n}}
-variable defined there is a corresponding @code{$region@var{n}}
-variable. Its value is a pair @code{(@var{start-pos} .
-@var{end-pos})} that represent the start and end positions (in the
-lexical input stream) of the @code{$@var{n}} value. It can be
-@code{nil} when the component positions are not available, like for an
-empty string component for example.
-
-@vindex $region
-@item $region
-Its value is the leftmost and rightmost positions of input data
-matched by all @var{components} in the rule. This is a pair
-@code{(@var{leftmost-pos} . @var{rightmost-pos})}. It can be
-@code{nil} when components positions are not available.
-
-@vindex $nterm
-@item $nterm
-This variable is initialized with the nonterminal symbol
-(@var{nonterm}) the rule belongs to. It could be useful to improve
-error reporting or debugging. It is also used to automatically
-provide incremental re-parse entry points for @semantic{} tags
-(@pxref{Wisent Semantic}).
-
-@vindex $action
-@item $action
-The value of @code{$action} is the symbolic name of the current
-semantic action (@pxref{Debugging actions}).
-@end table
-
-When an action is not specified a default value is supplied, it is
-@code{(identity $1)}. This means that the default semantic value of a
-rule is the value of its first component. Excepted for a rule
-matching the empty string, for which the default action is to return
-@code{nil}.
-@end table
-@end table
-
-@node Example
-@section Example
-
-@cindex grammar example
-Here is an example to parse simple infix arithmetic expressions. See
-@ref{Infix Calc, , , bison}, in the Bison manual for details.
-
-@lisp
-@group
-'(
- ;; Terminals
- (NUM)
-
- ;; Terminal associativity & precedence
- ((nonassoc ?=)
- (left ?- ?+)
- (left ?* ?/)
- (left NEG)
- (right ?^))
-
- ;; Rules
- (input
- ((line))
- ((input line)
- (format "%s %s" $1 $2))
- )
-
- (line
- ((?;)
- (progn ";"))
- ((exp ?;)
- (format "%s;" $1))
- ((error ?;)
- (progn "Error;")))
- )
-
- (exp
- ((NUM)
- (string-to-number $1))
- ((exp ?= exp)
- (= $1 $3))
- ((exp ?+ exp)
- (+ $1 $3))
- ((exp ?- exp)
- (- $1 $3))
- ((exp ?* exp)
- (* $1 $3))
- ((exp ?/ exp)
- (/ $1 $3))
- ((?- exp) [NEG]
- (- $2))
- ((exp ?^ exp)
- (expt $1 $3))
- ((?\( exp ?\))
- (progn $2))
- )
- )
-@end group
-@end lisp
-
-In the bison-like @dfn{WY} format (@pxref{Wisent Semantic}) the
-grammar looks like this:
-
-@example
-@group
-%token <number> NUM
-
-%nonassoc '=' ;; comparison
-%left '-' '+'
-%left '*' '/'
-%left NEG ;; negation--unary minus
-%right '^' ;; exponentiation
-
-%%
-
-input:
- line
- | input line
- (format "%s %s" $1 $2)
- ;
-
-line:
- ';'
- @{";"@}
- | exp ';'
- (format "%s;" $1)
- | error ';'
- @{"Error;"@}
- ;
-
-exp:
- NUM
- (string-to-number $1)
- | exp '=' exp
- (= $1 $3)
- | exp '+' exp
- (+ $1 $3)
- | exp '-' exp
- (- $1 $3)
- | exp '*' exp
- (* $1 $3)
- | exp '/' exp
- (/ $1 $3)
- | '-' exp %prec NEG
- (- $2)
- | exp '^' exp
- (expt $1 $3)
- | '(' exp ')'
- @{$2@}
- ;
-
-%%
-@end group
-@end example
-
-@node Compiling a grammar
-@section Compiling a grammar
-
-@cindex automaton
-After providing a context-free grammar in a suitable format, it must
-be translated into a set of tables (an @dfn{automaton}) that will be
-used to derive the parser. Like Bison, Wisent translates grammars that
-must be @dfn{LALR(1)}.
-
-@cindex LALR(1) grammar
-@cindex look-ahead token
-A grammar is @acronym{LALR(1)} if it is possible to tell how to parse
-any portion of an input string with just a single token of look-ahead:
-the @dfn{look-ahead token}. See @ref{Language and Grammar, , ,
-bison}, in the Bison manual for more information.
-
-@cindex grammar compilation
-Grammar translation (compilation) is achieved by the function:
-
-@cindex compiling a grammar
-@vindex wisent-single-start-flag
-@findex wisent-compile-grammar
-@defun wisent-compile-grammar grammar &optional start-list
-Compile @var{grammar} and return an @acronym{LALR(1)} automaton.
-
-Optional argument @var{start-list} is a list of start symbols
-(nonterminals). If @code{nil} the first nonterminal defined in the
-grammar is the default start symbol. If @var{start-list} contains
-only one element, it defines the start symbol. If @var{start-list}
-contains more than one element, all are defined as potential start
-symbols, unless @code{wisent-single-start-flag} is non-@code{nil}. In
-that case the first element of @var{start-list} defines the start
-symbol and others are ignored.
-
-The @acronym{LALR(1)} automaton is a vector of the form:
-
-@code{[@var{actions gotos starts functions}]}
-
-@table @var
-@item actions
-A state/token matrix telling the parser what to do at every state
-based on the current look-ahead token. That is shift, reduce, accept
-or error. See also @ref{Wisent Parsing}.
-
-@item gotos
-A state/nonterminal matrix telling the parser the next state to go to
-after reducing with each rule.
-
-@item starts
-An alist which maps the allowed start symbols (nonterminals) to
-lexical tokens that will be first shifted into the parser stack.
-
-@item functions
-An obarray of semantic action symbols. A semantic action is actually
-an Emacs Lisp function (lambda expression).
-@end table
-@end defun
-
-@node Conflicts
-@section Conflicts
-
-Normally, a grammar should produce an automaton where at each state
-the parser has only one action to do (@pxref{Wisent Parsing}).
-
-@cindex ambiguous grammar
-In certain cases, a grammar can produce an automaton where, at some
-states, there are more than one action possible. Such a grammar is
-@dfn{ambiguous}, and generates @dfn{conflicts}.
-
-@cindex deterministic automaton
-The parser can't be driven by an automaton which isn't completely
-@dfn{deterministic}, that is which contains conflicts. It is
-necessary to resolve the conflicts to eliminate them. Wisent resolves
-conflicts like Bison does.
-
-@cindex grammar conflicts
-@cindex conflicts resolution
-There are two sorts of conflicts:
-
-@table @dfn
-@cindex shift/reduce conflicts
-@item shift/reduce conflicts
-When either a shift or a reduction would be valid at the same state.
-
-Such conflicts are resolved by choosing to shift, unless otherwise
-directed by operator precedence declarations.
-See @ref{Shift/Reduce , , , bison}, in the Bison manual for more
-information.
-
-@cindex reduce/reduce conflicts
-@item reduce/reduce conflicts
-That occurs if there are two or more rules that apply to the same
-sequence of input. This usually indicates a serious error in the
-grammar.
-
-Such conflicts are resolved by choosing to use the rule that appears
-first in the grammar, but it is very risky to rely on this. Every
-reduce/reduce conflict must be studied and usually eliminated. See
-@ref{Reduce/Reduce , , , bison}, in the Bison manual for more
-information.
-@end table
-
-@menu
-* Grammar Debugging::
-* Understanding the automaton::
-@end menu
-
-@node Grammar Debugging
-@subsection Grammar debugging
-
-@cindex grammar debugging
-@cindex grammar verbose description
-To help writing a new grammar, @code{wisent-compile-grammar} can
-produce a verbose report containing a detailed description of the
-grammar and parser (equivalent to what Bison reports with the
-@option{--verbose} option).
-
-To enable the verbose report you can set to non-@code{nil} the
-variable:
-
-@vindex wisent-verbose-flag
-@deffn Option wisent-verbose-flag
-non-@code{nil} means to report verbose information on generated parser.
-@end deffn
-
-Or interactively use the command:
-
-@findex wisent-toggle-verbose-flag
-@deffn Command wisent-toggle-verbose-flag
-Toggle whether to report verbose information on generated parser.
-@end deffn
-
-The verbose report is printed in the temporary buffer
-@file{*wisent-log*} when running interactively, or in file
-@file{wisent.output} when running in batch mode. Different
-reports are separated from each other by a line like this:
-
-@example
-@group
-*** Wisent @var{source-file} - 2002-06-27 17:33
-@end group
-@end example
-
-where @var{source-file} is the name of the Emacs Lisp file from which
-the grammar was read. See @ref{Understanding the automaton}, for
-details on the verbose report.
-
-@table @strong
-@item Please Note
-To help debugging the grammar compiler itself, you can set this
-variable to print the content of some internal data structures:
-
-@vindex wisent-debug-flag
-@defvar wisent-debug-flag
-non-@code{nil} means enable some debug stuff.
-@end defvar
-@end table
-
-@node Understanding the automaton
-@subsection Understanding the automaton
-
-@cindex understanding the automaton
-This section (took from the manual of Bison 1.49) describes how to use
-the verbose report printed by @code{wisent-compile-grammar} to
-understand the generated automaton, to tune or fix a grammar.
-
-We will use the following example:
-
-@example
-@group
-(let ((wisent-verbose-flag t)) ;; Print a verbose report!
- (wisent-compile-grammar
- '((NUM STR) ; %token NUM STR
-
- ((left ?+ ?-) ; %left '+' '-';
- (left ?*)) ; %left '*'
-
- (exp ; exp:
- ((exp ?+ exp)) ; exp '+' exp
- ((exp ?- exp)) ; | exp '-' exp
- ((exp ?* exp)) ; | exp '*' exp
- ((exp ?/ exp)) ; | exp '/' exp
- ((NUM)) ; | NUM
- ) ; ;
-
- (useless ; useless:
- ((STR)) ; STR
- ) ; ;
- )
- 'nil) ; no %start declarations
- )
-@end group
-@end example
-
-When evaluating the above expression, grammar compilation first issues
-the following two clear messages:
-
-@example
-@group
-Grammar contains 1 useless nonterminals and 1 useless rules
-Grammar contains 7 shift/reduce conflicts
-@end group
-@end example
-
-The @file{*wisent-log*} buffer details things!
-
-The first section reports conflicts that were solved using precedence
-and/or associativity:
-
-@example
-@group
-Conflict in state 7 between rule 1 and token '+' resolved as reduce.
-Conflict in state 7 between rule 1 and token '-' resolved as reduce.
-Conflict in state 7 between rule 1 and token '*' resolved as shift.
-Conflict in state 8 between rule 2 and token '+' resolved as reduce.
-Conflict in state 8 between rule 2 and token '-' resolved as reduce.
-Conflict in state 8 between rule 2 and token '*' resolved as shift.
-Conflict in state 9 between rule 3 and token '+' resolved as reduce.
-Conflict in state 9 between rule 3 and token '-' resolved as reduce.
-Conflict in state 9 between rule 3 and token '*' resolved as reduce.
-@end group
-@end example
-
-The next section reports useless tokens, nonterminal and rules (note
-that useless tokens might be used by the scanner):
-
-@example
-@group
-Useless nonterminals:
-
- useless
-
-
-Terminals which are not used:
-
- STR
-
-
-Useless rules:
-
-#6 useless: STR;
-@end group
-@end example
-
-The next section lists states that still have conflicts:
-
-@example
-@group
-State 7 contains 1 shift/reduce conflict.
-State 8 contains 1 shift/reduce conflict.
-State 9 contains 1 shift/reduce conflict.
-State 10 contains 4 shift/reduce conflicts.
-@end group
-@end example
-
-The next section reproduces the grammar used:
-
-@example
-@group
-Grammar
-
- Number, Rule
- 1 exp -> exp '+' exp
- 2 exp -> exp '-' exp
- 3 exp -> exp '*' exp
- 4 exp -> exp '/' exp
- 5 exp -> NUM
-@end group
-@end example
-
-And reports the uses of the symbols:
-
-@example
-@group
-Terminals, with rules where they appear
-
-$EOI (-1)
-error (1)
-NUM (2) 5
-STR (3) 6
-'+' (4) 1
-'-' (5) 2
-'*' (6) 3
-'/' (7) 4
-
-
-Nonterminals, with rules where they appear
-
-exp (8)
- on left: 1 2 3 4 5, on right: 1 2 3 4
-@end group
-@end example
-
-The report then details the automaton itself, describing each state
-with it set of @dfn{items}, also known as @dfn{pointed rules}. Each
-item is a production rule together with a point (marked by @samp{.})
-that the input cursor.
-
-@example
-@group
-state 0
-
- NUM shift, and go to state 1
-
- exp go to state 2
-@end group
-@end example
-
-State 0 corresponds to being at the very beginning of the parsing, in
-the initial rule, right before the start symbol (@samp{exp}). When
-the parser returns to this state right after having reduced a rule
-that produced an @samp{exp}, it jumps to state 2. If there is no such
-transition on a nonterminal symbol, and the lookahead is a @samp{NUM},
-then this token is shifted on the parse stack, and the control flow
-jumps to state 1. Any other lookahead triggers a parse error.
-
-In the state 1...
-
-@example
-@group
-state 1
-
- exp -> NUM . (rule 5)
-
- $default reduce using rule 5 (exp)
-@end group
-@end example
-
-the rule 5, @samp{exp: NUM;}, is completed. Whatever the lookahead
-(@samp{$default}), the parser will reduce it. If it was coming from
-state 0, then, after this reduction it will return to state 0, and
-will jump to state 2 (@samp{exp: go to state 2}).
-
-@example
-@group
-state 2
-
- exp -> exp . '+' exp (rule 1)
- exp -> exp . '-' exp (rule 2)
- exp -> exp . '*' exp (rule 3)
- exp -> exp . '/' exp (rule 4)
-
- $EOI shift, and go to state 11
- '+' shift, and go to state 3
- '-' shift, and go to state 4
- '*' shift, and go to state 5
- '/' shift, and go to state 6
-@end group
-@end example
-
-In state 2, the automaton can only shift a symbol. For instance,
-because of the item @samp{exp -> exp . '+' exp}, if the lookahead if
-@samp{+}, it will be shifted on the parse stack, and the automaton
-control will jump to state 3, corresponding to the item
-@samp{exp -> exp . '+' exp}:
-
-@example
-@group
-state 3
-
- exp -> exp '+' . exp (rule 1)
-
- NUM shift, and go to state 1
-
- exp go to state 7
-@end group
-@end example
-
-Since there is no default action, any other token than those listed
-above will trigger a parse error.
-
-The interpretation of states 4 to 6 is straightforward:
-
-@example
-@group
-state 4
-
- exp -> exp '-' . exp (rule 2)
-
- NUM shift, and go to state 1
-
- exp go to state 8
-
-
-
-state 5
-
- exp -> exp '*' . exp (rule 3)
-
- NUM shift, and go to state 1
-
- exp go to state 9
-
-
-
-state 6
-
- exp -> exp '/' . exp (rule 4)
-
- NUM shift, and go to state 1
-
- exp go to state 10
-@end group
-@end example
-
-As was announced in beginning of the report, @samp{State 7 contains 1
-shift/reduce conflict.}:
-
-@example
-@group
-state 7
-
- exp -> exp . '+' exp (rule 1)
- exp -> exp '+' exp . (rule 1)
- exp -> exp . '-' exp (rule 2)
- exp -> exp . '*' exp (rule 3)
- exp -> exp . '/' exp (rule 4)
-
- '*' shift, and go to state 5
- '/' shift, and go to state 6
-
- '/' [reduce using rule 1 (exp)]
- $default reduce using rule 1 (exp)
-@end group
-@end example
-
-Indeed, there are two actions associated to the lookahead @samp{/}:
-either shifting (and going to state 6), or reducing rule 1. The
-conflict means that either the grammar is ambiguous, or the parser
-lacks information to make the right decision. Indeed the grammar is
-ambiguous, as, since we did not specify the precedence of @samp{/},
-the sentence @samp{NUM + NUM / NUM} can be parsed as @samp{NUM + (NUM
-/ NUM)}, which corresponds to shifting @samp{/}, or as @samp{(NUM +
-NUM) / NUM}, which corresponds to reducing rule 1.
-
-Because in @acronym{LALR(1)} parsing a single decision can be made,
-Wisent arbitrarily chose to disable the reduction, see
-@ref{Conflicts}. Discarded actions are reported in between square
-brackets.
-
-Note that all the previous states had a single possible action: either
-shifting the next token and going to the corresponding state, or
-reducing a single rule. In the other cases, i.e., when shifting
-@emph{and} reducing is possible or when @emph{several} reductions are
-possible, the lookahead is required to select the action. State 7 is
-one such state: if the lookahead is @samp{*} or @samp{/} then the
-action is shifting, otherwise the action is reducing rule 1. In other
-words, the first two items, corresponding to rule 1, are not eligible
-when the lookahead is @samp{*}, since we specified that @samp{*} has
-higher precedence that @samp{+}. More generally, some items are
-eligible only with some set of possible lookaheads.
-
-States 8 to 10 are similar:
-
-@example
-@group
-state 8
-
- exp -> exp . '+' exp (rule 1)
- exp -> exp . '-' exp (rule 2)
- exp -> exp '-' exp . (rule 2)
- exp -> exp . '*' exp (rule 3)
- exp -> exp . '/' exp (rule 4)
-
- '*' shift, and go to state 5
- '/' shift, and go to state 6
-
- '/' [reduce using rule 2 (exp)]
- $default reduce using rule 2 (exp)
-
-
-state 9
-
- exp -> exp . '+' exp (rule 1)
- exp -> exp . '-' exp (rule 2)
- exp -> exp . '*' exp (rule 3)
- exp -> exp '*' exp . (rule 3)
- exp -> exp . '/' exp (rule 4)
-
- '/' shift, and go to state 6
-
- '/' [reduce using rule 3 (exp)]
- $default reduce using rule 3 (exp)
-
-
-state 10
-
- exp -> exp . '+' exp (rule 1)
- exp -> exp . '-' exp (rule 2)
- exp -> exp . '*' exp (rule 3)
- exp -> exp . '/' exp (rule 4)
- exp -> exp '/' exp . (rule 4)
-
- '+' shift, and go to state 3
- '-' shift, and go to state 4
- '*' shift, and go to state 5
- '/' shift, and go to state 6
-
- '+' [reduce using rule 4 (exp)]
- '-' [reduce using rule 4 (exp)]
- '*' [reduce using rule 4 (exp)]
- '/' [reduce using rule 4 (exp)]
- $default reduce using rule 4 (exp)
-@end group
-@end example
-
-Observe that state 10 contains conflicts due to the lack of precedence
-of @samp{/} wrt @samp{+}, @samp{-}, and @samp{*}, but also because the
-associativity of @samp{/} is not specified.
-
-Finally, the state 11 (plus 12) is named the @dfn{final state}, or the
-@dfn{accepting state}:
-
-@example
-@group
-state 11
-
- $EOI shift, and go to state 12
-
-
-
-state 12
-
- $default accept
-@end group
-@end example
-
-The end of input is shifted @samp{$EOI shift,} and the parser exits
-successfully (@samp{go to state 12}, that terminates).
-
-@node Wisent Parsing
-@chapter Wisent Parsing
-
-@cindex bottom-up parser
-@cindex shift-reduce parser
-The Wisent's parser is what is called a @dfn{bottom-up} or
-@dfn{shift-reduce} parser which repeatedly:
-
-@table @dfn
-@cindex shift
-@item shift
-That is pushes the value of the last lexical token read (the
-look-ahead token) into a value stack, and reads a new one.
-
-@cindex reduce
-@item reduce
-That is replaces a nonterminal by its semantic value. The values of
-the components which form the right hand side of a rule are popped
-from the value stack and reduced by the semantic action of this rule.
-The result is pushed back on top of value stack.
-@end table
-
-The parser will stop on:
-
-@table @dfn
-@cindex accept
-@item accept
-When all input has been successfully parsed. The semantic value of
-the start nonterminal is on top of the value stack.
-
-@cindex syntax error
-@item error
-When a syntax error (an unexpected token in input) has been detected.
-At this point the parser issues an error message and either stops or
-calls a recovery routine to try to resume parsing.
-@end table
-
-@cindex table-driven parser
-The above elementary actions are driven by the @acronym{LALR(1)}
-automaton built by @code{wisent-compile-grammar} from a context-free
-grammar.
-
-The Wisent's parser is entered by calling the function:
-
-@findex wisent-parse
-@defun wisent-parse automaton lexer &optional error start
-Parse input using the automaton specified in @var{automaton}.
-
-@table @var
-@item automaton
-Is an @acronym{LALR(1)} automaton generated by
-@code{wisent-compile-grammar} (@pxref{Wisent Grammar}).
-
-@item lexer
-Is a function with no argument called by the parser to obtain the next
-terminal (token) in input (@pxref{Writing a lexer}).
-
-@item error
-Is an optional reporting function called when a parse error occurs.
-It receives a message string to report. It defaults to the function
-@code{wisent-message} (@pxref{Report errors}).
-
-@item start
-Specify the start symbol (nonterminal) used by the parser as its goal.
-It defaults to the start symbol defined in the grammar
-(@pxref{Wisent Grammar}).
-@end table
-@end defun
-
-The following two normal hooks permit doing some useful processing
-respectively before starting parsing, and after the parser terminated.
-
-@vindex wisent-pre-parse-hook
-@defvar wisent-pre-parse-hook
-Normal hook run just before entering the @var{LR} parser engine.
-@end defvar
-
-@vindex wisent-post-parse-hook
-@defvar wisent-post-parse-hook
-Normal hook run just after the @var{LR} parser engine terminated.
-@end defvar
-
-@menu
-* Writing a lexer::
-* Actions goodies::
-* Report errors::
-* Error recovery::
-* Debugging actions::
-@end menu
-
-@node Writing a lexer
-@section What the parser must receive
-
-It is important to understand that the parser does not parse
-characters, but lexical tokens, and does not know anything about
-characters in text streams!
-
-@cindex lexical analysis
-@cindex lexer
-@cindex scanner
-Reading input data to produce lexical tokens is performed by a lexer
-(also called a scanner) in a lexical analysis step, before the syntax
-analysis step performed by the parser. The parser automatically calls
-the lexer when it needs the next token to parse.
-
-@cindex lexical tokens
-A Wisent's lexer is an Emacs Lisp function with no argument. It must
-return a valid lexical token of the form:
-
-@code{(@var{token-class value} [@var{start} . @var{end}])}
-
-@table @var
-@item token-class
-Is a category of lexical token identifying a terminal as specified in
-the grammar (@pxref{Wisent Grammar}). It can be a symbol or a character
-literal.
-
-@item value
-Is the value of the lexical token. It can be of any valid Emacs Lisp
-data type.
-
-@item start
-@itemx end
-Are the optional beginning and ending positions of @var{value} in the
-input stream.
-@end table
-
-When there are no more tokens to read the lexer must return the token
-@code{(list wisent-eoi-term)} to each request.
-
-@vindex wisent-eoi-term
-@defvar wisent-eoi-term
-Predefined constant, End-Of-Input terminal symbol.
-@end defvar
-
-@code{wisent-lex} is an example of a lexer that reads lexical tokens
-produced by a @semantic{} lexer, and translates them into lexical tokens
-suitable to the Wisent parser. See also @ref{Wisent Lex}.
-
-To call the lexer in a semantic action use the function
-@code{wisent-lexer}. See also @ref{Actions goodies}.
-
-@node Actions goodies
-@section Variables and macros useful in grammar actions.
-
-@vindex wisent-input
-@defvar wisent-input
-The last token read.
-This variable only has meaning in the scope of @code{wisent-parse}.
-@end defvar
-
-@findex wisent-lexer
-@defun wisent-lexer
-Obtain the next terminal in input.
-@end defun
-
-@findex wisent-region
-@defun wisent-region &rest positions
-Return the start/end positions of the region including
-@var{positions}. Each element of @var{positions} is a pair
-@w{@code{(@var{start-pos} . @var{end-pos})}} or @code{nil}. The
-returned value is the pair @w{@code{(@var{min-start-pos} .
-@var{max-end-pos})}} or @code{nil} if no @var{positions} are
-available.
-@end defun
-
-@node Report errors
-@section The error reporting function
-
-@cindex error reporting
-When the parser encounters a syntax error it calls a user-defined
-function. It must be an Emacs Lisp function with one argument: a
-string containing the message to report.
-
-By default the parser uses this function to report error messages:
-
-@findex wisent-message
-@defun wisent-message string &rest args
-Print a one-line message if @code{wisent-parse-verbose-flag} is set.
-Pass @var{string} and @var{args} arguments to @dfn{message}.
-@end defun
-
-@table @strong
-@item Please Note:
-@code{wisent-message} uses the following function to print lexical
-tokens:
-
-@defun wisent-token-to-string token
-Return a printed representation of lexical token @var{token}.
-@end defun
-
-The general printed form of a lexical token is:
-
-@w{@code{@var{token}(@var{value})@@@var{location}}}
-@end table
-
-To control the verbosity of the parser you can set to non-@code{nil}
-this variable:
-
-@vindex wisent-parse-verbose-flag
-@deffn Option wisent-parse-verbose-flag
-non-@code{nil} means to issue more messages while parsing.
-@end deffn
-
-Or interactively use the command:
-
-@findex wisent-parse-toggle-verbose-flag
-@deffn Command wisent-parse-toggle-verbose-flag
-Toggle whether to issue more messages while parsing.
-@end deffn
-
-When the error reporting function is entered the variable
-@code{wisent-input} contains the unexpected token as returned by the
-lexer.
-
-The error reporting function can be called from a semantic action too
-using the special macro @code{wisent-error}. When called from a
-semantic action entered by error recovery (@pxref{Error recovery}) the
-value of the variable @code{wisent-recovering} is non-@code{nil}.
-
-@node Error recovery
-@section Error recovery
-
-@cindex error recovery
-The error recovery mechanism of the Wisent's parser conforms to the
-one Bison uses. See @ref{Error Recovery, , , bison}, in the Bison
-manual for details.
-
-@cindex error token
-To recover from a syntax error you must write rules to recognize the
-special token @code{error}. This is a terminal symbol that is
-automatically defined and reserved for error handling.
-
-When the parser encounters a syntax error, it pops the state stack
-until it finds a state that allows shifting the @code{error} token.
-After it has been shifted, if the old look-ahead token is not
-acceptable to be shifted next, the parser reads tokens and discards
-them until it finds a token which is acceptable.
-
-@cindex error recovery strategy
-Strategies for error recovery depend on the choice of error rules in
-the grammar. A simple and useful strategy is simply to skip the rest
-of the current statement if an error is detected:
-
-@example
-@group
-(statement (( error ?; )) ;; on error, skip until ';' is read
- )
-@end group
-@end example
-
-It is also useful to recover to the matching close-delimiter of an
-opening-delimiter that has already been parsed:
-
-@example
-@group
-(primary (( ?@{ expr ?@} ))
- (( ?@{ error ?@} ))
- @dots{}
- )
-@end group
-@end example
-
-@cindex error recovery actions
-Note that error recovery rules may have actions, just as any other
-rules can. Here are some predefined hooks, variables, functions or
-macros, useful in such actions:
-
-@vindex wisent-nerrs
-@defvar wisent-nerrs
-The number of parse errors encountered so far.
-@end defvar
-
-@vindex wisent-recovering
-@defvar wisent-recovering
-non-@code{nil} means that the parser is recovering.
-This variable only has meaning in the scope of @code{wisent-parse}.
-@end defvar
-
-@findex wisent-error
-@defun wisent-error msg
-Call the user supplied error reporting function with message
-@var{msg} (@pxref{Report errors}).
-
-For an example of use, @xref{wisent-skip-token}.
-@end defun
-
-@findex wisent-errok
-@defun wisent-errok
-Resume generating error messages immediately for subsequent syntax
-errors.
-
-The parser suppress error message for syntax errors that happens
-shortly after the first, until three consecutive input tokens have
-been successfully shifted.
-
-Calling @code{wisent-errok} in an action, make error messages resume
-immediately. No error messages will be suppressed if you call it in
-an error rule's action.
-
-For an example of use, @xref{wisent-skip-token}.
-@end defun
-
-@findex wisent-clearin
-@defun wisent-clearin
-Discard the current lookahead token.
-This will cause a new lexical token to be read.
-
-In an error rule's action the previous lookahead token is reanalyzed
-immediately. @code{wisent-clearin} may be called to clear this token.
-
-For example, suppose that on a parse error, an error handling routine
-is called that advances the input stream to some point where parsing
-should once again commence. The next symbol returned by the lexical
-scanner is probably correct. The previous lookahead token ought to
-be discarded with @code{wisent-clearin}.
-
-For an example of use, @xref{wisent-skip-token}.
-@end defun
-
-@findex wisent-abort
-@defun wisent-abort
-Abort parsing and save the lookahead token.
-@end defun
-
-@findex wisent-set-region
-@defun wisent-set-region start end
-Change the region of text matched by the current nonterminal.
-@var{start} and @var{end} are respectively the beginning and end
-positions of the region occupied by the group of components associated
-to this nonterminal. If @var{start} or @var{end} values are not a
-valid positions the region is set to @code{nil}.
-
-For an example of use, @xref{wisent-skip-token}.
-@end defun
-
-@vindex wisent-discarding-token-functions
-@defvar wisent-discarding-token-functions
-List of functions to be called when discarding a lexical token.
-These functions receive the lexical token discarded.
-When the parser encounters unexpected tokens, it can discards them,
-based on what directed by error recovery rules. Either when the
-parser reads tokens until one is found that can be shifted, or when an
-semantic action calls the function @code{wisent-skip-token} or
-@code{wisent-skip-block}.
-For language specific hooks, make sure you define this as a local
-hook.
-
-For example, in @semantic{}, this hook is set to the function
-@code{wisent-collect-unmatched-syntax} to collect unmatched lexical
-tokens (@pxref{Useful functions}).
-@end defvar
-
-@findex wisent-skip-token
-@defun wisent-skip-token
-@anchor{wisent-skip-token}
-Skip the lookahead token in order to resume parsing.
-Return @code{nil}.
-Must be used in error recovery semantic actions.
-
-It typically looks like this:
-
-@lisp
-@group
-(wisent-message "%s: skip %s" $action
- (wisent-token-to-string wisent-input))
-(run-hook-with-args
- 'wisent-discarding-token-functions wisent-input)
-(wisent-clearin)
-(wisent-errok)))
-@end group
-@end lisp
-@end defun
-
-@findex wisent-skip-block
-@defun wisent-skip-block
-Safely skip a block in order to resume parsing.
-Return @code{nil}.
-Must be used in error recovery semantic actions.
-
-A block is data between an open-delimiter (syntax class @code{(}) and
-a matching close-delimiter (syntax class @code{)}):
-
-@example
-@group
-(a parenthesized block)
-[a block between brackets]
-@{a block between braces@}
-@end group
-@end example
-
-The following example uses @code{wisent-skip-block} to safely skip a
-block delimited by @samp{LBRACE} (@code{@{}) and @samp{RBRACE}
-(@code{@}}) tokens, when a syntax error occurs in
-@samp{other-components}:
-
-@example
-@group
-(block ((LBRACE other-components RBRACE))
- ((LBRACE RBRACE))
- ((LBRACE error)
- (wisent-skip-block))
- )
-@end group
-@end example
-@end defun
-
-@node Debugging actions
-@section Debugging semantic actions
-
-@cindex semantic action symbols
-Each semantic action is represented by a symbol interned in an
-@dfn{obarray} that is part of the @acronym{LALR(1)} automaton
-(@pxref{Compiling a grammar}). @code{symbol-function} on a semantic
-action symbol return the semantic action lambda expression.
-
-A semantic action symbol name has the form
-@code{@var{nonterminal}:@var{index}}, where @var{nonterminal} is the
-name of the nonterminal symbol the action belongs to, and @var{index}
-is an action sequence number within the scope of @var{nonterminal}.
-For example, this nonterminal definition:
-
-@example
-@group
-input:
- line [@code{input:0}]
- | input line
- (format "%s %s" $1 $2) [@code{input:1}]
- ;
-@end group
-@end example
-
-Will produce two semantic actions, and associated symbols:
-
-@table @code
-@item input:0
-A default action that returns @code{$1}.
-
-@item input:1
-That returns @code{(format "%s %s" $1 $2)}.
-@end table
-
-@cindex debugging semantic actions
-Debugging uses the Lisp debugger to investigate what is happening
-during execution of semantic actions.
-Three commands are available to debug semantic actions. They receive
-two arguments:
-
-@itemize @bullet
-@item The automaton that contains the semantic action.
-
-@item The semantic action symbol.
-@end itemize
-
-@findex wisent-debug-on-entry
-@deffn Command wisent-debug-on-entry automaton function
-Request @var{automaton}'s @var{function} to invoke debugger each time it is called.
-@var{function} must be a semantic action symbol that exists in @var{automaton}.
-@end deffn
-
-@findex wisent-cancel-debug-on-entry
-@deffn Command wisent-cancel-debug-on-entry automaton function
-Undo effect of @code{wisent-debug-on-entry} on @var{automaton}'s @var{function}.
-@var{function} must be a semantic action symbol that exists in @var{automaton}.
-@end deffn
-
-@findex wisent-debug-show-entry
-@deffn Command wisent-debug-show-entry automaton function
-Show the source of @var{automaton}'s semantic action @var{function}.
-@var{function} must be a semantic action symbol that exists in @var{automaton}.
-@end deffn
-
-@node Wisent Semantic
-@chapter How to use Wisent with Semantic
-
-@cindex tags
-This section presents how the Wisent's parser can be used to produce
-@dfn{tags} for the @semantic{} tool set.
-
-@semantic{} tags form a hierarchy of Emacs Lisp data structures that
-describes a program in a way independent of programming languages.
-Tags map program declarations, like functions, methods, variables,
-data types, classes, includes, grammar rules, etc..
-
-@cindex WY grammar format
-To use the Wisent parser with @semantic{} you have to define
-your grammar in @dfn{WY} form, a grammar format very close
-to the one used by Bison.
-
-Please see @ref{top, Semantic Grammar Framework Manual,, grammar-fw},
-for more information on @semantic{} grammars.
-
-@menu
-* Grammar styles::
-* Wisent Lex::
-@end menu
-
-@node Grammar styles
-@section Grammar styles
-
-@cindex grammar styles
-@semantic{} parsing heavily depends on how you wrote the grammar.
-There are mainly two styles to write a Wisent's grammar intended to be
-used with the @semantic{} tool set: the @dfn{Iterative style} and the
-@dfn{Bison style}. Each one has pros and cons, and in certain cases
-it can be worth a mix of the two styles!
-
-@menu
-* Iterative style::
-* Bison style::
-* Mixed style::
-* Start nonterminals::
-* Useful functions::
-@end menu
-
-@node Iterative style
-@subsection Iterative style
-
-@cindex grammar iterative style
-The @dfn{iterative style} is the preferred style to use with @semantic{}.
-It relies on an iterative parser back-end mechanism which parses start
-nonterminals one at a time and automagically skips unexpected lexical
-tokens in input.
-
-Compared to rule-based iterative functions (@pxref{Bison style}),
-iterative parsers are better in that they can handle obscure errors
-more cleanly.
-
-@cindex raw tag
-Each start nonterminal must produces a @dfn{raw tag} by calling a
-@code{TAG}-like grammar macro with appropriate parameters. See also
-@ref{Start nonterminals}.
-
-@cindex expanded tag
-Then, each parsing iteration automatically translates a raw tag into
-@dfn{expanded tags}, updating the raw tag structure with internal
-properties and buffer related data.
-
-After parsing completes, it results in a tree of expanded tags.
-
-The following example is a snippet of the iterative style Java grammar
-provided in the @semantic{} distribution in the file
-@file{semantic/wisent/java-tags.wy}.
-
-@example
-@group
-@dots{}
-;; Alternate entry points
-;; - Needed by partial re-parse
-%start formal_parameter
-@dots{}
-;; - Needed by EXPANDFULL clauses
-%start formal_parameters
-@dots{}
-
-formal_parameter_list
- : PAREN_BLOCK
- (EXPANDFULL $1 formal_parameters)
- ;
-
-formal_parameters
- : LPAREN
- ()
- | RPAREN
- ()
- | formal_parameter COMMA
- | formal_parameter RPAREN
- ;
-
-formal_parameter
- : formal_parameter_modifier_opt type variable_declarator_id
- (VARIABLE-TAG $3 $2 nil :typemodifiers $1)
- ;
-@end group
-@end example
-
-@findex EXPANDFULL
-It shows the use of the @code{EXPANDFULL} grammar macro to parse a
-@samp{PAREN_BLOCK} which contains a @samp{formal_parameter_list}.
-@code{EXPANDFULL} tells to recursively parse @samp{formal_parameters}
-inside @samp{PAREN_BLOCK}. The parser iterates until it digested all
-available input data inside the @samp{PAREN_BLOCK}, trying to match
-any of the @samp{formal_parameters} rules:
-
-@itemize
-@item @samp{LPAREN}
-
-@item @samp{RPAREN}
-
-@item @samp{formal_parameter COMMA}
-
-@item @samp{formal_parameter RPAREN}
-@end itemize
-
-At each iteration it will return a @samp{formal_parameter} raw tag,
-or @code{nil} to skip unwanted (single @samp{LPAREN} or @samp{RPAREN}
-for example) or unexpected input data. Those raw tags will be
-automatically expanded by the iterative back-end parser.
-
-@node Bison style
-@subsection Bison style
-
-@cindex grammar bison style
-What we call the @dfn{Bison style} is the traditional style of Bison's
-grammars. Compared to iterative style, it is not straightforward to
-use grammars written in Bison style in @semantic{}. Mainly because such
-grammars are designed to parse the whole input data in one pass, and
-don't use the iterative parser back-end mechanism (@pxref{Iterative
-style}). With Bison style the parser is called once to parse the
-grammar start nonterminal.
-
-The following example is a snippet of the Bison style Java grammar
-provided in the @semantic{} distribution in the file
-@file{semantic/wisent/java.wy}.
-
-@example
-@group
-%start formal_parameter
-@dots{}
-
-formal_parameter_list
- : formal_parameter_list COMMA formal_parameter
- (cons $3 $1)
- | formal_parameter
- (list $1)
- ;
-
-formal_parameter
- : formal_parameter_modifier_opt type variable_declarator_id
- (EXPANDTAG
- (VARIABLE-TAG $3 $2 :typemodifiers $1)
- )
- ;
-@end group
-@end example
-
-The first consequence is that syntax errors are not automatically
-handled by @semantic{}. Thus, it is necessary to explicitly handle
-them at the grammar level, providing error recovery rules to skip
-unexpected input data.
-
-The second consequence is that the iterative parser can't do automatic
-tag expansion, except for the start nonterminal value. It is
-necessary to explicitly expand tags from concerned semantic actions by
-calling the grammar macro @code{EXPANDTAG} with a raw tag as
-parameter. See also @ref{Start nonterminals}, for incremental
-re-parse considerations.
-
-@node Mixed style
-@subsection Mixed style
-
-@cindex grammar mixed style
-@example
-@group
-%start grammar
-;; Reparse
-%start prologue epilogue declaration nonterminal rule
-@dots{}
-
-%%
-
-grammar:
- prologue
- | epilogue
- | declaration
- | nonterminal
- | PERCENT_PERCENT
- ;
-@dots{}
-
-nonterminal:
- SYMBOL COLON rules SEMI
- (TAG $1 'nonterminal :children $3)
- ;
-
-rules:
- lifo_rules
- (apply 'nconc (nreverse $1))
- ;
-
-lifo_rules:
- lifo_rules OR rule
- (cons $3 $1)
- | rule
- (list $1)
- ;
-
-rule:
- rhs
- (let* ((rhs $1)
- name type comps prec action elt)
- @dots{}
- (EXPANDTAG
- (TAG name 'rule :type type :value comps :prec prec :expr action)
- ))
- ;
-@end group
-@end example
-
-This example shows how iterative and Bison styles can be combined in
-the same grammar to obtain a good compromise between grammar
-complexity and an efficient parsing strategy in an interactive
-environment.
-
-@samp{nonterminal} is parsed using iterative style via the main
-@samp{grammar} rule. The semantic action uses the @code{TAG} macro to
-produce a raw tag, automagically expanded by @semantic{}.
-
-But @samp{rules} part is parsed in Bison style! Why?
-
-Rule delimiters are the colon (@code{:}), that follows the nonterminal
-name, and a final semicolon (@code{;}). Unfortunately these
-delimiters are not @code{open-paren}/@code{close-paren} type, and the
-Emacs' syntactic analyzer can't easily isolate data between them to
-produce a @samp{RULES_PART} parenthesis-block-like lexical token.
-Consequently it is not possible to use @code{EXPANDFULL} to iterate in
-@samp{RULES_PART}, like this:
-
-@example
-@group
-nonterminal:
- SYMBOL COLON rules SEMI
- (TAG $1 'nonterminal :children $3)
- ;
-
-rules:
- RULES_PART ;; @strong{Map a parenthesis-block-like lexical token}
- (EXPANDFULL $1 'rules)
- ;
-
-rules:
- COLON
- ()
- OR
- ()
- SEMI
- ()
- rhs
- rhs
- (let* ((rhs $1)
- name type comps prec action elt)
- @dots{}
- (TAG name 'rule :type type :value comps :prec prec :expr action)
- )
- ;
-@end group
-@end example
-
-In such cases, when it is difficult for Emacs to obtain
-parenthesis-block-like lexical tokens, the best solution is to use the
-traditional Bison style with error recovery!
-
-In some extreme cases, it can also be convenient to extend the lexer,
-to deliver new lexical tokens, to simplify the grammar.
-
-@node Start nonterminals
-@subsection Start nonterminals
-
-@cindex start nonterminals
-@cindex @code{reparse-symbol} property
-When you write a grammar for @semantic{}, it is important to carefully
-indicate the start nonterminals. Each one defines an entry point in
-the grammar, and after parsing its semantic value is returned to the
-back-end iterative engine. Consequently:
-
-@strong{The semantic value of a start nonterminal must be a produced
-by a TAG like grammar macro}.
-
-Start nonterminals are declared by @code{%start} statements. When
-nothing is specified the first nonterminal that appears in the grammar
-is the start nonterminal.
-
-Generally, the following nonterminals must be declared as start
-symbols:
-
-@itemize @bullet
-@item The main grammar entry point
-@quotation
-Of course!
-@end quotation
-
-@item nonterminals passed to @code{EXPAND}/@code{EXPANDFULL}
-@quotation
-These grammar macros recursively parse a part of input data, based on
-rules of the given nonterminal.
-
-For example, the following will parse @samp{PAREN_BLOCK} data using
-the @samp{formal_parameters} rules:
-
-@example
-@group
-formal_parameter_list
- : PAREN_BLOCK
- (EXPANDFULL $1 formal_parameters)
- ;
-@end group
-@end example
-
-The semantic value of @samp{formal_parameters} becomes the value of
-the @code{EXPANDFULL} expression. It is a list of @semantic{} tags
-spliced in the tags tree.
-
-Because the automaton must know that @samp{formal_parameters} is a
-start symbol, you must declare it like this:
-
-@example
-@group
-%start formal_parameters
-@end group
-@end example
-@end quotation
-@end itemize
-
-@cindex incremental re-parse
-@cindex reparse-symbol
-The @code{EXPANDFULL} macro has a side effect it is important to know,
-related to the incremental re-parse mechanism of @semantic{}: the
-nonterminal symbol parameter passed to @code{EXPANDFULL} also becomes
-the @code{reparse-symbol} property of the tag returned by the
-@code{EXPANDFULL} expression.
-
-When buffer's data mapped by a tag is modified, @semantic{}
-schedules an incremental re-parse of that data, using the tag's
-@code{reparse-symbol} property as start nonterminal.
-
-@strong{The rules associated to such start symbols must be carefully
-reviewed to ensure that the incremental parser will work!}
-
-Things are a little bit different when the grammar is written in Bison
-style.
-
-@strong{The @code{reparse-symbol} property is set to the nonterminal
-symbol the rule that explicitly uses @code{EXPANDTAG} belongs to.}
-
-For example:
-
-@example
-@group
-rule:
- rhs
- (let* ((rhs $1)
- name type comps prec action elt)
- @dots{}
- (EXPANDTAG
- (TAG name 'rule :type type :value comps :prec prec :expr action)
- ))
- ;
-@end group
-@end example
-
-Set the @code{reparse-symbol} property of the expanded tag to
-@samp{rule}. An important consequence is that:
-
-@strong{Every nonterminal having any rule that calls @code{EXPANDTAG}
-in a semantic action, should be declared as a start symbol!}
-
-@node Useful functions
-@subsection Useful functions
-
-Here is a description of some predefined functions it might be useful
-to know when writing new code to use Wisent in @semantic{}:
-
-@findex wisent-collect-unmatched-syntax
-@defun wisent-collect-unmatched-syntax input
-Add @var{input} lexical token to the cache of unmatched tokens, in
-variable @code{semantic-unmatched-syntax-cache}.
-
-See implementation of the function @code{wisent-skip-token} in
-@ref{Error recovery}, for an example of use.
-@end defun
-
-@node Wisent Lex
-@section The Wisent Lex lexer
-
-@findex semantic-lex
-The lexical analysis step of @semantic{} is performed by the general
-function @code{semantic-lex}. For more information, see @ref{Writing
-Lexers, Semantic Language Development,,semantic-langdev}.
-
-@code{semantic-lex} produces lexical tokens of the form:
-
-@example
-@group
-@code{(@var{token-class start} . @var{end})}
-@end group
-@end example
-
-@table @var
-@item token-class
-Is a symbol that identifies a lexical token class, like @code{symbol},
-@code{string}, @code{number}, or @code{PAREN_BLOCK}.
-
-@item start
-@itemx end
-Are the start and end positions of mapped data in the input buffer.
-@end table
-
-The Wisent's parser doesn't depend on the nature of analyzed input
-stream (buffer, string, etc.), and requires that lexical tokens have a
-different form (@pxref{Writing a lexer}):
-
-@example
-@group
-@code{(@var{token-class value} [@var{start} . @var{end}])}
-@end group
-@end example
-
-@cindex lexical token mapping
-@code{wisent-lex} is the default Wisent's lexer used in @semantic{}.
-
-@vindex wisent-lex-istream
-@findex wisent-lex
-@defun wisent-lex
-Return the next available lexical token in Wisent's form.
-
-The variable @code{wisent-lex-istream} contains the list of lexical
-tokens produced by @code{semantic-lex}. Pop the next token available
-and convert it to a form suitable for the Wisent's parser.
-@end defun
-
-Mapping of lexical tokens as produced by @code{semantic-lex} into
-equivalent Wisent lexical tokens is straightforward:
-
-@example
-@group
-(@var{token-class start} . @var{end})
- @result{} (@var{token-class value start} . @var{end})
-@end group
-@end example
-
-@var{value} is the input @code{buffer-substring} from @var{start} to
-@var{end}.
-
-@node GNU Free Documentation License
-@appendix GNU Free Documentation License
-
-@include doclicense.texi
-
-@node Index
-@unnumbered Index
-@printindex cp
-
-@iftex
-@contents
-@summarycontents
-@end iftex
-
-@bye
-
-@c Following comments are for the benefit of ispell.
-
-@c LocalWords: Wisent automagically wisent Wisent's LALR obarray
+++ /dev/null
-;;; c.srt --- SRecode templates for c-mode
-
-;; Copyright (C) 2007-2010, 2012-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "c-mode"
-
-set comment_start "/**"
-set comment_end " */"
-set comment_prefix " *"
-
-;; OVERRIDE THIS in your user or project template file to whatever
-;; you use for your project.
-set HEADEREXT ".h"
-
-context file
-
-template empty :time :user :file :c
-----
-{{>:filecomment}}
-
-{{#NOTHEADER}}
-
-{{^}}
-{{/NOTHEADER}}
-{{#HEADER}}
-{{>:header_guard}}
-{{/HEADER}}
-----
-
-template header_guard :file :blank :c
-----
-#ifndef {{FILENAME_SYMBOL:upcase}}
-#define {{FILENAME_SYMBOL:upcase}} 1
-
-{{^}}
-
-#endif // {{FILENAME_SYMBOL:upcase}}
-----
-
-context misc
-
-template arglist
-"Insert an argument list for a function.
-@todo - Support smart CR in a buffer for not too long lines."
-----
-({{#ARGS}}{{TYPE}} {{NAME}}{{#NOTLAST}},{{/NOTLAST}}{{/ARGS}})
-----
-
-context declaration
-
-prompt TYPE "Return Type: "
-
-template function :indent :blank
-"Insert a function declaration."
-----
-{{?TYPE}} {{?NAME}}{{>:misc:arglist}}
-{{#INITIALIZERS}}{{>B:initializers}}{{/INITIALIZERS}}
-{
-{{^}}
-}
-----
-bind "f"
-
-template function-prototype :indent :blank
-"Insert a function declaration."
-----
-{{?TYPE}} {{?NAME}}{{>:misc:arglist}};
-----
-
-
-prompt TYPE "Data Type: "
-
-template variable :indent :blank
-"Insert a variable declaration."
-----
-{{?TYPE}} {{?NAME}}{{#HAVEDEFAULT}} = {{DEFAULT}}{{/HAVEDEFAULT}};
-----
-bind "v"
-
-template variable-prototype :indent :blank
-"Insert a variable declaration."
-----
-{{?TYPE}} {{?NAME}};
-----
-bind "v"
-
-
-template include :blank
-"An include statement."
-----
-#include "{{?NAME}}"
-----
-bind "i"
-
-template system-include :blank
-"An include statement."
-----
-#include <{{?NAME}}>
-----
-bind "i"
-
-template label :blank :indent
-----
- {{?NAME}}:
-----
-
-context declaration
-
-template comment-function :indent :blank
-"Used to put a nice comment in front of a function.
-Override this with your own preference to avoid using doxygen"
-----
-{{>A:declaration:doxygen-function}}
-----
-
-;;; DOXYGEN FEATURES
-;;
-;;
-context declaration
-
-template doxygen-function :indent :blank
-----
-/**
- * @name {{NAME}} - {{DOC}}{{^}}{{#ARGS}}
- * @param {{NAME}} - {{DOC}}{{/ARGS}}
- * @return {{TYPE}}
- */
-----
-
-template doxygen-variable-same-line
-----
-/**< {{DOC}}{{^}} */
-----
-
-template doxygen-section-comment :blank :indent
-"Insert a comment that separates sections of an Emacs Lisp file."
-----
-\f
-/** {{?TITLE}}
- *
- * {{^}}
- */
-
-----
-
-
-;; end
+++ /dev/null
-;;; cpp.srt --- SRecode templates for c++-mode
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "c++-mode"
-
-set comment_start "/**"
-set comment_end " */"
-set comment_prefix " *"
-
-context declaration
-
-template class :indent :blank
-"Insert a C++ class. For use by user insertion.
-Override this template to change contents of a class.
-Override `class-tag' to override the outer structure of the class."
-----
-{{<A:class-tag}}
- public:
- {{>CONSTRUCTOR:classdecl:constructor-tag}}
- {{>DESTRUCTOR:classdecl:destructor-tag}}
- private:
- {{^}}
-
-{{/A}}
-----
-
-template subclass :indent :blank
-"Insert a C++ subclass of some other class."
-sectiondictionary "PARENTS"
-set NAME "?PARENTNAME"
-----
-{{>A:class}}
-----
-
-template class-tag :indent :blank
-"Insert a C++ class with the expectation of it being used by a tag inserter.
-Override this to affect applications, or the outer class structure for
-the user-facing template."
-----
-class {{?NAME}} {{#PARENTS}}{{#FIRST}}: {{/FIRST}}public {{NAME}}{{/PARENTS}}
-{
- {{^}}
-};
-----
-bind "c"
-
-template method :indent :blank
-"Method belonging to some class, declared externally."
-----
-{{?TYPE}} {{?PARENT}}::{{?NAME}}{{>:misc:arglist}}
-{{#INITIALIZERS}}{{>B:initializers}}{{/INITIALIZERS}}
-{
-{{^}}
-}
-----
-
-context classdecl
-
-template constructor-tag :indent :blank
-----
-{{?NAME}}{{>:misc:arglist}}
-{ {{^}} }
-----
-
-;; This one really sucks. How can I finish it?
-template initializers :indent
-----
-{{#FIRST}}:
-{{/FIRST}}{{INITNAME}}(){{#NOTLAST}},{{/NOTLAST}}
-----
-
-template destructor-tag :indent :blank
-----
-~{{?NAME}}{{>:misc:arglist}}
-{ {{^}} }
-----
-
-;;; Base Comment functions for overriding.
-context classdecl
-
-template comment-function-group-start :indent :blank
-"Used for putting comments in front of a functional group of declarations.
-Override this with your own preference to avoid using doxygen."
-----
-{{>A:classdecl:doxygen-function-group-start}}
-----
-
-template comment-function-group-end :indent :blank
-"Used for putting comments in front of a functional group of declarations.
-Override this with your own preference to avoid using doxygen."
-----
-{{>A:classdecl:doxygen-function-group-end}}
-----
-
-;;; DOXYGEN FEATURES
-;;
-;;
-context classdecl
-
-prompt GROUPNAME "Name of declaration group: "
-
-template doxygen-function-group-start :indent :blank
-----
-/**
- * {{?GROUPNAME}}
- * @{
- */
-
-----
-
-template doxygen-function-group-end :indent :blank
-----
-/**
- * @}
- */
-
-----
-
-;; end
+++ /dev/null
-;;; default.srt --- SRecode templates for srecode-template-mode
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "default"
-
-set comment_start "#"
-
-set COPYRIGHT "This program is free software; you can redistribute it and/or
-modify it under the terms of the GNU General Public License as
-published by the Free Software Foundation, either version 3 of the
-License, or (at your option) any later version.
-
-This program 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 this program. If not, see https://www.gnu.org/licenses/."
-
-set DOLLAR "$"
-
-context file
-
-template copyright
-----
-{{COPYRIGHT:srecode-comment-prefix}}
-----
-
-template filecomment :file :user :time
-----
-{{comment_start}} {{FILENAME}} --- {{^}}
-{{comment_prefix}}
-{{comment_prefix}} Copyright (C) {{YEAR}} {{?AUTHOR}}
-{{comment_prefix}}
-{{comment_prefix}} Author: {{AUTHOR}} <{{EMAIL}}>{{#RCS}}
-{{comment_prefix}} X-RCS: {{DOLLAR}}Id{{DOLLAR}}{{/RCS}}
-{{comment_prefix}}
-{{>:copyright}}
-{{comment_end}}
-----
-
-;; end
+++ /dev/null
-;; doc-c.srt --- SRecode templates for "document" applications
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "c-mode"
-
-set application "document"
-context declaration
-
-;;; Notes on the DOCUMENT templates.
-;;
-;; These templates recycle existing templates for doxygen in the
-;; more general C++ template set.
-
-template section-comment :indent :blank
-"A comment separating major sections of a file."
-----
-{{>:declaration:doxygen-section-comment}}
-----
-
-template function-comment :tag :indent :blank
-"A comment occurring in front of a function.
-Recycle doxygen comment code from the more general template set."
-----
-{{>:declaration:doxygen-function}}
-----
-
-template variable-same-line-comment :tag
-"A comment occurring after a variable declaration.
-Recycle doxygen comment code from the more general template set."
-----
-{{>:declaration:doxygen-variable-same-line}}
-----
-
-;; These happen to be the same as in a classdecl.
-template group-comment-start :blank :indent
-"A comment occurring in front of a group of declarations.
-Recycle doxygen comment code from the more general template set."
-----
-{{>:classdecl:doxygen-function-group-start}}
-----
-
-template group-comment-end :blank :indent
-"A comment occurring at the end of a group of declarations.
-Recycle doxygen comment code from the more general template set."
-----
-{{>:classdecl:doxygen-function-group-end}}
-----
-
-;; Some templates only show up in classdecls.
-context classdecl
-
-template group-comment-start :blank :indent
-"A comment occurring in front of a group of declarations.
-Recycle doxygen comment code from the more general template set."
-----
-{{>:classdecl:doxygen-function-group-start}}
-----
-
-template group-comment-end :blank :indent
-"A comment occurring at the end of a group of declarations.
-Recycle doxygen comment code from the more general template set."
-----
-{{>:classdecl:doxygen-function-group-end}}
-----
-
-;; end
+++ /dev/null
-;; doc-default.srt --- SRecode templates for "document" applications
-
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "default"
-
-set application "document"
-
-context declaration
-
-template section-comment :blank :indent
-"A comment occurring in front of a group of declarations."
-----
-{{comment_start}} {{?TITLE}}
-{{comment_prefix}}
-{{comment_prefix}} {{^}}
-{{comment_end}}
-----
-
-template function-comment :tag :indent :blank
-"A comment occurring in front of a function."
-----
-{{comment_start}} {{?NAME}} --
-{{DOC:srecode-comment-prefix}}
-{{comment_end}}
-----
-
-template variable-same-line-comment :tag
-"A comment occurring after a variable declaration."
-----
-{{comment_start}} {{?DOC}} {{comment_end}}
-----
-
-;; These happen to be the same as in a classdecl.
-template group-comment-start :blank :indent
-"A comment occurring in front of a group of declarations."
-----
-{{comment_start}} {{?GROUPNAME}} --
-{{comment_end}}
-----
-
-template group-comment-end :indent
-"A comment occurring at the end of a group of declarations."
-----
-{{comment_start}} End {{?GROUPNAME}} {{comment_end}}
-----
-
-;; Some templates only show up in classdecls.
-context classdecl
-
-template group-comment-start :blank :indent
-"A comment occurring in front of a group of declarations."
-----
-{{>:declaration:group-comment-start}}
-----
-
-template group-comment-end :indent
-"A comment occurring at the end of a group of declarations."
-----
-{{>:declaration:group-comment-end}}
-----
-
-;; end
+++ /dev/null
-;; doc-java.srt --- SRecode templates for "document" applications
-
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "java-mode"
-
-set application "document"
-
-context declaration
-
-;;; Notes on the DOCUMENT templates.
-;;
-;; These templates recycle existing templates for javadoc in the
-;; more general C++ template set.
-
-template section-comment :indent :blank
-"A comment separating major sections of a file."
-----
-{{>:declaration:javadoc-section-comment}}
-----
-
-template function-comment :tag :indent :blank
-"A comment occurring in front of a function.
-Recycle javadoc comment code from the more general template set."
-----
-{{>:declaration:javadoc-function}}
-----
-
-template variable-same-line-comment :tag
-"A comment occurring after a variable declaration.
-Recycle javadoc comment code from the more general template set."
-----
-{{>:declaration:javadoc-variable-same-line}}
-----
-
-;; These happen to be the same as in a classdecl.
-template group-comment-start :blank :indent
-"A comment occurring in front of a group of declarations.
-Recycle javadoc comment code from the more general template set."
-----
-{{>:classdecl:javadoc-function-group-start}}
-----
-
-template group-comment-end :blank :indent
-"A comment occurring at the end of a group of declarations.
-Recycle javadoc comment code from the more general template set."
-----
-{{>:classdecl:javadoc-function-group-end}}
-----
-
-;; Some templates only show up in classdecls.
-context classdecl
-
-template group-comment-start :blank :indent
-"A comment occurring in front of a group of declarations.
-Recycle javadoc comment code from the more general template set."
-----
-{{>:classdecl:javadoc-function-group-start}}
-----
-
-template group-comment-end :blank :indent
-"A comment occurring at the end of a group of declarations.
-Recycle javadoc comment code from the more general template set."
-----
-{{>:classdecl:javadoc-function-group-end}}
-----
-
-;; end
+++ /dev/null
-;;; ede/templates/autoconf.srt --- Templates for autoconf used by EDE
-
-;; Copyright (C) 2010, 2012-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "autoconf-mode"
-set escape_start "{{"
-set escape_end "}}"
-set comment_start "#"
-set comment_prefix "#"
-set application "ede"
-
-context file
-
-template ede-empty :project
-"Start a new EDE generated configure.in/ac file."
-----
-{{comment_prefix}} Automatically Generated/Maintained {{FILE}} by EDE.
-{{comment_prefix}}
-{{comment_prefix}} YOU MAY MODIFY THIS FILE
-{{comment_prefix}} Hand made changes in some sections will be preserved
-{{comment_prefix}} by EDE when this file is updated.
-{{comment_prefix}}
-{{comment_prefix}} EDE is the Emacs Development Environment.
-{{comment_prefix}} https://cedet.sourceforge.net/ede.shtml
-{{comment_prefix}}
-{{comment_prefix}} Process this file with autoconf to produce a configure script
-
-AC_INIT({{PROJECT_NAME}}, {{PROJECT_VERSION}})
-AM_INIT_AUTOMAKE([{{PROGRAM}}], 0)
-AM_CONFIG_HEADER([config.h])
-
-{{comment_prefix}} End the configure script.
-AC_OUTPUT([Makefile], [date > stamp-h] )
-----
-
-
-;; end
+++ /dev/null
-;; ede-make.srt --- SRecode templates for Makefiles used by EDE.
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "makefile-mode"
-set escape_start "{{"
-set escape_end "}}"
-set application "ede"
-
-context file
-
-template ede-empty :file :project
-----
-# Automatically Generated {{FILE}} by EDE.
-# For use with: {{MAKETYPE}}
-# Relative File Name: {{PROJECT_FILENAME}}
-#
-# DO NOT MODIFY THIS FILE OR YOUR CHANGES MAY BE LOST.
-# EDE is the Emacs Development Environment.
-# https://cedet.sourceforge.net/ede.shtml
-#
-
-----
-
-context declaration
-
-template ede-vars
-----
-{{#VARIABLE}}
-{{NAME}}={{#VALUE}} {{VAL}}{{/VALUE}}{{/VARIABLE}}
-----
-
-;; Some extra templates for Arduino based Makefiles.
-;; Perhaps split this out someday in the future.
-context arduino
-
-template ede-empty :file
-----
-# Automatically Generated {{FILE}} by EDE.
-# For use with Make for an Arduino project.
-#
-# DO NOT MODIFY THIS FILE OR YOUR CHANGES MAY BE LOST.
-# EDE is the Emacs Development Environment.
-# https://cedet.sourceforge.net/ede.shtml
-
-ARDUINO_DIR = {{ARDUINO_HOME}}
-
-TARGET = {{TARGET}}
-ARDUINO_LIBS = {{ARDUINO_LIBS}}
-
-MCU = {{MCU}}
-F_CPU = {{F_CPU}}
-ARDUINO_PORT = {{PORT}}
-BOARD_TAG = {{BOARD}}
-
-AVRDUDE_ARD_BAUDRATE = {{AVRDUDE_ARD_BAUDRATE}}
-AVRDUDE_ARD_PROGRAMMER = {{AVRDUDE_ARD_PROGRAMMER}}
-
-include {{ARDUINO_MK}}
-
-# End of Makefile
-----
-
-
-;; end
+++ /dev/null
-;;; el.srt --- SRecode templates for Emacs Lisp mode
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-set escape_start "$"
-set escape_end "$"
-
-set mode "emacs-lisp-mode"
-
-set comment_start ";;;"
-set comment_prefix ";;"
-set comment_end ""
-
-set DOLLAR "$"
-
-context file
-
-template section-comment :blank
-"Insert a comment that separates sections of an Emacs Lisp file."
-----
-\f
-;;; $^$
-;;
-
-----
-bind "s"
-
-
-template empty :user :time :file
-"Insert a skeleton for an Emacs Lisp file."
-----
-$>:filecomment$
-
-;;; Commentary:
-;;
-;; $^$
-
-;;; Code:
-
-
-(provide '$FILE$)
-
-;;; $FILENAME$ ends here
-
-----
-
-prompt MODESYM "Major Mode Symbol (sans -mode): "
-prompt MODENAME "Nice Name of mode: " defaultmacro "MODESYM"
-prompt MODEEXTENSION "File name extension for mode: "
-
-template major-mode :file :blank :indent
-"Insert the framework needed for a major mode."
-sectiondictionary "FONTLOCK"
-set NAME macro "MODESYM" "-mode-font-lock-keywords"
-set DOC "Keywords for use with srecode macros and font-lock."
-sectiondictionary "MODEHOOK"
-set NAME macro "MODESYM" "-mode-hook"
-set DOC "Hook run when " macro "MODESYM" " starts."
-set GROUP macro "MODESYM" "-mode"
-set CUSTOMTYPE "'hook"
-sectiondictionary "MODEFCN"
-set NAME macro "MODESYM" "-mode"
-set DOC "Major-mode for " macro "MODESYM" "-mode buffers."
-set INTERACTIVE ""
-----
-$>:declaration:defgroup$
-
-$>:syntax-table$
-
-$<FONTLOCK:declaration:variable$
- '(
- )
-$/FONTLOCK$
-
-$>:declaration:keymap$
-
-$<MODEHOOK:declaration:variable-option$nil$/MODEHOOK$
-
-;;;###autoload
-$<MODEFCN:declaration:function$
- (interactive)
- (kill-all-local-variables)
- (setq major-mode '$MODESYM$-mode
- mode-name "$?MODENAME$"
- comment-start ";;"
- comment-end "")
- (set (make-local-variable 'comment-start-skip)
- "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
- (set-syntax-table $MODESYM$-mode-syntax-table)
- (use-local-map $MODESYM$-mode-map)
- (set (make-local-variable 'font-lock-defaults)
- '($MODESYM$-mode-font-lock-keywords
- nil ;; perform string/comment fontification
- nil ;; keywords are case sensitive.
- ;; This puts _ & - as a word constituent,
- ;; simplifying our keywords significantly
- ((?_ . "w") (?- . "w"))))
- (run-hooks '$MODESYM$-mode-hook)
-$/MODEFCN$
-
-;;;###autoload
-(add-to-list 'auto-mode-alist '("\\.$?MODEEXTENSION$$DOLLAR$" . $MODESYM$-mode))
-
-$<A:section-comment$Commands for $MODESYM$$/A$
-
-$<B:section-comment$Utils for $MODESYM$$/B$
-----
-
-template syntax-table
-"Create a syntax table."
-sectiondictionary "A"
-set NAME macro "?MODESYM" "-mode-syntax-table"
-set DOC "Syntax table used in " macro "?MODESYM" " buffers."
-----
-$<A:declaration:variable$
- (let ((table (make-syntax-table (standard-syntax-table))))
- (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
- (modify-syntax-entry ?\n ">" table) ;; Comment end
- (modify-syntax-entry ?\" "\"" table) ;; String
- (modify-syntax-entry ?\- "_" table) ;; Symbol
- (modify-syntax-entry ?\\ "\\" table) ;; Quote
- (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
- (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
- (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
-
- table)
-$/A$
-----
-
-
-context declaration
-
-template include :blank
-"Insert a require statement."
-----
-(require '$?NAME$)
-----
-bind "i"
-
-template include-protected :blank
-"Insert a require statement."
-----
-(condition-case nil
- (require '$?NAME$)
- (error nil))
-----
-
-prompt INTERACTIVE "Is this an interactive function? " default " (interactive)\n " read y-or-n-p
-prompt NAME "Name: " defaultmacro "PRENAME"
-
-template function :el :indent :blank
-"Insert a defun outline."
-----
-(defun $?NAME$ ($#ARGS$$NAME$$#NOTLAST$ $/NOTLAST$$/ARGS$)
- "$DOC$"
-$?INTERACTIVE$$^$
- )
-----
-bind "f"
-
-
-template variable :el :indent :blank
-"Inert a variable.
-DOC is optional."
-----
-(defvar $?NAME$ $^$
- "$DOC$")
-----
-bind "v"
-
-template variable-const :el :indent :blank
-"Inert a variable."
-----
-(defconst $?NAME$ $^$
- "$DOC$")
-----
-
-template variable-option :el :el-custom :indent :blank
-"Inert a variable created using defcustom."
-----
-(defcustom $?NAME$ $^$
- "*$DOC$"
- :group '$GROUP$
- :type $?CUSTOMTYPE$)
-----
-bind "o"
-
-template class :el :indent :blank
-"Insert a new class."
-----
-(defclass $?NAME$ ()
- (($?ARG1$ :initarg :$ARG1$
- :documentation
- "$^$")
- )
- "Class $NAME$ ")
-----
-bind "c"
-
-template class-tag :el :indent :blank
-"Insert a new class."
-----
-(defclass $?NAME$ ($#PARENTS$$NAME$ $/PARENTS$)
- ($^$
- )
- "Class $NAME$ ")
-----
-
-template method :el :ctxt :indent :blank
-"Insert a new method."
-----
-(defmethod $?NAME$ ((this $?PARENT$))
- "$DOC$"
- $^$
- )
-----
-bind "m"
-
-template method-tag :el :ctxt :indent :blank
-"Insert a new method for tag inserter."
-----
-(defmethod $NAME$ ($#ARGS$$#FIRST$($NAME$ $PARENT$)$/FIRST$$#NOTFIRST$ $NAME$$/NOTFIRST$$/ARGS$)
- "$DOC$"
- $^$
- )
-----
-
-prompt NAME "Method to Override: " defaultmacro "PRENAME" read mode-local-read-function
-prompt PARENT "Major Mode for binding: " defaultmacro "MODESYM"
-
-;; Note: PARENT is used for override methods and for classes. Handy!
-template modelocal :el :ctxt :indent :blank
-"Insert a new mode-local function."
-----
-(define-mode-local-override $?NAME$ $?PARENT$ ()
- "$DOC$"
- $^$)
-----
-bind "l"
-
-
-template defgroup :indent :blank
-"Create a custom group."
-----
-(defgroup $?MODESYM$-mode nil
- "$MODESYM$ group."
- :group 'languages)
-----
-bind "g"
-
-
-template keymap :indent :blank
-"Insert a keymap of some sort"
-----
-(defvar $?MODESYM$-mode-map
- (let ((km (make-sparse-keymap)))
- (define-key km "\C-c\C-c" '$MODESYM$-mode$^$)
- km)
- "Keymap used in `$MODESYM$-mode'.")
-----
-bind "k"
-
-
-context classdecl
-
-prompt NAME "Slot Name: "
-
-template variable-tag :indent :indent :blank
-"A field in a class."
-----
-($?NAME$ :initarg :$NAME$
- $#DEFAULTVALUE$:initform $VALUE$$/DEFAULTVALUE$
- :documentation
- "$DOC$")
-
-----
-
-template variable :indent :indent :blank
-"A field in a class."
-----
-($?NAME$ :initarg :$NAME$
- :initform nil
- :type list
- :documentation
- "$DOC$")
-
-----
-bind "s"
-
-
-
-;; end
+++ /dev/null
-;;; getset-cpp.srt --- SRecode templates for C++ class getter/setters.
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "c++-mode"
-set application "getset"
-
-context declaration
-
-template getset-in-class :tag :indent :blank
-----
-{{>A:classdecl:comment-function-group-start}}
-{{TYPE}} get{{NICENAME}}() const {
- return {{NAME}};
-}
-void set{{NICENAME}}({{TYPE}} {{NICENAME}}) {
- {{NAME}} = {{NICENAME}};
-}
-{{>A:classdecl:comment-function-group-end}}
-----
-
-template getset-field :blank :indent
-----
-{{?TYPE}} f{{?NAME}};
-----
-
-template getset-initializer :indent
-----
-f{{NAME}}(){{#NOTLAST}},{{/NOTLAST}}
-----
-
-;; end
+++ /dev/null
-;; java.srt
-
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "java-mode"
-set escape_start "{{"
-set escape_end "}}"
-
-context file
-
-set comment_start "/**"
-set comment_end " */"
-set comment_prefix " *"
-
-template empty :file :user :time :java :indent
-"Fill out an empty file."
-sectiondictionary "CLASSSECTION"
-set NAME macro "FILENAME_AS_CLASS"
-----
-{{>:filecomment}}
-
-package {{FILENAME_AS_PACKAGE}};
-
-{{>CLASSSECTION:declaration:class}}
-
-----
-bind "e"
-
-template empty-main :file :user :time :java :indent
-"Fill out an empty file with a class having a static main method"
-sectiondictionary "CLASSSECTION"
-set NAME macro "FILENAME_AS_CLASS"
-----
-{{>:filecomment}}
-
-package {{FILENAME_AS_PACKAGE}};
-
-{{<CLASSSECTION:declaration:class}}
-public static void main(String args[]) {
- {{^}}
-}
-{{/CLASSSECTION}}
-----
-bind "l"
-
-context declaration
-
-template import :blank :indent
-"Template to import a package."
-----
-{{>:declaration:include}}
-----
-bind "i"
-
-template class :blank :indent
-"Template to declare a variable."
-sectiondictionary "DOCSECTION"
-set NAME macro "NAME"
-----
-{{>DOCSECTION:declaration:javadoc-class}}
-public class {{?NAME}} {
-
- {{^}}
-
-} // {{NAME}}
-----
-bind "c"
-
-;;; Semantic Tag support
-;;
-template class-tag :indent :blank
-"Insert a Java class with the expectation of it being used by a tag inserter.
-Override this to affect applications, or the outer class structure for
-the user-facing template."
-----
-{{>:declaration:javadoc-class}}
-public class {{?NAME}} {{#PARENTS}}{{#FIRST}}extends {{/FIRST}}{{#NOTFIRST}}implements {{/NOTFIRST}}{{NAME}}{{/PARENTS}}
-{
- {{^}}
-};
-----
-
-template include :blank
-"An include statement."
-----
-import {{?NAME}};
-----
-
-context misc
-
-template arglist
-"Insert an argument list for a function.
-@todo - Support smart CR in a buffer for not too long lines."
-----
-({{#ARGS}}{{TYPE}} {{NAME}}{{#NOTLAST}},{{/NOTLAST}}{{/ARGS}})
-----
-
-context classdecl
-
-template function :indent :blank
-----
-public {{?TYPE}} {{?NAME}}{{>:misc:arglist}} {
-{{^}}
-}
-----
-bind "m"
-
-template variable :indent :blank
-"Insert a variable declaration."
-----
-{{?TYPE}} {{?NAME}}{{#HAVEDEFAULT}} = {{DEFAULT}}{{/HAVEDEFAULT}};
-----
-bind "v"
-
-;;; Java Doc Comments
-;;
-context classdecl
-
-prompt GROUPNAME "Name of declaration group: "
-
-template javadoc-function-group-start :indent :blank
-----
-/**
- * {{?GROUPNAME}}
- * @{
- */
-
-----
-
-template javadoc-function-group-end :indent :blank
-----
-/**
- * @}
- */
-
-----
-
-context declaration
-
-template javadoc-class :indent :blank :time :user :tag
-----
-/**
- * {{DOC}}{{^}}
- *
- * Created: {{DATE}}
- *
- * @author {{AUTHOR}}
- * @version
- * @since
- */
-----
-
-template javadoc-function :indent :blank :tag
-----
-/**
- * {{DOC}}{{^}}
- * {{#ARGS}}
- * @param {{?NAME}} - {{DOC}}{{/ARGS}}
- * @return {{TYPE}}{{#THROWS}}
- * @exception {{NAME}} - {{EXDOC}}{{/THROWS}}
- */
-----
-
-template javadoc-variable-same-line
-----
-/**< {{DOC}}{{^}} */
-----
-
-template javadoc-section-comment :blank :indent
-"Insert a comment that separates sections of an Emacs Lisp file."
-----
-\f
-/** {{?TITLE}}
- *
- * {{^}}
- */
-
-----
-
-
-;; end
+++ /dev/null
-;; make.srt
-
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "makefile-mode"
-set escape_start "{{"
-set escape_end "}}"
-set comment_start "#"
-set comment_prefix "#"
-set TAB "\t"
-
-context file
-
-template empty :file :user
-----
-{{>:filecomment}}
-
-all: {{^}}
-
-{{comment_start}} end
-----
-
-context declaration
-
-;; GNU Make has real functions you can define, but semantic uses
-;; 'function for rules. This is unfortunate, and should be fixed.
-template rule :blank
-----
-{{?NAME}}:
-{{TAB}}{{^}}
-----
-bind "r"
-
-template inferencerule :blank
-----
-%.{{?SRCEXTENSION}}: %.{{?DESTEXTENSION}}
-{{TAB}}{{^}}
-----
-bind "i"
-
-template phonyrule :blank
-----
-.PHONY {{?NAME}}
-{{NAME}}:
-{{TAB}}{{^}}
-----
-bind "p"
-
-
-template variable :blank
-"Insert a variable declaration."
-----
-{{?NAME}}:= {{^}}
-----
-bind "v"
-
-template include :blank
-----
-include {{?NAME}}
-----
-
-;; end
+++ /dev/null
-;; proj-test.srt --- SRecode template for testing project scoping.
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "srecode-template-mode"
-set escape_start "{{"
-set escape_end "}}"
-
-set application "tests"
-set project "/tmp/"
-
-context test
-
-template test-project
-"A template that only exists for files in /tmp."
-----
-Contents doesn't matter.
-----
-
-;; end
+++ /dev/null
-;;; template.srt --- Templates for Semantic Recoders
-
-;; Copyright (C) 2005, 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-set escape_start "$"
-set escape_end "$"
-set mode "srecode-template-mode"
-set priority "70"
-
-set comment_start ";;"
-set comment_end ""
-set comment_prefix ";;"
-
-set SEPARATOR "----"
-
-set DOLLAR "$"
-
-context file
-
-prompt MAJORMODE "Major Mode for templates: " read srecode-read-major-mode-name
-prompt START "Escape Start Characters: " default "{{"
-prompt END "Escape End Characters: " default "}}"
-
-template empty :file :user :time :srt
-"Insert a skeleton for a template file."
-----
-$>:filecomment$
-
-set mode "$?MAJORMODE$"
-set escape_start "$?START$"
-set escape_end "$?END$"
-
-context file
-
-$^$
-
-
-;; end
-----
-
-template mode-basics :srt
-"Fill out a full template including parts for basic new mode stuff."
-sectiondictionary "E"
-set NAME "empty :file :user :time"
-set DOC "Fill out an empty file."
-set KEY "e"
-sectiondictionary "C1"
-set NAME "declaration"
-sectiondictionary "DTF"
-set NAME "function :blank :indent"
-set DOC "Template to declare a function."
-set KEY "f"
-sectiondictionary "DTV"
-set NAME "variable :blank :indent"
-set DOC "Template to declare a variable."
-set KEY "v"
-sectiondictionary "PR"
-set NAME "NAME"
-set PROMPT "Name for declaration: "
-----
-$>:declaration:commentchars$
-
-$<E:declaration:function$
-$ESCAPE_START$>:filecomment$ESCAPE_END$
-$/E$
-
-$>C1:declaration:context$
-
-$>PR:declaration:prompt$
-
-$>DTF:declaration:function$
-$>DTV:declaration:function$
-----
-bind "m"
-
-
-context declaration
-
-prompt NAME "Name of new template: "
-prompt KEY "Key Binding: " read read-char
-
-template function :blank
-"Insert a template block for Srecoder templates."
-----
-template $?NAME$$#ARG$$NAME$$/ARG$
-"$DOC$"
-$SEPARATOR$
-$^$
-$SEPARATOR$
-bind "$?KEY$"
-----
-bind "f"
-
-prompt NAME "Name of new variable: "
-
-template variable :blank
-"Inert a variable."
-----
-set $?NAME$ "$^$"
-----
-bind "v"
-
-template prompt :blank
-"Insert a prompt."
-----
-prompt $?NAME$ "$?PROMPT$"
-----
-bind "p"
-
-template priority :blank
-"Insert a priority statement."
-----
-set priority $^$
-----
-
-template application :blank
-"Insert an application statement."
-----
-set application "$^$"
-----
-
-template context :blank
-"Insert a context statement."
-----
-context $NAME$
-----
-bind "c"
-
-template commentchars :blank
-"Insert the variables for handling comments."
-----
-set comment_start ""
-set comment_end ""
-set comment_prefix ""
-----
-
-context code
-
-prompt NAME "Name of variable: " read srecode-read-variable-name
-
-template variable :srt
-"Insert a variable with completion from the current file."
-----
-$ESCAPE_START$$?NAME$$ESCAPE_END$
-----
-bind "v"
-
-prompt NAME "Name of macro: "
-
-template ask :srt
-"Insert a prompting variable."
-----
-$ESCAPE_START$?$?NAME$$ESCAPE_END$
-----
-bind "a"
-
-template comment :srt
-----
-$ESCAPE_START$!$^$$ESCAPE_END$
-----
-bind "c"
-
-prompt TEMPLATE "Template to include: " read srecode-read-template-name
-
-template include :srt
-----
-$ESCAPE_START$>:$?TEMPLATE$$ESCAPE_END$
-----
-bind "i"
-
-template includewrap :srt
-----
-$ESCAPE_START$<:$?TEMPLATE$$ESCAPE_END$$^$$ESCAPE_START$/$NAME$$ESCAPE_END$
-----
-bind "w"
-
-template point :srt
-----
-$ESCAPE_START$^$ESCAPE_END$
-----
-bind "p"
-
-template section :srt
-"Insert a section, or looping construct."
-----
-$ESCAPE_START$#$?NAME$$ESCAPE_END$
-$^$
-$ESCAPE_START$/$NAME$$ESCAPE_END$
-----
-bind "s"
-
-template escape-start-quoted :srt
-"Escape Start"
-----
-$ESCAPE_START$ESCAPE_START$ESCAPE_END$
-----
-bind "q"
-
-template escape-end-quoted :srt
-"Escape Start"
-----
-$ESCAPE_START$ESCAPE_END$ESCAPE_END$
-----
-bind "e"
-
-
-;; end
+++ /dev/null
-;; test.srt --- SRecode templates for testing
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "srecode-template-mode"
-set escape_start "$"
-set escape_end "$"
-set application "tests"
-
-set UTESTVAR1 ".SRT VAR 1"
-;;
-;; These are for testing features of template files.
-;;
-context test
-
-template test :user
-----
-$! This is a comment in the template. $
-;; $AUTHOR$
-;; $AUTHOR:upcase$
-----
-
-template subs :blank
-----
-;; Before Loop
-$#LOOP$
-;; - loop stuff
-$/LOOP$
-;; After Loop
-----
-
-;; Before insertion
-;; After insertion
-
-template firstlast
-sectiondictionary "A"
-set MOOSE "FIRST"
-sectiondictionary "A"
-set MOOSE "MIDDLE"
-sectiondictionary "A"
-set MOOSE "LAST"
-----
-$#A$
-;; << -- $MOOSE$
-$#FIRST$;; I'm First$/FIRST$
-$#NOTFIRST$;; I'm Not First$/NOTFIRST$
-$#LAST$;; I'm Last$/LAST$
-$#NOTLAST$;; I'm Not Last$/NOTLAST$
-;; -- >>
-$/A$
-----
-
-
-template wrapsomething :region
-----
-;; Put this line in front:
-$REGIONTEXT$
-;; Put this line at the end:
-----
-
-template gapsomething :blank
-----
-### ALL ALONE ON A LINE ###
-----
-
-template inlinetext
-"Insert text that has no newlines"
-----
-*In the middle*
-----
-
-template includable :blank
-----
-;; An includable $COMMENT$ we could use.
-;; $INPUTNAME$$^$
-;; Text after a point inserter.
-----
-
-template wrapinclude-basic
-----
-$>WI1:includable$
-----
-
-template wrapinclude-around
-sectiondictionary "WI1"
-set INPUTNAME "[VAR]"
-----
-$<WI1:includable$Intermediate Comments$/WI1$
-----
-
-template complex-subdict
-sectiondictionary "A"
-set MYVAR1 "cow"
-set MYVAR2 "dog"
-set CPLX "I have a " macro "MYVAR1" " and a " macro "MYVAR2" "."
-----
-;; $#A$$CPLX$$/A$
-----
-
-template wrap-new-template
-sectiondictionary "NEWTMP"
-set DOC "A nice doc string goes here."
-----
-$<NEWTMP:declaration:function$Random text in the new template
-$/NEWTMP$
-----
-
-template column-data
-sectiondictionary "A"
-set MOOSE "FIRST"
-sectiondictionary "A"
-set MOOSE "VERY VERY LONG STRING THAT WILL BE CROPPED."
-sectiondictionary "A"
-set MOOSE "MIDDLE"
-sectiondictionary "A"
-set MOOSE "S"
-sectiondictionary "A"
-set MOOSE "LAST"
-----
-Table of Values:
-Left Justified | Right Justified$#A$
-$|MOOSE:20:right$ | $|MOOSE:20:left$$/A$
-----
-
-template custom-arg-handler :utest
-sectiondictionary "A"
-set MOOSE "why"
-----
-OUTSIDE SECTION: $UTESTVAR1$
-INSIDE SECTION: $#A$$UTESTVAR1$$/A$
-----
-
-template custom-arg-w-arg :utestwitharg
-----
-Value of xformed UTWA: $UTESTARGXFORM$
-----
-
-template custom-arg-w-subdict :utestwitharg
-sectiondictionary "UTLOOP"
-set NAME "item1"
-sectiondictionary "UTLOOP"
-set NAME "item2"
-sectiondictionary "UTLOOP"
-set NAME "item3"
-----
-All items here: $FOO_item1$ $FOO_item2$ $FOO_item3$
-----
-
-template nested-dictionary-syntax-flat
-section "TOP"
- show SUB
- set NAME "item1"
-end
-----
-$#TOP$$#SUB$sub $/SUB$$NAME$$/TOP$
-----
-
-template nested-dictionary-syntax-nesting
-section "TOP"
- show SHOW1
- set NAME "item1"
- section "SUB"
- show SHOW11
- set NAME "item11"
- end
- show SHOW2
- set NAME "item2"
- section "SUB"
- show SHOW21
- set NAME "item21"
- end
- show SHOW3
- set NAME "item3"
- section "SUB"
- show SHOW11
- set NAME "item31"
- section "SUB"
- show SHOW311
- set NAME "item311"
- end
- section "SUB"
- show SHOW321
- set NAME "item321"
- end
- end
-end
-----
-$#TOP$$#SUB$$NAME$$#SUB$-$NAME$$/SUB$ $/SUB$$/TOP$
-----
-
-template nested-dictionary-syntax-mixed
-section "TOP"
- show SUB
- set NAME "item1"
-end
-sectiondictionary "SECTION"
-show SUB
-set NAME "item2"
-----
-$#TOP$$NAME$$/TOP$ $#SECTION$$NAME$$/SECTION$
-----
-
-;; end
+++ /dev/null
-;; texi.srt --- SRecode templates for Texinfo
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "texinfo-mode"
-
-set escape_start "$"
-set escape_end "$"
-set DOLLAR "$"
-
-context file
-
-prompt NAME "Name of manual: "
-
-template empty :file :user :time
-"Fill a new texinfo file with some baseline stuff."
-----
-\input texinfo @c -*-texinfo-*-
-@c %**start of header
-@setfilename $FILE$.info
-@set TITLE $?NAME$
-@set AUTHOR $?AUTHOR$
-@settitle @value{TITLE}
-@c %**end of header
-
-@ifinfo
-@format
-START-INFO-DIR-ENTRY
-* $FILE$: ($FILE$). $NAME$
-END-INFO-DIR-ENTRY
-@end format
-@end ifinfo
-
-@titlepage
-@sp 10
-@center @titlefont{$FILE$}
-@vskip 0pt plus 1 fill
-Copyright @copyright{} $YEAR$ $AUTHOR$
-@end titlepage
-
-@node Top
-@top @value{TITLE}
-
-$^$
-
-@menu
-* Index::
-@end menu
-
-
-
-
-@node Index
-@chapter Index
-
-@contents
-
-@bye
-----
-
-prompt NAME "Name of item: "
-
-context declaration
-
-;; Note to self: It would be cool to replace the junk in
-;; semantic/document.el with macros from here.
-template function :blank :texitag
-"Import some function tag into texinfo."
-----
-
-@defun $NAME$$#ARGS$ $NAME$$/ARGS$
-@anchor{$NAME$}
-$TAGDOC$
-@end defun
-
-----
-bind "f"
-
-template function-command :blank :texitag
-"Import some function tag into texinfo."
-----
-
-@deffn Command $NAME$$#ARGS$ $NAME$$/ARGS$
-@anchor{$NAME$}
-$TAGDOC$
-@end deffn
-
-----
-bind "f"
-
-
-template variable :blank :texitag
-"Import some variable tag into texinfo"
-----
-
-@defvar $NAME$$#ARGS$ $NAME$$/ARGS$
-@anchor{$NAME$}
-$TAGDOC$
-@end defvar
-
-----
-bind "v"
-
-prompt NAME "Name of node: "
-
-template node :texi
-"Insert a node right about here."
-----
-
-@node $?NAME$
-@$?LEVEL$ $NAME$
-
-$^$
-
-----
-bind "n"
-
-template subnode :texi
-"Insert a node right about here."
-----
-
-@node $?NAME$
-@$?NEXTLEVEL$ $NAME$
-
-$^$
-
-----
-bind "n"
-
-
-template menu :blank
-"Menu items for texinfo."
-----
-
-@menu
-$^$
-@end menu
-
-----
-bind "m"
-
-prompt NAME "Menu item: "
-
-template menuitem :blank
-"Insert a menu item."
-----
-* $?NAME$:: $^$
-----
-
-
-;; end
+++ /dev/null
-;; wisent.srt --- SRecode templates for Emacs/WISENT grammar files.
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-set mode "wisent-grammar-mode"
-set comment_start ";;"
-set comment_prefix ";;"
-set comment_end ""
-
-context file
-
-template empty :file :user :time
-"Insert a skeleton for a grammar file."
-----
-{{>:filecomment}}
-
-;;; Commentary:
-;;
-;; Parser for {{?TARGETMODE}} mode
-
-%languagemode {{TARGETMODE}}-mode
-%parsetable wisent-{{TARGETMODE}}-parser-tables
-%keywordtable wisent-{{TARGETMODE}}-keywords
-%tokentable wisent-{{TARGETMODE}}-tokens
-%languagemode {{TARGETMODE}}-mode
-%setupfunction wisent-{{TARGETMODE}}-default-setup
-
-%start goal
-
-;;; KEYWORDS
-%type <keyword>
-
-%%
-
-goal
- : {{^}}
- ;
-
-%%
-(define-lex wisent-{{TARGETMODE}}-lexer
- "Lexical analyzer to handle {{TARGETMODE}} buffers."
- ;; semantic-lex-newline
- semantic-lex-ignore-whitespace
- semantic-lex-ignore-newline
- semantic-lex-ignore-comments
-
- semantic-lex-default-action
- )
-
-;; {{FILENAME}} ends here
-----
-
-context declaration
-
-template function
-----
-{{?NAME}}
- : {{^}}
- ;
-----
-bind "f"
-
-template keyword
-----
-%keyword {{?NAME:upcase}} "{{NAME:downcase}}"
-%put {{NAME:upcase}} summary "{{NAME}} {{^}}"
-----
-bind "k"
-
-template token
-----
-%type <{{?LEXTOKEN}}>
-%token <{{LEXTOKEN}}> {{LEXTOKEN}}
-----
-bind "t"
-
-;; end
# to speed things up. The org files are used to convert org files to
# texi files.
MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \
- ./cedet/semantic/db.el ./emacs-lisp/cconv.el \
+ ./emacs-lisp/cconv.el \
./international/ja-dic-cnv.el \
./org/ox.el ./org/ox-texinfo.el ./org/org-macro.el ./org/org-element.el \
./org/oc.el ./org/ol.el ./emacs-lisp/cl-lib.el
## since many share basenames with files in language/.
SUBDIRS_FINDER = $(filter-out ${srcdir}/leim%,${SUBDIRS_ALMOST})
## All subdirectories in which we might want to create subdirs.el.
-SUBDIRS_SUBDIRS = $(filter-out ${srcdir}/cedet% ${srcdir}/leim%,${SUBDIRS})
+SUBDIRS_SUBDIRS = $(filter-out ${srcdir}/leim%,${SUBDIRS})
# cus-load, finder-inf and autoloads are not explicitly requested by
# anything, so we add them here to make sure they get built.
fi; \
done
-.PHONY: gen-lisp leim semantic
+.PHONY: gen-lisp leim
## make -C ../admin/unidata all should be here, but that would race
## with ../src. See comments above for loaddefs.
-gen-lisp: leim semantic
+gen-lisp: leim
# (re)compile titdic-cnv before recursing into `leim` since its used to
# generate some of the Quail source files from tables.
leim: $(lisp)/international/titdic-cnv.elc
$(MAKE) -C ../leim all EMACS="$(EMACS)"
-semantic:
- $(MAKE) -C ../admin/grammars all EMACS="$(EMACS:.%=../.%)"
-
# Compile all Lisp files, but don't recompile those that are up to
# date. Some .el files don't get compiled because they set the
# local variable no-byte-compile.
+++ /dev/null
-2015-02-22 Paul Eggert <eggert@cs.ucla.edu>
-
- Spelling fixes
- * semantic/doc.el (semantic-documentation-comment-preceding-tag):
- Rename from semantic-documentation-comment-preceeding-tag. All
- uses changed. Leave an obsolete alias behind.
-
-2015-02-16 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/db-el.el (semanticdb-elisp-sym->tag): Fix copy&paste error
- (semanticdb-project-database => sym). Avoid eieio--class-public-a
- when possible.
-
-2015-02-04 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Use cl-generic instead of EIEIO's defgeneric/defmethod.
- * **/*.el: Mechanically replace all calls to defmethod/defgeneric by
- calls to cl-defmethod/cl-defgeneric.
- * srecode/table.el:
- * srecode/fields.el:
- * srecode/dictionary.el:
- * srecode/compile.el:
- * semantic/debug.el:
- * semantic/db-ref.el:
- * ede/base.el:
- * ede/auto.el:
- * ede.el: Require `cl-generic'.
-
-2015-01-07 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Don't use <class> as a variable and don't assume that <class>-list-p is
- automatically defined.
-
- * ede/speedbar.el (ede-speedbar-compile-line)
- (ede-speedbar-get-top-project-for-line):
- * ede.el (ede-buffer-belongs-to-target-p)
- (ede-buffer-belongs-to-project-p, ede-build-forms-menu)
- (ede-add-project-to-global-list):
- * semantic/db-typecache.el (semanticdb-get-typecache):
- * semantic/db-file.el (semanticdb-load-database):
- * semantic/db-el.el (semanticdb-elisp-sym->tag):
- * semantic/db-ebrowse.el (semanticdb-ebrowse-load-helper):
- * ede/project-am.el (project-am-preferred-target-type):
- * ede/proj.el (ede-proj-load):
- * ede/custom.el (ede-customize-current-target, ede-customize-target):
- * semantic/ede-grammar.el ("semantic grammar"):
- * semantic/scope.el (semantic-scope-reset-cache)
- (semantic-calculate-scope):
- * srecode/map.el (srecode-map-update-map):
- * srecode/insert.el (srecode-insert-show-error-report)
- (srecode-insert-method, srecode-insert-include-lookup)
- (srecode-insert-method):
- * srecode/fields.el (srecode-active-template-region):
- * srecode/compile.el (srecode-flush-active-templates)
- (srecode-compile-inserter): Don't use <class> as a variable.
- Use `oref-default' for class slots.
-
- * semantic/grammar.el (semantic-grammar-eldoc-last-data): New var.
- (semantic-grammar-eldoc-get-macro-docstring): Use it instead of
- eldoc-last-data.
- * semantic/fw.el (semantic-exit-on-input): Use `declare'.
- (semantic-throw-on-input): Use `with-current-buffer'.
- * semantic/db.el (semanticdb-abstract-table-list): Define if not
- pre-defined.
- * semantic/db-find.el (semanticdb-find-tags-collector):
- Use save-current-buffer.
- (semanticdb-find-tags-collector): Don't use <class> as a variable.
- * semantic/complete.el (semantic-complete-active-default)
- (semantic-complete-current-matched-tag): Declare.
- (semantic-complete-inline-custom-type): Don't use <class> as a variable.
- * semantic/bovine/make.el (semantic-analyze-possible-completions):
- Use with-current-buffer.
- * semantic.el (semantic-parser-warnings): Declare.
- * ede/base.el (ede-target-list): Define if not pre-defined.
- (ede-with-projectfile): Prefer find-file-noselect over
- save-window-excursion.
-
-2014-12-22 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * srecode/srt-mode.el (srecode-macro-help): Use eieio-class-children.
-
- * semantic/db.el (semanticdb-cache-get): Prefer eieio-object-class over
- eieio--object-class.
-
- * semantic/db-el.el (semanticdb-elisp-sym->tag): Prefer find-class over
- class-v.
-
- * ede/generic.el (ede-find-target): Prefer \` and \' to ^ and $.
-
-2014-12-14 Dmitry Gutov <dgutov@yandex.ru>
-
- * semantic.el (semantic-analyze-completion-at-point-function)
- (semantic-analyze-notc-completion-at-point-function)
- (semantic-analyze-nolongprefix-completion-at-point-function):
- Do nothing if the current buffer is not using Semantic (bug#19077).
-
-2014-12-14 Paul Eggert <eggert@cs.ucla.edu>
-
- * semantic/lex-spp.el (semantic-lex-spp-analyzer-do-replace):
- Rename from semantic-lex-spp-anlyzer-do-replace.
-
-2014-12-08 Matt Curtis <matt.r.curtis@gmail.com> (tiny change)
-
- * pulse.el (pulse-momentary-highlight-one-line): Respect the POINT
- argument (bug#17260).
-
-2014-11-09 Eric Ludlam <zappo@gnu.org>
-
- * semantic.el (semantic-mode): Add/remove 3
- completion-at-point-functions.
- (semantic-completion-at-point-function): Remove.
- (semantic-analyze-completion-at-point-function)
- (semantic-analyze-notc-completion-at-point-function)
- (semantic-analyze-nolongprefix-completion-at-point-function):
- New completion at point functions.
-
- * semantic/doc.el (semantic-doc-snarf-comment-for-tag): Fix case
- when comment-end is empty string.
-
- * semantic/debug.el
- (semantic-debug-parser-debugger-source): New buffer local
- variable.
- (semantic-debug-interface): Add 'nil' initform to overlays.
- (semantic-debug-mode): Remove read-only tags from buffers on exit.
- (semantic-debug): Add autoload cookie. Force the language
- specific debugger to load.
-
- * semantic/db.el (generic::semanticdb-full-filename): New generic
- method to allow this method to be used on buffer names via an
- associated database.
-
- * semantic/symref.el
- (semantic-symref-cleanup-recent-buffers-fcn): When cleaning up
- buffers, don't clean up buffers that are being used (i.e., in a
- window) when the hook fires.
- (semantic-symref-recently-opened-buffers): New tracking variable.
- (semantic-symref-cleanup-recent-buffers-fcn): New hook fcn.
- (semantic-symref-result-get-tags): Move logic into
- `semantic-symref-hit-to-tag-via-buffer', and cleanup buffers via
- the symref cleanup function in post-command-hook.
- (semantic-symref-hit-to-tag-via-buffer): Logic that used to be
- from above.
- (semantic-symref-hit-to-tag-via-db): New.
-
- * semantic/analyze.el:
- (semantic-analyze-find-tag-sequence-default): If first entry in
- sequence is the only one, apply tagclass filter.
- (semantic-analyze-princ-sequence): Show slot even if empty.
- (semantic-analyze-find-tag-sequence)
- (semantic-analyze-find-tag-sequence-default): Add flags argument.
- Add support for forcing the final entry of the sequence to be of
- class variable.
- (semantic-analyze-find-tag): Fix bug where input class filter was
- ignored if there was a typecache match.
- (semantic-analyze-current-context-default): For assignments, the
- assignee now must be of class variable.
-
- * semantic/analyze/complete.el
- (semantic-analyze-possible-completions-default):
- Add 'no-longprefix' flag. When used, the prefix and prefixtypes are
- shortened to just the last symbol.
-
- * semantic/bovine/c.el (semantic-c-do-lex-if): Catch errors from
- 'hideif', and push to the parser warning stack.
- (semantic-lex-cpp-define): When a comment is at the end of a
- macro, do not subtract an extra 1 from the found position.
- Fixes bug with: #define foo (a)/**/ adding an extra ')' to the stream.
-
- * semantic/bovine/scm.el (semantic-lex-scheme-symbol):
- Allow symbols to be one char long.
-
- * semantic/bovine/grammar.el
- (bovine-grammar-calculate-source-on-path): New.
- (bovine-grammar-setupcode-builder): Use it.
-
- * ede.el (ede/detect): New require.
- (ede-version): Bump version
- (ede-initialize-state-current-buffer): Use new
- `ede-detect-directory-for-project' to detect projects first
- instead of depending on currente dir only.
- (ede-delete-project-from-global-list): New.
- (ede-flush-deleted-projects): Use above.
- (ede-check-project-query-fcn): New variable
- (ede-check-project-directory): Use above when querying the user.
- Added to support unit testing of this security measure.
- (ede-initialize-state-current-buffer):
- Use `ede-directory-project-cons' instead of the -detect- fcn to take
- advantage of the cache. Pass found project into
- `ede-load-project-file'.
- (ede-load-project-file): Add new input DETECTIN.
- (ede-rescan-toplevel): Get the proj root a better way.
- (ede-load-project-file): Return the loaded object. When asking
- for existing project, ask for an exact match.
- (ede-initialize-state-current-buffer): Simplify some conditional
- logic.
- (ede-load-project-file): Simplify conditional logic.
- (ede-global-list-sanity-check): New Testing fcn.
- (ede-parent-project): Replace old code with call to faster
- `ede-find-subproject-for-directory'.
- (ede-load-project-file):
- Use `ede-directory-get-toplevel-open-project' instead of above
- deleted. Rename "pfc" to "autoloader".
- Use `ede-directory-project-cons' to detect a project. Delete no
- project found case where we search up the tree.
-
- * ede/auto.el (ede-project-autoload): Fix doc typo.
- Add `:root-only' slot.
- (ede-auto-load-project): Doc update: warn to not use.
- (ede-dir-to-projectfile): Delete.
- (ede-project-autoload-dirmatch): Add subdir-only slot.
- Make configdatastash unbound by default.
- (ede-do-dirmatch): If subdir-only is true, then don't allow exact
- matches. Account for configdatastash as unbound. Assume value of
- nil means no tool installed. Make sure loaded path matches from
- beginning. Stash the regexp, not the raw string.
- (ede-project-class-files): Note that makefile and automake are not
- root only.
- (ede-auto-detect-in-dir): New (for use with `ede/detect.el').
- (ede-project-dirmatch-p): Delete.
- (ede-project-root-directory): Remove body, return nil.
- (ede-project-autoload): :proj-root-dirmatch can be null & doc fix.
- (ede-auto-detect-in-dir): If there is no :proj-file, check for a
- dirmatch.
-
- * ede/generic.el (ede/config): Replace require of ede.
- (ede-generic-new-autoloader): Generic projects are now safe by
- default. Note this is NOT a root only project.
- (project-rescan, ede-project-root, ede-generic-target-java)
- (ede-java-classpath, ede-find-subproject-for-directory): New.
- (ede-enable-generic-projects): Add new autoloaders for git, bzr,
- hg, sv, CVS.
- (ede-generic-vc-project)
- (ede-generic-vc-project::ede-generic-setup-configuration): New.
- (ede-generic-config): Remove slots: c-include-path,
- c-preprocessor-table, c-preprocessor-files, classpath,
- build-command, debug-command, run command. Inherit from
- ede-extra-config-build, ede-extra-config-program.
- Make run-command :value match :custom so only strings are accepted.
- Add some more :group slot specifiers.
- (ede-generic-project): Add mixins `ede-project-with-config-c' and
- `ede-project-with-config-java'. Inherit from
- `ede-project-with-config-build',
- `ede-project-with-config-program'. Subclass
- `ede-project-with-config'. Remove duplication from new baseclass.
- (ede-generic-target): Inherit from `ede-target-with-config-build',
- `ede-target-with-config-program'. Subclass `ede-target-with-config'.
- (ede-generic-target-c-cpp): Add mixin `ede-target-with-config-c'.
- (ede-generic-target-java): Add mixin `ede-target-with-config-java'.
- (ede-preprocessor-map, ede-system-include-path)
- (edejava-classpath): Delete, moved to config.el.
- (project-compile-project, project-compile-target)
- (project-debug-target, project-run-target): Delete.
- (ede-generic-get-configuration, ede-generic-setup-configuration)
- (ede-commit-project, project-rescan)
- (ede-generic-project::ede-customize)
- (ede-generic-target::ede-customize)
- (ede-generic-config::eieio-done-customizing)
- (ede-generic-config::ede-commit): Delete. Subsumed by new
- baseclass.
- (ede-preprocessor-map, ede-system-include-path)
- (project-debug-target, project-run-target): Call new
- `ede-config-get-configuration' instead of old version.
- (ede-generic-load): Do not add to global list here.
-
- * ede/files.el (ede-find-project-root)
- (ede-files-find-existing)
- (ede-directory-get-toplevel-open-project-new): Delete.
- (ede-project-root-directory): Use `ede-project-root' first.
- (ede-project-directory-remove-hash)
- (ede--directory-project-from-hash)
- (ede--directory-project-add-description-to-hash): Rename to make
- internal symbols (via --). Expand input dir first.
- (ede-directory-project-p): Doc fix (note obsoleted.)
- (ede-toplevel-project-or-nil): Alias to `ede-toplevel-project'.
- (ede-toplevel-project): Doc Fix. Delete commented out old code.
- Simplify returning result from ede-detect-directory-for-project.
- (ede-directory-get-open-project): Support when
- inodes are disabled. If disabled to str compare on root project.
- (ede-directory-get-toplevel-open-project): Enabled nested
- projects. When doing directory name matching, save the 'short'
- version of an answer (non-exact match) and eventually select the
- shortest answer at the end. Expand the filename of tested
- projects. Better support for when inodes are disabled.
- Add 'exact' option so that it will return a project that is an exact
- match.
- (ede-find-subproject-for-directory): Small optimization to run
- `file-truename' less often.
- (ede-directory-project-p): Move content, then use
- `ede-directory-project-cons'.
- Use `ede-detect-directory-for-project', replacing old detection loop.
- (ede-directory-project-cons): New, from above.
- (ede-toplevel-project): Toss old scanning code.
- Use `ede-detect-directory-for-project' instead.
- (ede-directory-get-toplevel-open-project-new): New.
-
- * ede/linux.el (ede-linux-project-root): Delete.
- (ede-project-autoload): Remove dirmatch entry - it is no longer
- needed.
-
- * ede/proj.el (project-rescan): Replace direct
- manipulation of `ede-projects' with equivalent and better
- functions.
- (ede-proj-load): Replace call to test if dir has project to
- explicitly ask filesystem if Project.ede is there.
-
- * ede/config.el:
- * ede/detect.el: New files.
-
- * ede/project-am.el (project-run-target): Add "./" to program to
- run for systems where '.' isn't in PATH.
- (project-am-load): Remove old code regarding `ede-constructing'.
- Just read in the makefiles.
-
- * ede/linux.el (ede-linux-load): Do not add to global list here.
- Don't check for existing anymore.
- (project-rescan): New.
- (ede-linux-project-list, ede-linux-file-existing): Delete.
- (ede-linux-project-root): Delete body. Need symbol for autoloads
- for now.
- (ede-linux-project): No longer instance tracker.
- (ede-project-autoload): Don't provide :proj-root
-
- * ede/emacs.el (ede-emacs-load): Do not add project to global list
- here. Don't look for existing first.
- (ede-project-autoload): Remove dirmatch entry - it is no longer
- needed. Don't provide proj-root anymore.
- (ede-emacs-project-list, ede-emacs-file-existing): Delete.
- (ede-emacs-project-root): Remove body (need symbol for loaddefs
- still).
- (ede-emacs-project): Do not instance track anymore.
-
- * ede/cpp-root.el (initialize-instance): Remove commented code.
- Add note about why we are adding the project to the master list.
- Make sure if we are replacing a prev version, remove from global
- list.
- (ede-cpp-root-file-existing)
- (ede-cpp-root-project-file-for-dir)
- (ede-cpp-root-count, ede-cpp-root-project-root, ede-cpp-root-load)
- (ede-project-autoload cpp-root): Delete.
- (ede-project-root-directory): Return :directory instead of
- calculating from :file.
- (project-rescan): New.
-
- * ede/base.el (ede-toplevel): Only use buffer cached value if
- subproj not passed in.
-
- * srecode/java.el (srecode-semantic-handle-:java): Fix case when
- an EDE project didn't support java paths.
-
-2014-11-09 David Engster <dengste@eml.cc>
-
- * ede/proj-elisp.el (ede-proj-target-elisp::ede-proj-tweak-autoconf):
- Kill buffer after saving modified elisp-comp script, so as to avoid
- "file has changed on disk; really edit the buffer" questions when
- script gets rewritten.
-
-2014-10-29 Paul Eggert <eggert@cs.ucla.edu>
-
- Simplify use of current-time and friends.
- * srecode/args.el (srecode-semantic-handle-:time):
- Don't call current-time twice to get the current time stamp,
- as this can lead to inconsistent results.
-
-2014-10-24 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/complete.el: Require semantic/db-find.
-
-2014-10-20 Glenn Morris <rgm@gnu.org>
-
- * Merge in all changes up to 24.4 release.
-
-2014-10-15 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/wisent/comp.el (wisent-defcontext): Move declarations
- outside of eval-when-compile. Use `declare'.
- (wisent-with-context): Add `defvar' declarations in case this macro is
- used in a file compiled with lexical-binding.
- (wisent-semantic-action-expand-body): Avoid add-to-list on local var.
-
-2014-09-22 David Engster <deng@randomsample.de>
-
- * ede/emacs.el (ede-emacs-version): Do not call 'egrep' to
- determine Emacs version (it was dead code anyway). Make sure that
- configure.ac or configure.in exist. (Bug#18476)
-
-2014-06-19 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/ia.el (semantic-ia-complete-symbol-menu): Use posn-at-point
- instead of senator-completion-menu-point-as-event; un-comment, tho keep
- the "no smart completion" fallback commented since it still doesn't
- work.
-
-2014-05-01 Glenn Morris <rgm@gnu.org>
-
- * ede.el (ede-project-directories, ede-check-project-directory):
- * semantic/ia-sb.el (semantic-ia-sb-show-doc):
- * semantic/tag.el (semantic-tag-in-buffer-p):
- * semantic/bovine/c.el (semantic-tag-abstract-p):
- Doc fixes (replace `iff').
-
-2014-04-01 Glenn Morris <rgm@gnu.org>
-
- * ede/emacs.el (ede-emacs-version): Update AC_INIT regexp. (Bug#17160)
-
-2014-03-29 Glenn Morris <rgm@gnu.org>
-
- * ede/dired.el (ede-dired-minor-mode): Add autoload cookie.
- (generated-autoload-file, generated-autoload-load-name):
- Set file-local values.
- * ede.el: Load ede/loaddefs at compile time too.
- (ede-dired-minor-mode): Remove hand-written autoload.
-
-2014-03-04 Glenn Morris <rgm@gnu.org>
-
- * semantic/util.el (semantic-complete-symbol):
- Replace use of obsolete argument of display-completion-list.
-
-2014-02-03 Glenn Morris <rgm@gnu.org>
-
- * semantic/senator.el (senator-copy-tag-to-register):
- Use register-read-with-preview, if available.
-
-2014-01-13 Eric Ludlam <zappo@gnu.org>
-
- * semantic/analyze/refs.el (semantic-analyze-refs-impl): Fix typo
- in a doc string.
-
- * semantic/ia.el (semantic-ia-complete-symbol): Ignore case if
- prefix is all lower case.
- (semantic-ia-fast-jump): Push mark before jumping to an include file.
-
- * semantic/complete.el (semantic-displayor-point-position):
- Calculate if the toolbar is on the left when calculating point
- position.
-
-2014-01-08 Paul Eggert <eggert@cs.ucla.edu>
-
- Spelling fixes.
- * semantic/decorate/include.el (semantic-decoration-mouse-3):
- Rename from semantic-decoratiton-mouse-3. All uses changed.
-
-2013-12-28 Glenn Morris <rgm@gnu.org>
-
- * ede/linux.el (project-linux-build-directory-default)
- (project-linux-architecture-default): Fix custom types. Add version.
-
-2013-12-12 David Engster <deng@randomsample.de>
-
- * semantic/analyze.el (semantic-analyze-find-tag-sequence-default):
- Always add scope to the local miniscope for each type. Otherwise,
- structure tags are not analyzed correctly. Also, always search
- the extended miniscope even when not dealing with types.
-
- * semantic/ctxt.el (semantic-get-local-variables-default):
- Also try to parse local variables for buffers which are currently
- marked as unparsable. Otherwise, it is often impossible to
- complete local variables.
-
- * semantic/scope.el (semantic-analyze-scoped-types-default): If we
- cannot find a type in the typecache, also look into the types
- we already found. This is necessary since in C++, a 'using
- namespace' can be dependent on a previous one.
- (semantic-completable-tags-from-type): When creating the list of
- completable types, pull in types which are referenced through
- 'using' statements, and also preserve their filenames.
-
- * semantic/bovine/c.el (semantic/analyze/refs): Require.
- (semantic-analyze-tag-references): New override. Mainly copied
- from the default implementation, but if nothing could be found (or
- just the tag itself), drop all namespaces from the scope and
- search again. This is necessary for implementations which are
- defined outside of the namespace and only pull those in through
- 'using' statements.
- (semantic-ctxt-scoped-types): Go through all tags around point and
- search them for using statements. In the case for using
- statements outside of function scope, append them in the correct
- order instead of using 'cons'. This is important since using
- statements may depend on previous ones.
- (semantic-expand-c-tag-namelist): Do not try to parse struct
- definitions as default values. The grammar parser seems to return
- the point positions slightly differently (as a cons instead of a
- list). Also, set parent for typedefs to 'nil'. It does not
- really make sense to set a parent class for typedefs, and it can
- also lead to endless loops when calculating scope.
- (semantic-c-reconstitute-token): Change handling of function
- pointers; instead of seeing them as variables, handle them as
- functions with a 'function-pointer' attribute. Also, correctly
- deal with function pointers as function arguments.
- (semantic-c-reconstitute-function-arglist): New function to parse
- function pointers inside an argument list.
- (semantic-format-tag-name): Use 'function-pointer' attribute
- instead of the old 'functionpointer-flag'.
- (semantic-cpp-lexer): Use new `semantic-lex-spp-paren-or-list'.
-
- * semantic/bovine/gcc.el (semantic-gcc-setup): Add 'features.h' to
- the list of files whose preprocessor symbols are included.
- This pulls in things like __USE_POSIX and similar.
-
- * semantic/format.el (semantic-format-tag-prototype-default):
- Display default values if available.
-
- * semantic/analyze/refs.el (semantic-analyze-refs-impl)
- (semantic-analyze-refs-proto): Add 'default-value' as ignorable in
- call to `semantic-tag-similar-p'.
-
- * semantic/db-mode.el (semanticdb-semantic-init-hook-fcn):
- Always set buffer for `semanticdb-current-table'.
-
- * semantic/db.el (semanticdb-table::semanticdb-refresh-table):
- The previous change turned up a bug in this method. Since the current
- table now correctly has a buffer set, the first clause in the
- `cond' would be taken, but there was a `save-excursion' missing.
-
- * semantic/lex-spp.el (semantic-c-end-of-macro): Declare.
- (semantic-lex-spp-token-macro-to-macro-stream): Deal with macros
- which open/close a scope. For this, leave an overlay if we
- encounter a single open paren and return a semantic-list in the
- lexer. When this list gets expanded, retrieve the old position
- from the overlay. See the comments in the function for further
- details.
- (semantic-lex-spp-find-closing-macro): New function to find the
- next macro which closes scope (i.e., has a closing paren).
- (semantic-lex-spp-replace-or-symbol-or-keyword): Go to end of
- closing macro if necessary.
- (semantic-lex-spp-paren-or-list): New lexer to specially deal with
- parens in macro definitions.
-
- * semantic/decorate/mode.el (semantic-decoration-mode): Do not
- decorate available tags immediately but in an idle timer, since
- EDE will usually not be activated yet, which will make it
- impossible to find project includes.
-
- * semantic/decorate/include.el
- (semantic-decoration-on-includes-highlight-default):
- Remove 'unloaded' from throttle when decorating includes, otherwise all
- would be loaded. Rename 'table' to 'currenttable' to make things
- clearer.
-
- * ede/linux.el (cl): Require during compile.
-
-2013-12-12 Lluís Vilanova <xscript@gmx.net>
-
- * ede/linux.el (project-linux-build-directory-default)
- (project-linux-architecture-default): Add customizable variables.
- (ede-linux-project): Add additional slots to track Linux-specific
- information (out-of-tree build directory and selected
- architecture).
- (ede-linux--get-build-directory, ede-linux--get-archs)
- (ede-linux--detect-architecture, ede-linux--get-architecture)
- (ede-linux--include-path): Add function to detect Linux-specific
- information.
- (ede-linux-load): Set new Linux-specific information when creating
- a project.
- (ede-expand-filename-impl): Use new and more accurate include
- information.
-
-2013-12-12 Eric Ludlam <zappo@gnu.org>
-
- * semantic/scope.el (semantic-calculate-scope): Return a clone of
- the scopecache, so that everyone is working with its own (shallow)
- copy. Otherwise, if one caller is resetting the scope, it would
- be reset for all others working with the scope cache as well.
-
-2013-12-12 Alex Ott <alexott@gmail.com>
-
- * ede/generic.el (project-run-target): Remove incorrect require.
-
- * semantic/format.el (semantic-format-tag-prototype-default):
- Use concat only for strings.
-
-2013-11-30 Glenn Morris <rgm@gnu.org>
-
- Stop keeping (most) generated cedet grammar files in the repository.
- * semantic/bovine/grammar.el (bovine--make-parser-1):
- New function, split from bovine-make-parsers.
- (bovine-make-parsers): Use bovine--make-parser-1.
- (bovine-batch-make-parser): New function.
- * semantic/wisent/grammar.el (wisent--make-parser-1):
- New function, split from wisent-make-parsers.
- (wisent-make-parsers): Use wisent--make-parser-1.
- (wisent-batch-make-parser): New function.
- * semantic/db.el (semanticdb-save-all-db):
- Avoid prompting in batch mode.
- * semantic/grammar.el (semantic-grammar-footer-template):
- Disable version-control and autoloads in the output.
- (semantic-grammar-create-package):
- Add option to return nil if output is up-to-date.
- * semantic/bovine/c-by.el, semantic/bovine/make-by.el:
- * semantic/bovine/scm-by.el, semantic/wisent/javat-wy.el:
- * semantic/wisent/js-wy.el, semantic/wisent/python-wy.el:
- * srecode/srt-wy.el: Remove generated files from repository.
-
-2013-11-16 Barry O'Reilly <gundaetiapo@gmail.com>
-
- * semantic/fw.el (semantic-exit-on-input)
- (semantic-throw-on-input): Restore point before
- accept-process-output because timers which redisplay can run.
- (Bug#15045)
-
-2013-11-03 Johan Bockgård <bojohan@gnu.org>
-
- * semantic/lex.el (semantic-lex-start-block)
- (semantic-lex-end-block): Move after definition of
- semantic-lex-token macro.
-
-2013-10-28 Barry O'Reilly <gundaetiapo@gmail.com>
-
- * semantic/idle.el (semantic-idle-symbol-highlight)
- (semantic-idle-symbol-highlight-face): Define face with defface
- and obsolete the replaced one defined with defvar. (Bug#15745)
- * pulse.el (pulse-momentary-highlight-overlay)
- (pulse-momentary-highlight-region): Fix typo in doc
-
-2013-10-30 Glenn Morris <rgm@gnu.org>
-
- * semantic/grammar.el (semantic-grammar-mode-keywords-2)
- (semantic-grammar-mode-keywords-3): Handle renamed font-lock vars.
-
-2013-10-20 Johan Bockgård <bojohan@gnu.org>
-
- * semantic/db-mode.el (global-semanticdb-minor-mode):
- Remove hooks correctly.
- (semanticdb-toggle-global-mode): Pass `toggle' to minor mode function.
-
-2013-09-28 Leo Liu <sdl.web@gmail.com>
-
- * semantic/texi.el (semantic-analyze-possible-completions):
- Use ispell-lookup-words instead. (Bug#15460)
-
-2013-09-20 Glenn Morris <rgm@gnu.org>
-
- * semantic.el (semantic-new-buffer-fcn-was-run, semantic-active-p):
- Move from here...
- * semantic/fw.el: ...to here.
-
-2013-09-18 Glenn Morris <rgm@gnu.org>
-
- * semantic/find.el (semantic-brute-find-first-tag-by-name):
- Replace obsolete function assoc-ignore-case with assoc-string.
-
- * semantic/complete.el (tooltip-mode, tooltip-frame-parameters)
- (tooltip-show): Declare.
-
-2013-09-17 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/symref/list.el (semantic-symref-results-mode):
- Use define-derived-mode.
- (semantic-symref-produce-list-on-results): Set up the results here
- instead of in semantic-symref-results-mode. Move after
- semantic-symref-current-results's defvar now that it refers to that var.
- (semantic-symref-auto-expand-results)
- (semantic-symref-results-summary-function)
- (semantic-symref-results-mode-hook): Remove redundant :group arg.
- (semantic-symref, semantic-symref-symbol, semantic-symref-regexp):
- Initialize directly in the let.
-
-2013-09-13 Glenn Morris <rgm@gnu.org>
-
- * semantic/ia.el (semantic-ia-complete-symbol-menu):
- Comment it out, since it cannot work. (Bug#14522)
-
-2013-09-12 Glenn Morris <rgm@gnu.org>
-
- * semantic/find.el (semantic-find-first-tag-by-name):
- Replace obsolete function assoc-ignore-case with assoc-string.
-
-2013-09-11 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/grammar.el (semantic-grammar-mode): Use define-derived-mode.
- (semantic-grammar-mode-syntax-table): Rename from
- semantic-grammar-syntax-table.
- (semantic-grammar-mode-map): Rename from semantic-grammar-map.
- * data-debug.el (data-debug-mode-map): Rename from data-debug-map.
- (data-debug-mode): Use define-derived-mode.
-
-2013-09-05 Glenn Morris <rgm@gnu.org>
-
- * semantic/fw.el (semantic-make-local-hook):
- Simplify by dropping Emacs <= 20.
-
-2013-07-29 David Engster <deng@randomsample.de>
-
- * cedet.el (cedet-packages): Remove speedbar since its
- development does no longer happens in CEDET upstream but in Emacs
- proper. Also remove cedet-contrib and cogre since those are only
- in upstream.
-
- * semantic/analyze/fcn.el (semantic-analyze-type-to-name): If TYPE
- has a parent, return a fully qualified name.
-
- * semantic/decorate/mode.el
- (semantic-decoration-on-includes-p-default)
- (semantic-decoration-on-includes-highlight-default): Declare for
- byte compiler.
-
- * semantic/wisent/python.el (semantic/format): New require.
-
-2013-07-27 Eric Ludlam <zappo@gnu.org>
-
- * semantic/edit.el (semantic-edits-splice-remove):
- Wrap debug message removing middle tag in semantic-edits-verbose-flag
- check.
-
-2013-07-27 David Engster <deng@randomsample.de>
-
- * semantic/bovine/el.el (semantic/db-el): New require.
-
- * semantic/db-el.el (semanticdb-normalize-one-tag): It might be
- that a symbol comes from a file but cannot be found in its table.
- This happens for instance when a symbol was dynamically created
- through a macro like `defstruct'. In this case, return the
- original tag.
- (semanticdb-elisp-sym->tag): Deal with autoloaded functions, where
- the argument list is not available until the file is loaded.
-
-2013-06-25 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * data-debug.el, cedet-idutils.el: Neuter the "Version:" header.
-
-2013-06-19 Glenn Morris <rgm@gnu.org>
-
- * semantic/idle.el (define-semantic-idle-service):
- No need to use eval-and-compile, progn will do.
-
- * semantic/decorate/mode.el (define-semantic-decoration-style):
- Doc fix.
- (define-semantic-decoration-style): 'function is not an accepted
- value for autoload's "type" argument. Might as well use the default.
-
-2013-06-18 Glenn Morris <rgm@gnu.org>
-
- * semantic/ctxt.el (semantic-ctxt-end-of-symbol-default):
- Remove unused free variable `symlist'.
-
-2013-06-02 Eric Ludlam <zappo@gnu.org>
-
- * semantic/edit.el (semantic-change-function):
- Use `save-match-data' around running hooks.
-
- * semantic/decorate/mode.el
- (semantic-decorate-style-predicate-default)
- (semantic-decorate-style-highlighter-default): New.
- (semantic-decoration-mode): Do not require
- `semantic/decorate/include' anymore.
- (semantic-toggle-decoration-style): Error if an unknown decoration
- style is toggled.
- (define-semantic-decoration-style): Add new :load option.
- When :load is specified, add autoload tokens for the definition
- functions so that code is loaded when the mode is used.
- (semantic-decoration-on-includes): New autoload definition for
- highlighting includes.
-
- * semantic/bovine/c.el (semantic-lex-c-ifdef): Allow some misc
- characters to appear after the tested variable.
-
- * semantic/ede-grammar.el (project-compile-target): Calculate full
- src name via ede-expand-filename instead of the crutch of the
- current buffer. Enables this target to compile in batch mode.
-
- * semantic/idle.el
- (semantic-idle-symbol-maybe-highlight): Wrap highlighting of
- remote symbol with `save-excursion'.
- (semantic-idle-scheduler-work-parse-neighboring-files): Instead of
- using directory-files on each found mode pattern, collect all the
- patterns for the current mode, and then for each file, see if it
- matches any of them. If it does, parse the file. (Patch
- inspiration from Tomasz Gajewski.)
-
- * semantic/ctxt.el (semantic-ctxt-end-of-symbol): New.
- (semantic-ctxt-current-symbol-default): New.
-
- * semantic/bovine/el.el (semantic-default-elisp-setup):
- Add autoload cookie. Explain existence.
- (footer): Add local variable for loaddefs.
-
- * semantic/db.el (semanticdb-file-table-object): Add new filter,
- only checking for regular files too.
-
- * semantic/wisent/python.el
- (semantic-format-tag-abbreviate): New override. Cuts back on size
- of code tags.
-
- * srecode/compile.el (srecode-compile-templates): Fix warning
- punctuation. Remove status messages to clean up testing output.
-
- * ede/base.el (ede-project-placeholder-cache-file): Update doc to
- mention 'nil' value.
- (ede-save-cache): Disable cache save if file is nil.
-
- * ede.el (ede-initialize-state-current-buffer): Flush deleted
- projects.
- (global-ede-mode): Always append our find-file-hook to the end.
- (ede-flush-deleted-projects): New command.
-
- * ede/cpp-root.el (ede-preprocessor-map): Protect against init
- problems.
-
- * ede/proj.el (ede-proj-target): Add a new "custom" option for
- custom symbols representing a compiler or linker instead of
- restricting things to only the predefined compilers and linkers.
-
-2013-06-02 David Engster <dengste@eml.cc>
-
- * semantic.el (semantic-mode-map): To avoid showing showing
- Development menu twice, only disable menu item if menu-bar is
- actually enabled, otherwise the popup 'global menu' might display
- a disabled Development menu.
-
- * srecode/srt-wy.el: Regenerate.
-
-2013-06-02 Pete Beardmore <elbeardmorez@msn.com>
-
- * semantic/complete.el
- (semantic-displayor-show-request): Fix which slot in obj is set to
- the max tags.
-
-2013-06-01 Glenn Morris <rgm@gnu.org>
-
- * semantic/grammar.el (semantic-grammar-complete):
- Replace the obsolete function lisp-complete-symbol.
-
- * semantic/analyze/fcn.el (semantic-tag-similar-p): Autoload.
-
- * srecode/args.el, srecode/java.el: Require ede.
-
- * semantic/lex.el (semantic-lex-make-type-table): Fix transposed args.
-
-2013-05-24 Glenn Morris <rgm@gnu.org>
-
- * semantic/bovine/grammar.el (bovine-make-parsers):
- Avoid free variable `copyright-end'.
-
- * semantic/bovine/c-by.el (semantic-parse-region):
- * semantic/wisent/javat-wy.el (semantic-parse-region):
- * semantic/wisent/js-wy.el (semantic-parse-region):
- * semantic/wisent/python-wy.el (semantic-parse-region): Declare.
-
-2013-05-22 Glenn Morris <rgm@gnu.org>
-
- * ede/speedbar.el (ede-file-find, ede-tag-find):
- * semantic/sb.el (semantic-sb-token-jump):
- Use dframe-maybee-jump-to-attached-frame rather than speedbar- alias.
-
-2013-05-15 Glenn Morris <rgm@gnu.org>
-
- * semantic/symref/list.el (semantic-symref-auto-expand-results)
- (semantic-symref-results-mode-hook)
- (semantic-symref-results-summary-function): Fix :group.
-
-2013-05-14 Glenn Morris <rgm@gnu.org>
-
- * ede/simple.el, semantic/java.el: Set generated-autoload-load-name.
-
-2013-05-11 Glenn Morris <rgm@gnu.org>
-
- * ede/project-am.el, semantic/db-ebrowse.el, semantic/grammar.el:
- * semantic/sb.el, semantic/bovine/grammar.el, semantic/wisent/comp.el:
- * semantic/wisent/grammar.el, semantic/wisent/wisent.el:
- * srecode/fields.el: Set generated-autoload-load-name (for cus-load).
-
- * ede/locate.el (cedet-cscope-version-check)
- (cedet-cscope-support-for-directory):
- * semantic/grammar.el (semantic-grammar-wy--install-parser):
- Fix declarations.
-
- * ede/project-am.el (project-am-compile-project-command): Fix :type.
-
-2013-05-09 Glenn Morris <rgm@gnu.org>
-
- * semantic/db-find.el (semanticdb-find-throttle-custom-list):
- Fix value.
-
-2013-04-27 David Engster <deng@randomsample.de>
-
- * semantic/complete.el
- (semantic-collector-calculate-completions-raw):
- If `completionslist' is not set, refresh the cache if necessary and
- use it for completions. This fixes the
- `semantic-collector-buffer-deep' collector (bug#14265).
-
-2013-03-26 Leo Liu <sdl.web@gmail.com>
-
- * semantic/senator.el (senator-copy-tag-to-register):
- Move register handling logic from register.el. (Bug#14052)
-
-2013-03-21 Eric Ludlam <zappo@gnu.org>
-
- * semantic.el (navigate-menu): Yank Tag :enable. Make sure
- `senator-tag-ring' is bound.
- (semantic-parse-region-default): Stop reversing the output of
- parse-whole-stream.
- (semantic-repeat-parse-whole-stream): Append returned tags
- differently, so they come out in the right order.
-
- * semantic/sb.el (semantic-sb-filter-tags-of-class): New option.
- (semantic-sb-fetch-tag-table): Filter tags being bucketed to
- exclude tags belonging to above filtered classes.
-
- * semantic/find.el (semantic-filter-tags-by-class): New function.
-
- * semantic/tag-ls.el (semantic-tag-similar-p-default):
- Add short-circuit in case tag1 and 2 are identical.
-
- * semantic/analyze/fcn.el
- (semantic-analyze-dereference-metatype-stack):
- Use `semantic-tag-similar-p' instead of 'eq' when comparing two tags
- during metatype evaluation in case they are the same, but not the
- same node. (Tweaked patch from Tomasz Gajewski) (Tiny change)
-
- * semantic/db-find.el (semanticdb-partial-synchronize):
- Fix require to semantic/db-typecache to be correct.
- (semanticdb-find-tags-external-children-of-type): Make this a
- brutish search by default.
-
- * semantic/sort.el
- (semantic-tag-external-member-children-default): When calling
- `semanticdb-find-tags-external-children-of-type', pass in the
- input tag as the place to start searching for externally defined
- methods.
-
- * semantic/db-file.el (semanticdb-default-save-directory):
- Doc fix: Add ref to default value.
-
- * semantic/complete.el (semantic-complete-post-command-hook):
- When detecting if cursor is outside completion area, do so if cursor
- moves before start of overlay, or the original starting location
- of the overlay (i.e., if user deletes past beginning of the
- overlay region).
- (semantic-complete-inline-tag-engine): Initialize original start
- of `semantic-complete-inline-overlay'.
-
- * semantic/bovine/c.el (semantic-c-describe-environment):
- Update some section titles. Test semanticdb table before printing it.
- (semantic-c-reset-preprocessor-symbol-map): Update
- `semantic-lex-spp-macro-symbol-obarray' outside the loop over all
- the files contributing to its value.
- (semantic-c-describe-environment): If there is an EDE project but
- no spp symbols from it, say so.
-
- * srecode/args.el (srecode-semantic-handle-:project): New argument
- handler. Provide variable values if not in an EDE project.
-
- * srecode/srt-mode.el (srecode-template-mode): Fix typo on srecode
- name.
-
- * srecode/cpp.el (srecode-semantic-handle-:c): Replace all
- characters in FILENAME_SYMBOL that aren't valid CPP symbol chars.
-
- * srecode/map.el (srecode-map-validate-file-for-mode):
- Force semantic to load if it is not active in the template being added
- to the map.
-
- * srecode/srt.el: Add local variables for setting the autoload
- file name.
- (srecode-semantic-handle-:srt): New autoload cookie.
-
- * ede.el (ede-apply-preprocessor-map): Apply map to
- `semantic-lex-spp-project-macro-symbol-obarray' instead of the
- system one. Add require for semantic.
-
- * ede/proj-elisp.el (ede-update-version-in-source): In case a file
- has both a version variable and a Version: comment, always use
- `call-next-method'.
-
- * ede/cpp-root.el (ede-set-project-variables): Delete.
- `ede-preprocessor-map' does the job this function was attempting
- to do with :spp-table.
- (ede-preprocessor-map): Update file tests to provide better
- messages. Do not try to get symbols from a file that is the file
- in the current buffer.
-
- * ede/base.el (ede-project-placeholder): Add more documentation to
- :file slot.
- (ede-load-cache): Use `insert-file-contents' instead of
- `find-file-noselect' in order to avoid activating other tools.
-
-2013-03-21 David Engster <deng@randomsample.de>
-
- * semantic/bovine/c.el (semantic-get-local-variables): Also add a
- new variable 'this' if we are in an inline member function.
- For detecting this, we check overlays at point if there is a class
- spanning the current function. Also, the variable 'this' has to
- be a pointer.
-
- * semantic/bovine/gcc.el (semantic-gcc-setup): Fail gracefully
- when querying g++ for defines returns an error.
-
- * srecode/srt-mode.el:
- * srecode/compile.el:
- * semantic/db-el.el:
- * semantic/complete.el:
- * ede.el:
- * srecode/table.el:
- * srecode/mode.el:
- * srecode/insert.el:
- * srecode/compile.el:
- * semantic/decorate/include.el:
- * semantic/db.el:
- * ede/auto.el:
- * srecode/dictionary.el:
- * semantic/ede-grammar.el:
- * semantic/db.el:
- * semantic/db-find.el:
- * semantic/db-file.el:
- * semantic/complete.el:
- * semantic/bovine/c.el:
- * semantic/analyze.el:
- * ede/util.el:
- * ede/proj.el:
- * ede/proj-elisp.el:
- * ede/pconf.el:
- * ede/locate.el:
- * ede.el: Adapt to EIEIO namespace cleanup: Rename `object-name'
- to `eieio-object-name', `object-set-name-string' to
- `eieio-object-set-name-string', `object-class' to
- `eieio-object-class', `class-parent' to `eieio-class-parent',
- `class-parents' to `eieio-class-parents', `class-children' to
- `eieio-class-children', `object-name-string' to
- `eieio-object-name-string', `object-class-fast' to
- `eieio--object-class'. Also replace direct access with new
- accessor functions.
-
-2013-03-21 Tomasz Gajewski <tomga@wp.pl> (tiny change)
-
- * ede/cpp-root.el (ede-project-autoload, initialize-instance):
- Fix EDE file symbol to match rename. Fix ede-cpp-root symbol to
- include -project in name.
-
-2013-03-21 Alex Ott <alexott@gmail.com>
-
- * cedet-files.el (cedet-files-list-recursively): New.
- Recursively find files whose names are matching to given regex.
-
- * ede.el (ede-current-project): Rewrite to avoid imperative style.
-
- * ede/files.el (ede-find-file): Simplify code.
-
- * ede/base.el (ede-normalize-file/directory): Add function to
- normalize :file or :directory slots if they are missing.
-
- * ede/cpp-root.el (ede-cpp-root-project): Add compile-command
- slot.
- (project-compile-project): Compiles project using value specified
- in :compule-command slot or in compile-command local variable.
- Value of slot or local variable could be string or function that
- receives project and should return string that will be invoked as
- command.
- (project-compile-target): Invokes compilation of whole project.
-
- * ede/files.el (ede-find-project-root): New function to
- find root of project that contains specific file.
- (ede-files-find-existing): New function which checks presence of
- given directory in the list of registered projects.
-
-2013-03-04 Paul Eggert <eggert@cs.ucla.edu>
-
- * semantic/wisent/wisent.el (wisent): Stick to ASCII in the ASCII art.
-
- * semantic/wisent/javat-wy.el: Regenerate.
-
-2012-11-19 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/fw.el (semantic-make-local-hook, semantic-mode-line-update):
- Simplify via CSE.
-
-2012-11-16 David Engster <deng@randomsample.de>
-
- * semantic/symref/list.el (semantic-symref-symbol):
- Use `semantic-complete-read-tag-project' instead of
- `semantic-complete-read-tag-buffer-deep', since the latter is not
- working correctly.
-
- * semantic/symref.el (semantic-symref-result-get-tags):
- Use `find-buffer-visiting' to follow symbolic links.
-
- * semantic/fw.el (semantic-find-file-noselect): Always set
- `enable-local-variables' to `:safe' when loading files.
-
-2012-11-16 Glenn Morris <rgm@gnu.org>
-
- * semantic/lex-spp.el (semantic-lex-spp-lex-text-string):
- * semantic/util.el (semantic-describe-buffer):
- * semantic/bovine/c.el (semantic-c-parse-lexical-token)
- (semantic-default-c-setup):
- Use new names for hooks rather than obsolete aliases.
-
-2012-11-13 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/mru-bookmark.el (semantic-mru-bookmark-mode):
- * semantic/grammar.el (semantic-grammar-mode):
- * semantic/util-modes.el (semantic-highlight-edits-mode)
- (semantic-show-parser-state-mode): Avoid obsolete name
- semantic-edits-new-change-hooks (bug#12869).
-
-2012-11-13 Glenn Morris <rgm@gnu.org>
-
- * srecode/srt-mode.el (srecode-template-mode):
- Don't change global values of comment-start, comment-end. (Bug#12781)
-
-2012-10-25 David Engster <deng@randomsample.de>
-
- * semantic/analyze.el (semantic-analyze-dereference-alias):
- New function to dereference aliases.
- (semantic-analyze-current-context-default): Use it.
-
- * semantic/grammar.el (semantic-grammar-create-package):
- * srecode/compile.el (srecode-compile-templates): Throw a proper
- error if semantic-mode is not enabled (bug#9968).
-
- Compiler warning fixes:
-
- * semantic.el (semantic-elapsed-time): Make it a defsubst.
-
- * srecode/dictionary.el (srecode-adebug-dictionary):
- Remove require for `semantic'.
-
- * srecode/map.el:
- * srecode/insert.el: Declare functions from `data-debug'.
-
- * semantic/grammar.el: Require `help-fns'. Declare functions from
- `eldoc', which is required in function body.
-
- * srecode/java.el:
- * semantic/texi.el:
- * semantic/grammar-wy.el:
- * semantic/db-file.el:
- * semantic/db-el.el:
- * semantic/chart.el: Fix requires.
-
- * ede/locate.el: Remove useless requires. Declare functions
- instead and require in functions when needed.
-
-2012-10-23 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/db-file.el (semanticdb-save-database-functions):
- * semantic/lex.el (semantic-lex-reset-functions):
- * semantic/edit.el (semantic-change-functions)
- (semantic-edits-new-change-functions)
- (semantic-edits-delete-change-functions)
- (semantic-edits-reparse-change-functions): Don't use "-hooks" suffix.
-
-2012-10-14 David Engster <deng@randomsample.de>
-
- * semantic.el (semantic-error-if-unparsed): New function.
- Raise error if buffer was not parsed by Semantic (bug #12045).
- (navigate-menu, edit-menu, cedet-menu-map): Enable Semantic items
- only if buffer was parsed. Also, replace ':active' with ':enable'
- where necessary.
-
- * semantic/wisent/python.el
- (semantic-python-get-system-include-path):
- Use `python-shell-internal-send-string' if available to query Python
- for system paths.
-
- * semantic/senator.el (senator-next-tag, senator-previous-tag)
- (senator-go-to-up-reference): Use `semantic-error-if-unparsed'.
-
- * semantic/complete.el (semantic-complete-jump-local)
- (semantic-complete-jump, semantic-complete-jump-local-members)
- (semantic-complete-self-insert): Use `semantic-error-if-unparsed'.
- (semantic-complete-inline-project): Fix autoload cookie.
-
- * semantic/analyze/complete.el
- (semantic-analyze-possible-completions): Check if buffer was
- parsed. Only raise an error if function was called interactively,
- otherwise silently return nil.
-
- * cedet.el (cedet-menu-map): Fix copy&paste typo in menu creation.
-
-2012-10-08 David Engster <deng@randomsample.de>
-
- * semantic/bovine/el.el: Add `semantic-default-elisp-setup' to
- `emacs-lisp-mode-hook'. This was accidentally removed during the
- CEDET update (2012-10-01T18:10:29Z!cyd@gnu.org).
-
-2012-10-07 David Engster <deng@randomsample.de>
-
- * semantic/wisent/python.el (semantic-ctxt-current-function)
- (semantic-ctxt-current-assignment): New overrides, simply
- returning nil. The defaults do not work correctly and can send
- the parser in an infinite loop (bug#12458).
-
- * semantic/ede-grammar.el (project-compile-target): Fix grammar
- compilation after introduction of %provide statement.
-
- * semantic.el (semantic-new-buffer-setup-functions): Remove setup
- function for `f90-mode', since the parser only exists upstream.
-
-2012-10-06 Glenn Morris <rgm@gnu.org>
-
- * semantic/complete.el (semantic-displayor-tooltip-max-tags): Doc fix.
-
- * semantic/complete.el (semantic-displayor-tooltip-mode)
- (semantic-displayor-tooltip-initial-max-tags)
- (semantic-displayor-tooltip-max-tags): Add missing custom :version tags.
- * ede/linux.el (project-linux): Add missing group :version tag.
-
-2012-10-06 Chong Yidong <cyd@gnu.org>
-
- * semantic/bovine/grammar.el:
- * semantic/wisent/grammar.el: Move from admin/grammars.
- Add autoloads for bovine-grammar-mode and wisent-grammar-mode.
-
-2012-10-02 Chong Yidong <cyd@gnu.org>
-
- * srecode.el, ede.el: Restore Version header.
-
-2012-10-01 Chong Yidong <cyd@gnu.org>
-
- * semantic/bovine/c-by.el: Regenerate.
- * semantic/bovine/make-by.el:
- * semantic/bovine/scm-by.el:
- * semantic/grammar-wy.el:
- * semantic/wisent/javat-wy.el:
- * semantic/wisent/js-wy.el:
- * srecode/srt-wy.el:
-
-2012-10-01 Eric Ludlam <zappo@gnu.org>
-
- * cedet.el (cedet-version, cedet-packages): Update.
-
- * cedet-global.el (cedet-gnu-global-version-check): Support newer
- versions that have extra (parens) in the version string.
-
- * cedet-idutils.el (cedet-idutils-version-check): Make sure a
- version number was found before calling inversion-check-version.
-
- * data-debug.el (data-debug-insert-thing): Bind inhibit-read-only
- while inserting the thing, then clear modified bit.
- (data-debug-map): Suppress the keymap.
- (data-debug-mode, data-debug-new-buffer): Make buffer read-only.
- (data-debug-contract-current-line): Inhibit read-only, then clear
- modified bit.
-
- * ede.el (ede-buffer-belongs-to-project-p): Use ede-object-project
- to allow use in more kinds of buffers.
- (ede-project-forms-menu): Add `Default configuration' menu item.
- (ede-configuration-forms-menu): New, for use in above.
- (ede-project-configurations-set): New command used from menu.
- (ede-java-classpath): New conveninece for Java support.
- (ede-apply-object-keymap): Combine keybindings from the project
- and the target, not just whatever is local to the buffer.
- (ede-apply-target-options): Call fcn to apply project local
- variables.
- (ede-reset-all-buffers): Remove arg.
- (ede, ede-rescan-toplevel): Callers changed.
- (ede-new-target): Fix bug where you couldn't call this from Dired.
- (ede-add-file): Replace assignment of ede-object with generic call
- to re-init the buffer.
- (ede-find-target): If ede-object is set, run short-cut code
- instead of `or' shortcut.
- (ede-project-buffers): Return buffers belonging to input project,
- not any buffer belonging to any project.
- (ede-system-include-path, ede-apply-project-local-variables)
- (ede-set-project-local-variable): New functions.
- (ede-make-project-local-variable): Apply to toplevel if none
- specified.
- (ede-set): Make it interactive.
-
- * ede/auto.el (ede-project-autoload): New class.
- (ede-do-dirmatch): New method.
- (ede-project-dirmatch-p): New function.
- (ede-project-root-directory): Call it.
- (ede-dir-to-projectfile): Don't call project file function if we
- didn't match the root.
- (ede-project-root-directory): Don't call a project's root function
- if the tool in question isn't installed.
- (ede-dir-to-projectfile): Don't call project file function if we
- didn't match the root.
-
- * ede/autoconf-edit.el (autoconf-parameter-strip): Remove any
- trailing `\' mid string, and replace with a space.
- (autoconf-parameter-count): New function.
- (autoconf-set-version): Use it.
-
- * ede/base.el (ede-project): The :type of targets is now a list of
- target base classes.
-
- * ede/emacs.el (ede-emacs-load): Fix typo.
-
- * ede/files.el (ede-flush-project-hash, ede-flush-directory-hash):
- Protect against missing locator object.
- (ede-get-locator-object): Protect against missing project.
- (ede-flush-directory-hash): New command.
- (ede-get-locator-object): Protect against missing project.
-
- * ede/generic.el (ede-generic-config): Add configurable
- `run-command' slot.
- (project-compile-project, project-compile-target)
- (project-debug-target, project-run-target): New methods.
- (ede-generic-get-configuration): Specify the class to load.
- (ede-generic-new-autoloader): Use ede-add-project-autoload.
- (ede-enable-generic-projects): Rename projects so as to never
- match the edeproject-* projects.
-
- * ede/makefile-edit.el (makefile-macro-file-list): Case sensitive
- searches. Protect against "SUBDIRS=$(subdirs)" infloop.
-
- * ede/proj-elisp.el (ede-proj-tweak-autoconf)
- (ede-proj-flush-autoconf): Disable local variables when loading
- the autoconf lisp compile script.
-
- * ede/proj.el (ede-proj-target-aux, -elisp, -elisp-autoloads)
- (-scheme, -makefile-misc, ede-proj-target-makefile-program)
- (-makefile-archive, -makefile-shared-object)
- (ede-proj-target-makefile-info, -grammar): New autoloads.
- (ede-proj-project): Inherit from eieio-persistent-read.
- Specify extension and header line.
- (ede-proj-load, ede-proj-save): Replace with impl using
- eieio-persistent-read.
-
- * ede/project-am.el (project-add-file): Use ede-target-parent
- instead of loading the project file.
-
- * semantic.el (semantic-version): Update.
- (semantic-new-buffer-setup-functions): Add f90-mode, texinfo-mode.
- (navigate-menu): Add menu item for Stickyfunc mode.
-
- * semantic/analyze/debug.el
- (semantic-analyzer-debug-insert-include-summary):
- Before dereferencing tableinner, make sure it has a value.
-
- * semantic/analyze/refs.el
- (semantic-analyze-tag-references-default): When doing a lookup,
- specify noerror.
- (semantic--analyze-refs-full-lookup): Add optional noerror input
- argument. Pass to full-lookup-simple.
- (semantic-analyze-refs-impl, semantic-analyze-refs-proto):
- Ignore :typemodifiers during compare.
-
- * semantic/bovine/c.el (semantic-lex-cpp-define): Specify limits
- to looking back for comment chars.
- (semantic--tag-similar-names-p, semantic--tag-similar-names-p-default)
- (semantic--tag-attribute-similar-p): New.
- (semantic-c-describe-environment): Handle list value of ede-object.
- (semantic-lex-c-preprocessor-symbol-map-builtin):
- Add __attribute_pure__.
-
- * semantic/bovine/scm.el (semantic-format-tag-prototype):
- Add parent and color argument. Pass them through.
-
- * semantic/complete.el (semantic-collector-calculate-completions):
- Search for more matches if new prefix is a substring of old one.
- (semantic-complete-inline-project): New function.
-
- * semantic/db-el.el (object-print): New method.
-
- * semantic/db-file.el (semanticdb-load-database): Specify class.
-
- * semantic/db-typecache.el
- (semanticdb-abstract-table::semanticdb-typecache-find-method):
- Allow proxied tags to be resolved during the search.
- (semanticdb-typecache-complete-flush): Support missing or empty
- pointmax slot, to allow for more database types.
-
- * semantic/db.el (semanticdb-abstract-table): Add db-refs slot.
- (object-print): Allow child classes to overwrite the display of
- the (%d tags) extra string.
- (semanticdb-project-database): Specify :type for table.
- (semanticdb-create-table-for-file): Specify file-truename.
- (semanticdb-synchronize, semanticdb-partial-synchronize):
- Restore code that refreshes references to include files.
-
- * semantic/decorate/include.el
- (semantic-decoration-on-fileless-includes): New face.
- (semantic-decoration-on-fileless-include-map)
- (semantic-decoration-on-fileless-include-menu): New variables.
- (semantic-decoration-on-includes-highlight-default):
- Support includes that have a table, but are not associated with a file.
- (semantic-decoration-fileless-include-describe)
- (semantic-decoration-fileless-include-menu): New functions.
- (semantic-decoration-all-include-summary): Add arrows to indicate
- the file associated with an include name.
-
- * semantic/find.el
- (semantic-find-tags-by-scope-protection-default): Also filter on
- package protection of the slot.
-
- * semantic/java.el (semantic-java-expand-tag): If some type has a
- fully qualified name, bust it up into one package and the type
- with a short name.
-
- * semantic/lex.el (define-lex-block-analyzer): Protect against
- random extra close parenthesis.
-
- * semantic/symref.el (semantic-symref-result-get-tags): Make sure
- the cursor is on the matched name.
-
- * semantic/symref/list.el (semantic-symref-results-mode-map):
- Suppress keymap.
-
- * semantic/tag-ls.el (semantic--tag-similar-names-p)
- (semantic--tag-attribute-similar-p)
- (semantic--tag-similar-types-p): New functions.
- (semantic-tag-similar-ignorable-attributes): New variable.
- (semantic-tag-protection-default): Add package concept to return
- value.
- (semantic-tag-package-protected-p): New function.
- (semantic-tag-full-package): New overload method.
- (semantic-tag-full-package-default): New default for above.
- (semantic-tag-full-name-default): Look for the full package name.
-
- * semantic/tag.el (semantic-create-tag-proxy)
- (semantic-tag-set-proxy, semantic-tag-resolve-proxy): New.
-
- * semantic/util.el (semantic-describe-buffer):
- Add semantic-new-buffer-fcn-was-run.
-
- * semantic/wisent/java-tags.el (semantic-get-local-variables):
- Add `this' to the local variable context.
- (semantic-analyze-split-name, semantic-analyze-unsplit-name): New.
-
- * semantic/wisent/python.el (semantic-python-expand-tag):
- New function.
-
- * srecode/compile.el (srecode-compile-templates): Add "framework"
- special variable support.
- (srecode-compile-template-table): Support framework specifier.
-
- * srecode/cpp.el (srecode-semantic-handle-:c)
- (srecode-semantic-handle-:cpp): New functions.
- (srecode-semantic-apply-tag-to-dict): Move from cpp-mode function
- to c-mode function.
- (srecode-c-apply-templates): Rename from srecode-cpp-apply-templates.
-
- * srecode/dictionary.el (initialize-instance): Remove bogus error
- condition.
- (srecode-create-section-dictionary): Remove unused function.
-
- * srecode/java.el (srecode-semantic-handle-:java): Fix filename as
- package variable. Add current_package variable.
-
- * srecode/map.el (srecode-map-update-map): Specify the class.
-
- * srecode/mode.el (srecode-minor-mode): Support the m3 menu.
-
- * srecode/semantic.el (srecode-semantic-insert-tag):
- Support system includes.
-
- * srecode/srt-mode.el (srecode-font-lock-keywords): Update.
-
- * srecode/table.el (srecode-template-table): Add :framework slot.
- (srecode-dump): Dump it.
- (srecode-mode-table): Add new modetables slot.
- (srecode-get-mode-table): Find the mode, but also find all parent
- modes, and merge the tables together in :tables from :modetables.
- (srecode-make-mode-table): Init :modetables.
- (srecode-mode-table-find): Search in modetables.
- (srecode-mode-table-new): Merge the different files into the
- modetables slot.
-
-2012-10-01 David Engster <deng@randomsample.de>
-
- * ede.el (ede-apply-preprocessor-map): Check that
- `semantic-lex-spp-macro-symbol-obarray' is non-nil.
- (global-ede-mode): Fix call to `ede-reset-all-buffers'.
-
- * ede/cpp-root.el (ede-preprocessor-map): Make sure we add the
- lexical-table even when the table doesn't need to be refreshed.
-
- * ede/dired.el (ede-dired-minor-mode): Use called-interactively-p.
-
- * ede/pmake.el (ede-pmake-insert-variable-once): Wrap in
- save-excursion.
-
- * ede/proj-comp.el (ede-proj-makefile-insert-rules): Fix insertion
- of phony rule.
-
- * ede/proj-elisp.el (ede-proj-target-elisp):
- Remove ede-emacs-preload-compiler.
- (ede-proj-makefile-insert-rules, ede-proj-makefile-dependencies):
- New methods.
- (ede-emacs-compiler): Add 'require' macro to variables and pattern
- rule. Add .elc object extension.
- (ede-proj-elisp-packages-to-loadpath): Allow longer relative names.
- (ede-proj-makefile-insert-variables): Do not insert preload items.
- (ede-proj-target-elisp-autoloads): Don't depend on cedet-autogen.
-
- * ede/util.el (ede-make-buffer-writable):
- * semantic/debug.el (semantic-debug-mode): Set buffer-read-only
- instead of calling toggle-read-only.
-
- * semantic.el (semantic-fetch-tags): Use progress reporter only
- when called interactively.
- (semantic-submode-list): Add debugging modes.
- (semantic-mode): Remove Semantic from after-change-functions.
- Delete the cache, call semantic--tag-unlink-cache-from-buffer, and
- set semantic-new-buffer-fcn-was-run to nil.
-
- * semantic/analyze/fcn.el (semantic-analyze-tag-prototype-p)
- (semantic-analyze-tag-prototype-p-default): Remove.
- (semantic-analyze-type, semantic-analyze-dereference-metatype-1):
- Use semantic-tag-prototype-p.
-
- * semantic/bovine/c.el (semantic-c-reset-preprocessor-symbol-map):
- Ensure semantic-mode is on before getting preprocessor symbols.
- (semantic-c-skip-conditional-section): Use c-scan-conditionals.
- (semantic-c-convert-spp-value-to-hideif-value)
- (semantic-c-evaluate-symbol-for-hideif, semantic-c-hideif-lookup)
- (semantic-c-hideif-defined): Revive hideif code from CEDET trunk.
- (semantic-lex-c-if, semantic-c-do-lex-ifdef): Revert changes for
- regular expression parsing.
- (semantic-cpp-lexer): Add semantic-lex-c-ifdef.
- (semantic-expand-c-tag): Check if tag is non-nil before adding it
- to return list.
- (semantic-expand-c-extern-C, semantic-expand-c-complex-type):
- New functions, copied from semantic-expand-c-tag.
- (semantic-find-tags-included): New override which also searches
- for include tags inside of namespaces.
- (semantic-c-dereference-typedef): Use semantic-tag-prototype-p.
- (semanticdb-find-table-for-include): New override.
-
- * semantic/bovine/el.el: Remove emacs-lisp-mode-hook.
-
- * semantic/complete.el (semantic-complete-post-command-hook):
- Exit completion when user has deleted all characters from the prefix.
- (semantic-displayor-focus-request): Return to previous window when
- focusing tags.
-
- * semantic/db-el.el (semanticdb-normalize-one-tag): Make obsolete.
- (semanticdb-elisp-sym->tag): Use help-function-arglist instead.
-
- * semantic/db-file.el (semanticdb-create-database):
- Use semantic-tag-version instead of just semantic-version as the
- initializer for the :semantic-tag-version slot.
-
- * semantic/db-find.el (semanticdb-find-tags-by-class-method):
- Delegate `include' to semantic-find-tags-included, which by
- default will just call semantic-find-tags-by-class.
-
- * semantic/db.el (semanticdb-refresh-table): Do not print warnings
- when calling semantic-find-file-noselect. This avoids the "file
- is write protected" messages when parsing system header files,
- which might easily be mistaken to mean the currently loaded file.
- (semanticdb-save-current-db, semanticdb-save-all-db): Only emit
- message when running interactively.
-
- * semantic/decorate/mode.el (semantic-decoration-mode):
- Activate decoration of includes by default.
-
- * semantic/doc.el (semantic-doc-snarf-comment-for-tag):
- Remove comment delimiter at the end of the text.
-
- * semantic/ede-grammar.el (semantic-ede-proj-target-grammar):
- Change aux- and pre-load-packages.
- (ede-proj-makefile-dependencies): Update pattern rule so that
- resulting parsers are also byte-compiled.
- (semantic-ede-grammar-compiler-bovine)
- (semantic-ede-source-grammar-wisent): Remove .elc from garbage
- pattern, since this is already covered by the elisp compiler.
- (project-compile-target): Add compatibility code for Emacs 23,
- which does not have `byte-recompile-file'.
- (ede-proj-makefile-insert-rules): Add target specific EMACSFLAGS
- to raise max-specpdl-size and max-lisp-eval-depth.
-
- * semantic/find.el (semantic-find-tags-included):
- Make overridable.
-
- * semantic/fw.el (semantic-alias-obsolete)
- (semantic-varalias-obsolete): Use byte-compile-warn.
- (semantic-find-file-noselect): Disable font lock by calling
- global-font-lock-mode.
-
- * semantic/grammar.el (semantic-grammar-create-package):
- Fix message.
- (semantic-grammar-batch-build-one-package): When generating
- parsers in batch-mode, ignore version control and make sure we do
- not use cached versions.
-
- * semantic/ia.el (semantic-ia-complete-symbol-menu): Bring back.
-
- * semantic/lex-spp.el (semantic-lex-spp-symbol-merge): New fun.
- (semantic-lex-spp-token-macro-to-macro-stream): Use it.
- (semantic-lex-spp-lex-text-string): Instead of only setting the
- lexer, call the major mode's setup function.
-
- * semantic/scope.el (semantic-analyze-scoped-types-default):
- Use semantic-tag-prototype-p.
- (semantic-analyze-scope-nested-tags-default): Make sure we don't
- return tags we already have in scopetypes.
-
- * semantic/symref/filter.el
- (semantic-symref-test-count-hits-in-tag): Restore.
-
- * semantic/wisent/comp.el (wisent-BITS-PER-WORD):
- Use most-positive-fixnum if available.
-
- * semantic/wisent/javascript.el (semantic-tag-protection)
- (semantic-analyze-scope-calculate-access)
- (semantic-ctxt-current-symbol): New overrides.
-
- * semantic/wisent/python.el (wisent-python-lex-beginning-of-line):
- Rewrite to fix byte-compiler warning.
-
-2012-10-01 Robert Jarzmik <robert.jarzmik@free.fr>
-
- * ede/linux.el (project-linux): New group.
- (project-linux-compile-target-command)
- (project-linux-compile-project-command): New options.
- (project-compile-project, project-compiler-target): New methods.
-
- * inversion.el (inversion-decoders): New regexps for SXEmacs.
- (inversion-package-version): More verbose error message.
- (inversion-<): Deal with new special cases.
- (inversion-require-emacs): New argument sxemacs-ver; use it.
-
-2012-10-01 Nelson Ferreira <nelson.ferreira@ieee.org>
-
- * ede/emacs.el (ede-emacs-version): Detect SXEmacs.
-
-2012-10-01 William Xu <william.xwl@gmail.com>
-
- * semantic/bovine/gcc.el (semantic-gcc-query): Returns status when
- there is an error.
- (semantic-gcc-setup): If the first attempt at calling cpp fails,
- try straight GCC.
-
-2012-10-01 Jan Moringen <jan.moringen@uni-bielefeld.de>
-
- * semantic/idle.el
- (semantic-idle-breadcrumbs--display-in-header-line):
- Escape %-characters to avoid erroneous expansion in header line.
- (semantic-idle-breadcrumbs--display-in-mode-line): Likewise.
-
- * semantic/wisent/python.el (wisent-python-reconstitute-function-tag)
- (wisent-python-reconstitute-class-tag, semantic-python-special-p)
- (semantic-python-private-p, semantic-python-instance-variable-p)
- (semantic-python-docstring-p): New functions.
-
- * srecode/find.el (srecode-user-template-p): New function.
- (srecode-all-template-hash): Accept new optional argument
- predicate; return only templates matching the predicate.
- (srecode-read-template-name): Only retrieve templates matching
- srecode-user-template-p.
-
- * srecode/insert.el (srecode-insert-show-error-report)
- (srecode-insert-report-error): New functions.
- (srecode-insert-variable-secondname-handler)
- (srecode-insert-method, srecode-insert-ask-default)
- (srecode-insert-variable-secondname-handler)
- (srecode-insert-subtemplate, srecode-insert-method-helper)
- (srecode-insert-include-lookup): Use them.
-
-2012-10-01 Thomas Bach <thbach@students.uni-mainz.de>
-
- * semantic/wisent/python.el
- (semantic-python-get-system-include-path): Add Python3k support.
-
-2012-10-01 Alexander Haeckel <_@_> (tiny change)
-
- * srecode/getset.el (srecode-query-for-field): Return the first
- tag found by name from all children tags.
-
-2012-10-01 Dale Sedivec <dale@codefu.org>
-
- * semantic/wisent/python.el (wisent-python-string-start-re)
- (wisent-python-string-re, wisent-python-forward-string)
- (wisent-python-forward-line, wisent-python-lex-string):
- New variables.
- (wisent-python-forward-balanced-expression): New function.
-
-2012-10-01 Pete Beardmore <elbeardmorez@msn.com>
-
- * semantic/complete.el (semantic-collector-calculate-completions):
- Search for additional matches if new prefix is a substring of the
- old prefix.
- (semantic-displayor-next-action): Immediately show more
- completions after user presses TAB the first time.
- (semantic-displayor-tooltip-mode)
- (semantic-displayor-tooltip-initial-max-tags)
- (semantic-displayor-tooltip-max-tags): New defcustoms.
- (semantic-displayor-tooltip): Use new variables as initforms.
- Use new slot `mode' instead of `force-show'. Rename `max-tags' to
- `max-tags-initial'.
- (semantic-displayor-show-request): Display completions according
- to new modes, and make variable names clearer.
- (semantic-displayor-tooltip::semantic-displayor-scroll-request):
- Use new max-tags-initial slot.
-
- * semantic/idle.el (semantic-idle-local-symbol-highlight):
- Make sure there actually is a tag at point.
- (semantic-idle-completion-list-default): Report errors as messages
- if semantic-idle-scheduler-verbose-flag is non-nil.
-
-2012-10-01 Richard Kim <emacs18@gmail.com>
-
- * semantic/db-global.el (semanticdb-enable-gnu-global-databases):
- Add optional NOERROR argument.
-
-2012-10-01 Alex Ott <alexott@gmail.com>
-
- * semantic/idle.el (semantic-idle-scheduler-enabled-p):
- Fix file-checking.
-
-2012-10-01 Darren Hoo <darren.hoo@gmail.com> (tiny change)
-
- * semantic/db-find.el (semanticdb-find-default-throttle):
- Make buffer-local.
- (semanticdb-strip-find-results): Check for existing :filename
- attribute, so that file information from GNU Global is not lost.
-
-2012-08-07 Andreas Schwab <schwab@linux-m68k.org>
-
- * ede/base.el (ede-with-projectfile): Use backquote forms.
-
-2012-07-29 Paul Eggert <eggert@cs.ucla.edu>
-
- "inaccessible" spelling fix (Bug#10052)
- * semantic/wisent/comp.el (wisent-inaccessible-symbols):
- Rename from wisent-inaccessable-symbols, fixing a misspelling.
- Caller changed.
-
-2012-07-09 Andreas Schwab <schwab@linux-m68k.org>
-
- * ede/project-am.el: Fix typo.
-
-2012-07-09 Paul Eggert <eggert@cs.ucla.edu>
-
- Rename configure.in to configure.ac (Bug#11603).
- * ede/autoconf-edit.el (autoconf-find-query-for-program)
- (autoconf-new-program):
- * ede/emacs.el (ede-emacs-version):
- * ede/proj.el (ede-proj-setup-buildenvironment):
- * ede/project-am.el (project-am-autoconf-file-options):
- Prefer configure.ac to configure.in.
-
-2012-03-12 David Engster <deng@randomsample.de>
-
- * semantic/db-find.el
- (semanticdb-find-translate-path-brutish-default): If we don't yet
- have a proper table for PATH, use `semanticdb-current-database'
- instead (bug #10343).
-
-2012-03-11 David Engster <deng@randomsample.de>
-
- * semantic/wisent/javascript.el (js-mode): Define `js-mode' as
- child-mode of `javascript-mode' (bug #8445).
-
-2012-02-28 Glenn Morris <rgm@gnu.org>
-
- * semantic/db.el (semanticdb-search-results-table):
- Doc fix (standardize possessive apostrophe usage).
-
-2012-02-09 Juanma Barranquero <lekktu@gmail.com>
-
- * ede/auto.el (ede-directory-safe-p, ede-add-project-to-global-list):
- Add declarations.
-
-2012-01-29 David Engster <deng@randomsample.de>
-
- Fix require error when using srecode-insert (Bug#9967).
- * srecode/insert.el: Require srecode/filters.
- * srecode/filters.el: Drop two requires.
-
-2012-01-09 Eric Ludlam <zappo@gnu.org>
-
- * ede.el (ede-project-directories): New option.
- (ede-directory-safe-p): Check it.
- (ede-initialize-state-current-buffer, ede, ede-new)
- (ede-check-project-directory, ede-rescan-toplevel)
- (ede-load-project-file, ede-parent-project, ede-current-project)
- (ede-target-parent): Avoid loading in a project unless it is safe,
- since it may involve malicious code. This security flaw was
- pointed out by Hiroshi Oota.
-
- * ede/auto.el (ede-project-autoload): Add safe-p slot.
- (ede-project-class-files): Projects using Project.ede are unsafe.
- (ede-auto-load-project): New method.
-
- * ede/simple.el (ede-project-class-files): Mark as unsafe.
-
-2011-12-19 Sam Steingold <sds@gnu.org>
-
- * semantic/edit.el (semantic-edits-incremental-parser): Add the
- autoload cookie, necessary for JDEE.
-
-2011-12-06 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/bovine/c.el (semantic-tag-abstract-p): Fix typo.
-
-2011-11-26 Chong Yidong <cyd@gnu.org>
-
- * semantic/wisent/python-wy.el:
- * semantic/wisent/js-wy.el:
- * semantic/wisent/javat-wy.el:
- * semantic/bovine/c-by.el:
- * semantic/grammar-wy.el: Regenerate.
-
-2011-11-24 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/lex-spp.el (semantic-lex-spp-first-token-arg-list): Fix typo.
-
-2011-11-20 Juanma Barranquero <lekktu@gmail.com>
-
- * cedet-cscope.el (cedet-cscope-version-check):
- * cedet-global.el (cedet-global-min-version)
- (cedet-gnu-global-version-check):
- * cedet.el (cedet-version):
- * data-debug.el (data-debug-prev, data-debug-contract-current-line):
- * ede.el (ede-buffer-belongs-to-project-p, ede-auto-add-to-target)
- (ede-new, ede-invoke-method, project-edit-file-target, project-rescan)
- (ede-add-project-to-global-list, ede-map-all-subprojects):
- * inversion.el (inversion-check-version):
- * mode-local.el (mode-local-map-file-buffers, define-child-mode)
- (define-overloadable-function):
- * pulse.el (pulse-flag, pulse):
- * semantic.el (semantic-elapsed-time, semantic-parse-region)
- (navigate-menu):
- * ede/proj-comp.el (ede-compilation-program):
- * semantic/debug.el (semantic-debug-parser-go)
- (semantic-debug-parser-fail, semantic-debug-parser-quit)
- (semantic-debug-parser-abort):
- * semantic/idle.el (semantic-idle-core-handler):
- * semantic/bovine/debug.el (semantic-bovine-debug-error-frame):
- Fix typos.
-
-2011-11-16 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/lex.el (semantic-lex-tokens):
- * semantic/tag-ls.el (semantic-tag-protected-p):
- * srecode/mode.el (srecode-prefix-map): Fix typos.
-
-2011-11-15 Juanma Barranquero <lekktu@gmail.com>
-
- * ede/project-am.el (project-compile-target-command): Fix typo.
-
-2011-11-14 Juanma Barranquero <lekktu@gmail.com>
-
- * ede/auto.el (ede-project-autoload):
- * ede/proj-comp.el (ede-makefile-rule):
- * semantic/analyze.el (semantic-analyze-current-context):
- * semantic/ctxt.el (semantic-get-local-variables):
- * semantic/tag-ls.el (semantic-tag-calculate-parent): Fix typos.
-
-2011-11-03 David Engster <dengste@eml.cc>
-
- * srecode.el:
- * srecode/texi.el:
- * srecode/template.el:
- * srecode/java.el:
- * srecode/insert.el:
- * srecode/document.el:
- * srecode/dictionary.el:
- * srecode/compile.el:
- * semantic/wisent/java-tags.el:
- * semantic/texi.el:
- * semantic/sort.el:
- * semantic/lex-spp.el:
- * semantic/idle.el:
- * semantic/html.el:
- * semantic/db-typecache.el:
- * semantic/analyze/complete.el:
- * ede/generic.el:
- * ede/custom.el:
- * ede/cpp-root.el:
- * ede/base.el: Fix filenames in comments and headers.
-
- * semantic/db-find.el:
- * srecode/insert.el (srecode-insert-include-lookup):
- * ede/proj-comp.el (ede-compilation-program): Fix it's -> its in
- comments and docstrings.
-
- * semantic/ctxt.el (semantic-end-of-context-default):
- * semantic/find.el (semantic-find-tags-by-scope-protection):
- * semantic/java.el (semantic-documentation-for-tag): Fix typos in
- docstrings.
-
- * semantic/db.el (semanticdb-table, semanticdb-abstract-cache)
- (semanticdb-abstract-db-cache):
- * semantic/decorate/include.el
- (semantic-decoration-unknown-include-describe): Fix filenames in
- docstring.
-
- * semantic/ede-grammar.el (semantic-ede-grammar-compiler-wisent)
- (semantic-ede-grammar-compiler-bovine): Fix requires that are
- added to the grammar-make-script.
-
-2011-10-23 Chong Yidong <cyd@gnu.org>
-
- * ede.el (ede-maybe-checkout): Function deleted;
- vc-toggle-read-only does not do version control now.
-
- * ede/util.el (ede-make-buffer-writable): Don't use
- vc-toggle-read-only.
-
- * ede/project-am.el (project-remove-file, project-add-file)
- (project-new-target): Don't call ede-maybe-checkout.
-
-2011-10-19 Chong Yidong <cyd@gnu.org>
-
- * ede.el (ede-minor-mode, global-ede-mode):
- * semantic.el (semantic-mode): Doc fix to reflect new
- define-minor-mode calling behavior.
-
-2011-07-30 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/grammar.el (semantic-grammar-insert-defanalyzers):
- Fix require.
-
-2011-07-04 Darren Hoo <darren.hoo@gmail.com> (tiny change)
-
- * semantic/db.el (semanticdb-file-table-object): Don't bug out on
- unconfigured projects if `global-ede-mode' is on (bug#8092).
-
-2011-07-01 Paul Eggert <eggert@cs.ucla.edu>
-
- * semantic.el (semantic-elapsed-time): Rewrite using
- time-subtract and float-time.
-
-2011-05-11 Glenn Morris <rgm@gnu.org>
-
- * semantic/wisent/javascript.el (semantic-get-local-variables):
- Use define-mode-local-override rather than its obsolete alias.
-
-2011-05-10 Jim Meyering <meyering@redhat.com>
-
- Fix doubled-word typos.
- * ede/pmake.el (ede-proj-makefile-garbage-patterns):
- * semantic/complete.el (semantic-complete-read-tag-local-members):
- * ede.el (ede-auto-add-method): Fix typos.
-
-2011-04-23 Juanma Barranquero <lekktu@gmail.com>
-
- * ede/pconf.el (ede-proj-tweak-autoconf, ede-proj-flush-autoconf):
- * ede/proj-comp.el (ede-proj-tweak-autoconf, ede-proj-flush-autoconf):
- * ede/proj-elisp.el (ede-proj-tweak-autoconf, ede-proj-flush-autoconf)
- (ede-proj-tweak-autoconf, ede-proj-flush-autoconf):
- * ede/proj-scheme.el (ede-proj-tweak-autoconf): Fix typos in docstrings.
-
-2011-03-07 Chong Yidong <cyd@stupidchicken.com>
-
- * Version 23.3 released.
-
-2011-02-21 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/wisent/comp.el (wisent-byte-compile-grammar):
- Macroexpand before passing to byte-compile-form.
-
-2011-01-13 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * srecode/srt-mode.el (srecode-template-mode): Use define-derived-mode.
- * semantic/symref/list.el (semantic-symref-results-mode):
- Use run-mode-hooks.
-
-2010-11-12 Glenn Morris <rgm@gnu.org>
-
- * semantic/wisent/comp.el: Remove unnecessary eval-when-compiles.
-
-2010-11-10 Glenn Morris <rgm@gnu.org>
-
- * semantic/bovine/c.el: Test system-type with memq.
-
-2010-11-09 Glenn Morris <rgm@gnu.org>
-
- * semantic/lex.el (semantic-lex-ignore-comments, semantic-flex):
- * semantic/grammar.el (semantic-grammar-epilogue):
- * ede/speedbar.el (ede-find-nearest-file-line):
- * ede/pmake.el (ede-proj-makefile-insert-dist-rules):
- * ede/autoconf-edit.el (autoconf-delete-parameter):
- Use point-at-bol and point-at-eol.
-
-2010-11-07 Glenn Morris <rgm@gnu.org>
-
- * ede/proj-elisp.el (ede-proj-flush-autoconf): Use point-at-bol.
-
-2010-11-01 Glenn Morris <rgm@gnu.org>
-
- * semantic/bovine/c.el (semantic-analyze-split-name): Move before use.
-
- * semantic/symref/cscope.el (ede-toplevel):
- * semantic/symref.el (ede-toplevel):
- * semantic/tag-file.el (ede-toplevel):
- * ede.el (ede-toplevel): Fix declarations.
-
-2010-10-31 Glenn Morris <rgm@gnu.org>
-
- * ede/proj-elisp.el (project-compile-target): Fix previous change.
- * semantic/ede-grammar.el (project-compile-target): Fix previous change.
-
-2010-10-31 Julien Danjou <julien@danjou.info>
-
- * ede/proj-elisp.el (project-compile-target):
- * semantic/ede-grammar.el (project-compile-target):
- Use `byte-recompile-file'.
-
-2010-10-31 Glenn Morris <rgm@gnu.org>
-
- * mode-local.el (mode-local-augment-function-help):
- * semantic/analyze/debug.el (semantic-analyzer-debug-add-buttons):
- * semantic/symref/list.el (semantic-symref-results-dump)
- (semantic-symref-rb-toggle-expand-tag): Replace inappropriate uses
- of toggle-read-only.
-
-2010-09-30 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/bovine/el.el:
- * semantic/mru-bookmark.el (global-semantic-mru-bookmark-mode):
- Fix require statements.
-
-2010-09-29 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/tag.el (semantic-tag-version): Bump to 2.0.
-
- * semantic/db-typecache.el (semanticdb-typecache-find-default):
- * semantic/imenu.el (semantic-create-imenu-index):
- * semantic/grammar.el (semantic--grammar-macro-function-tag):
- * semantic/fw.el (semanticdb-without-unloaded-file-searches):
- Fix require. Suggested by David Engster.
-
- * semantic/bovine/c-by.el: Regenerate.
-
-2010-09-29 Eric Ludlam <zappo@gnu.org>
-
- * semantic/lex-spp.el (semantic-lex-spp-debug-symbol): New var.
- (semantic-lex-spp-enable-debug-symbol): New command.
- (semantic-lex-spp-value-valid-p)
- (semantic-lex-spp-validate-value): New functions.
- (semantic-lex-spp-symbol-set)
- (semantic-lex-spp-symbol-push): Add call to validate value.
- (semantic-lex-spp-table-write-slot-value): Instead of erroring on
- invalid values during save, just save a nil.
-
-2010-09-25 Chong Yidong <cyd@stupidchicken.com>
-
- * ede/linux.el (ede-project-class-files):
- * ede/generic.el (ede-generic-new-autoloader):
- * ede/emacs.el (ede-project-class-files):
- * ede/simple.el (ede-project-class-files):
- * ede/cpp-root.el (ede-project-class-files): Fix require name.
-
-2010-09-25 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/lex.el (semantic-ignore-comments): Doc fix.
-
- * semantic/symref/list.el (semantic-symref-list-rename-open-hits):
- Fix typo in error message.
- (semantic-symref-list-map-open-hits): Fix typo in docstring.
-
-2010-09-21 Eric Ludlam <zappo@gnu.org>
-
- Synch SRecode to CEDET 1.0.
-
- * pulse.el (pulse-momentary-highlight-overlay): If pulse-flag is
- 'never, disable all pulsing.
-
- * cedet.el (cedet-version):
- * srecode.el (srecode-version): Bump version to 1.0.
-
- * srecode/texi.el (srecode-texi-insert-tag-as-doc): New function.
- (semantic-insert-foreign-tag): Use it.
-
- * srecode/mode.el (srecode-bind-insert):
- Call srecode-load-tables-for-mode.
- (srecode-minor-mode-templates-menu): Do not list templates that
- are not in the current project.
- (srecode-menu-bar): Add binding for srecode-macro-help.
-
- * srecode/table.el (srecode-template-table): Add :project slot.
- (srecode-dump): Dump it.
-
- * srecode/map.el (srecode-map-update-map): Make map loading more
- robust.
-
- * srecode/insert.el (srecode-insert-fcn): Merge template
- dictionary before resolving arguments.
- (srecode-insert-method-helper): Add error checking to make sure
- that we only have dictionaries.
- (srecode-insert-method): Check template nesting depth when using
- point inserter override.
- (srecode-insert-method): Install override with depth limit.
-
- * srecode/getset.el (srecode-insert-getset): Force tag table
- update. Don't query the class if it is empty.
-
- * srecode/find.el (srecode-template-get-table)
- (srecode-template-get-table-for-binding)
- (srecode-all-template-hash): Skip if not in current project.
- (srecode-template-table-in-project-p): New method.
-
- * srecode/fields.el (srecode-fields-exit-confirmation): New option.
- (srecode-field-exit-ask): Use it.
-
- * srecode/dictionary.el (srecode-dictionary-add-template-table):
- Do not add variables in tables not for the current project.
- (srecode-compound-toString): Handle cases where the default value
- is another compound value.
- (srecode-dictionary-lookup-name): New optional argument
- NON-RECURSIVE, which inhibits visiting dictionary parents.
- (srecode-dictionary-add-section-dictionary)
- (srecode-dictionary-merge): New optional argument FORCE adds
- values even if an identically named entry exists.
- (srecode-dictionary-add-entries): New method.
- (srecode-create-dictionaries-from-tags): New function.
-
- * srecode/cpp.el (srecode-cpp): New defgroup.
- (srecode-cpp-namespaces): New option.
- (srecode-semantic-handle-:using-namespaces)
- (srecode-cpp-apply-templates): New functions.
- (srecode-semantic-apply-tag-to-dict): Handle template parameters
- by calling `srecode-cpp-apply-templates'.
-
- * srecode/compile.el (srecode-compile-templates): Fix directory
- compare of built-in templates. Give built-ins lower priority.
- Support special variable "project".
- (srecode-compile-template-table): Set :project slot of new tables.
- (srecode-compile-one-template-tag):
- Use srecode-create-dictionaries-from-tags.
-
-2010-09-21 Eric Ludlam <zappo@gnu.org>
-
- Synch EDE to CEDET 1.0.
-
- * cedet-idutils.el (cedet-idutils-make-command): New option.
- (cedet-idutils-mkid-call)
- (cedet-idutils-create/update-database): New functions.
-
- * cedet-cscope.el (cedet-cscope-create)
- (cedet-cscope-create/update-database): New functions.
- (cedet-cscope-support-for-directory): Make interactive.
-
- * cedet-global.el (cedet-global-gtags-command): New option.
- (cedet-gnu-global-gtags-call)
- (cedet-gnu-global-create/update-database): New functions.
-
- * ede.el (ede-save-cache): Fix recentf-exclude expression.
- (ede-make-dist): Always use toplevel project.
- (ede-buffer-object): If we fail to find an object in the current
- project, loop upward looking for a match. If no target is found,
- use most local project.
- (ede-buffer-belongs-to-target-p)
- (ede-buffer-belongs-to-project-p): New functions.
- (ede-initialize-state-current-buffer): New function.
- (ede-target-forms-menu, ede-project-buffers): Use them.
- (ede-minor-mode, ede-reset-all-buffers): Use it.
- (project-interactive-select-target, project-add-file): Don't use
- ede-project-force-load.
- (ede-buffer-object): New arg PROJSYM.
- (ede-minor-mode): Remove ede-directory-project-p test.
- (ede-initialize-state-current-buffer): Don't test for
- ede-directory-project-p if there is a matching open project.
- (ede-customize-forms-menu): Prevent error if there is no project.
- (ede-load-project-file): Set ede-constructing to the thing being
- constructed, instead of t.
- (ede-project-force-load): Delete.
-
- * ede/base.el:
- * ede/auto.el:
- * ede/custom.el: New files.
-
- * ede/autoconf-edit.el (autoconf-find-last-macro)
- (autoconf-parameters-for-macro): Parse multiline parameters of
- macros. Optionally ignore case and at bol for macro.
- (autoconf-parameter-strip): Use greedy match for newlines.
- (autoconf-new-automake-string): Delete.
- (autoconf-new-program): Use SRecode to fill an empty file.
-
- * ede/cpp-root.el (ede-create-lots-of-projects-under-dir):
- New function.
-
- * ede/files.el (ede-flush-project-hash): New command.
- (ede-convert-path): Add optional PROJECT arg.
- (ede-directory-project-p): Obey ".ede-ignore".
- (ede-expand-filename-local)
- (ede-expand-filename-impl-via-subproj): New methods.
- (ede-expand-filename-impl): Use them.
- (ede-project-root, ede-project-root-directory): Move to
- ede/auto.el.
-
- * ede/locate.el (ede-locate-flush-hash)
- (ede-locate-create/update-root-database): New methods.
- (initialize-instance): Use ede-locate-flush-hash.
-
- * ede/pmake.el (ede-proj-makefile-insert-variables): If this is
- the top project and not a metasubproject, set TOP to CURDIR.
- (ede-proj-makefile-insert-variables): Output a target's object
- list whether or not the vars are already in the Makefile.
- (ede-pmake-insert-variable-once): New macro.
-
- * ede/project-am.el (project-am-with-makefile-current):
- Add recentf-exclude.
- (project-am-load-makefile): Obey an optional suggested name.
- (project-am-expand-subdirlist): New function.
- (project-am-makefile::project-rescan): Use it. Combine SUBDIRS
- and DIST_SUBDIRS.
- (project-am-meta-type-alist): A list to scan better Makefile.am.
- (project-am-scan-for-targets): Scan also over
- project-am-meta-type-alist.
- (ede-system-include-path): Simple implementation.
- (ede-find-target): Delete. EDE core takes care of this.
- (ede-buffer-mine): Create the searched filename as relative.
- (project-am-load): Simplify, using autoconf-edit.
- (project-am-extract-package-info): Fix separators.
-
- * ede/proj.el (project-run-target): New method.
- (project-make-dist, project-compile-project):
- Use ede-proj-automake-p to determine which kind of compile to use.
- (project-rescan): Call ede-load-project-file.
- (ede-buffer-mine): Add more file names that belong to the project.
- (ede-proj-compilers): Improve error message.
-
- * ede/proj-obj.el (ede-ld-linker): Use the LDDEPS variable.
- (ede-source-c++): Add more C++ extensions.
- (ede-proj-target-makefile-objectcode): Quote initforms.
- Support lex and yacc.
-
- * ede/proj-prog.el (ede-proj-makefile-insert-rules): Remove.
- (ede-proj-makefile-insert-variables): New, add LDDEPS.
- (ede-proj-makefile-insert-automake-post-variables): Add LDADD
- variable. Use ldlibs-local slot. Add a -l to ldlibs strings.
- (ede-proj-target-makefile-program): Swap order of two slots so
- they show up in the same order as in the command line.
- (ede-proj-target-makefile-program): Add ldlibs-local slot.
-
- * ede/proj-shared.el (ede-g++-libtool-shared-compiler):
- Fix inference rule to use cpp files.
- (ede-proj-target-makefile-shared-object): Quote initforms.
-
- * ede/proj-misc.el (ede-proj-target-makefile-miscelaneous):
- * ede/proj-info.el (ede-proj-target-makefile-info):
- * ede/proj-aux.el (ede-proj-target-aux):
- * ede/proj-archive.el (ede-proj-target-makefile-archive):
- * ede/proj-elisp.el (ede-proj-target-elisp)
- (ede-proj-target-elisp-autoloads): Quote initforms.
-
- * ede/srecode.el (ede-srecode-setup): Load autoconf templates.
-
- * ede/shell.el (ede-shell-buffer): Fix buffer name.
-
- * ede/pconf.el (ede-proj-configure-synchronize): If user events
- occur while waiting for the compile process to finish, pull them
- in and discard those events.
-
-2010-09-19 Eric Ludlam <zappo@gnu.org>
-
- Synch Semantic to CEDET 1.0.
-
- * semantic.el (semantic-version): Update to 2.0.
- (semantic-mode-map): Add "," and "m" bindings.
- (navigate-menu): Update.
-
- * semantic/symref.el (semantic-symref-calculate-rootdir):
- New function.
- (semantic-symref-detect-symref-tool): Use it.
-
- * semantic/symref/grep.el (semantic-symref-grep-shell): New var.
- (semantic-symref-perform-search): Use it. Calculate root dir with
- semantic-symref-calculate-rootdir.
- (semantic-symref-derive-find-filepatterns): Improve error message.
-
- * semantic/symref/list.el
- (semantic-symref-results-mode-map): New bindings.
- (semantic-symref-auto-expand-results): New option.
- (semantic-symref-results-dump): Obey auto-expand.
- (semantic-symref-list-expand-all, semantic-symref-regexp)
- (semantic-symref-list-contract-all)
- (semantic-symref-list-map-open-hits)
- (semantic-symref-list-update-open-hits)
- (semantic-symref-list-create-macro-on-open-hit)
- (semantic-symref-list-call-macro-on-open-hits): New functions.
- (semantic-symref-list-menu-entries)
- (semantic-symref-list-menu): New vars.
- (semantic-symref-list-map-open-hits): Move cursor to beginning of
- match before calling the mapped function.
-
- * semantic/doc.el
- (semantic-documentation-comment-preceeding-tag): Do nothing if the
- mode doesn't provide comment-start-skip.
-
- * semantic/scope.el
- (semantic-analyze-scope-nested-tags-default): Strip duplicates.
- (semantic-analyze-scoped-inherited-tag-map): Take the tag we are
- looking for as part of the scoped tags list.
-
- * semantic/html.el (semantic-default-html-setup):
- Add senator-step-at-tag-classes.
-
- * semantic/decorate/include.el
- (semantic-decoration-on-unknown-includes): Change light bgcolor.
- (semantic-decoration-on-includes-highlight-default): Check that
- the include tag has a position.
-
- * semantic/complete.el (semantic-collector-local-members)
- (semantic-complete-read-tag-local-members)
- (semantic-complete-jump-local-members): New class and functions.
- (semantic-complete-self-insert): Save excursion before completing.
-
- * semantic/analyze/complete.el
- (semantic-analyze-possible-completions-default): If no completions
- are found, return the raw by-name-only completion list. Add FLAGS
- arguments. Add support for 'no-tc (type constraint) and
- 'no-unique, or no stripping duplicates.
- (semantic-analyze-possible-completions-default): Add FLAGS arg.
-
- * semantic/util-modes.el
- (semantic-stickyfunc-show-only-functions-p): New option.
- (semantic-stickyfunc-fetch-stickyline): Don't show stickytext for
- the very first line in a buffer.
-
- * semantic/util.el (semantic-hack-search)
- (semantic-recursive-find-nonterminal-by-name)
- (semantic-current-tag-interactive): Delete.
- (semantic-describe-buffer): Fix expand-nonterminal.
- Add lex-syntax-mods, type relation separator char, and command
- separation char.
- (semantic-sanity-check): Only message if called interactively.
-
- * semantic/tag.el (semantic-tag-deep-copy-one-tag): Copy the
- :filename property and the tag position.
-
- * semantic/lex-spp.el (semantic-lex-spp-lex-text-string):
- Add recursion limit.
-
- * semantic/imenu.el (semantic-imenu-bucketize-type-members):
- Make this buffer local, not the obsoleted variable.
-
- * semantic/idle.el: Add breadcrumbs support.
- (semantic-idle-summary-current-symbol-info-default)
- (semantic-idle-tag-highlight)
- (semantic-idle-completion-list-default):
- Use semanticdb-without-unloaded-file-searches for speed, and to
- conform to the controls that specify if the idle timer is supposed
- to be parsing unparsed includes.
- (semantic-idle-symbol-highlight-face)
- (semantic-idle-symbol-maybe-highlight): Rename from *-summary-*.
- Callers changed.
- (semantic-idle-work-parse-neighboring-files-flag): Default to nil.
- (semantic-idle-work-update-headers-flag): New var.
- (semantic-idle-work-for-one-buffer): Use it.
- (semantic-idle-local-symbol-highlight): Rename from
- semantic-idle-tag-highlight.
- (semantic-idle-truncate-long-summaries): New option.
-
- * semantic/ia.el (semantic-ia-cache)
- (semantic-ia-get-completions): Delete. Callers changed.
- (semantic-ia-show-variants): New command.
- (semantic-ia-show-doc): If doc is empty, don't make a temp buffer.
- (semantic-ia-show-summary): If there isn't anything to show, say so.
-
- * semantic/grammar.el (semantic-grammar-create-package):
- Save the buffer even in batch mode.
-
- * semantic/fw.el
- (semanticdb-without-unloaded-file-searches): New macro.
-
- * semantic/dep.el (semantic-dependency-find-file-on-path):
- Fix case dereferencing ede-object when it is a list.
-
- * semantic/db-typecache.el (semanticdb-expand-nested-tag)
- (semanticdb-typecache-faux-namespace): New functions.
- (semanticdb-typecache-file-tags)
- (semanticdb-typecache-merge-streams): Use them.
- (semanticdb-typecache-file-tags): When deriving tags from a file,
- give the mode a chance to monkey with the tag copy.
- (semanticdb-typecache-find-default): Wrap find in save-excursion.
- (semanticdb-typecache-find-by-name-helper): Merge found names down.
-
- * semantic/db-global.el
- (semanticdb-enable-gnu-global-in-buffer): Don't show messages if
- GNU Global is not available and we don't want to throw an error.
-
- * semantic/db-find.el (semanticdb-find-result-nth-in-buffer):
- When trying to normalize the tag to a buffer, don't error if
- set-buffer method doesn't exist.
-
- * semantic/db-file.el (semanticdb-save-db): Simplify msg.
-
- * semantic/db.el (semanticdb-refresh-table): If forcing a
- refresh on a file not in a buffer, use semantic-find-file-noselect
- and delete the buffer after use.
- (semanticdb-current-database-list): When calculating root via
- hooks, force it through true-filename and skip the list of
- possible roots.
-
- * semantic/ctxt.el (semantic-ctxt-imported-packages): New.
-
- * semantic/analyze/debug.el
- (semantic-analyzer-debug-insert-tag): Reset standard output to
- current buffer.
- (semantic-analyzer-debug-global-symbol)
- (semantic-analyzer-debug-missing-innertype): Change "prefix" to
- "symbol" in messages.
-
- * semantic/analyze/refs.el (semantic-analyze-refs-impl)
- (semantic-analyze-refs-proto): When calculating value, make sure
- the found tag is 'similar' to the originating tag.
- (semantic--analyze-refs-find-tags-with-parent): Attempt to
- identify matches via imported symbols of parents.
- (semantic--analyze-refs-full-lookup-with-parents): Do a deep
- search during the brute search.
-
- * semantic/analyze.el
- (semantic-analyze-find-tag-sequence-default): Be robust to
- calculated scopes being nil.
-
- * semantic/bovine/c.el (semantic-c-describe-environment):
- Add project macro symbol array.
- (semantic-c-parse-lexical-token): Add recursion limit.
- (semantic-ctxt-imported-packages, semanticdb-expand-nested-tag):
- New overrides.
- (semantic-expand-c-tag-namelist): Split a full type from a typedef
- out to its own tag.
- (semantic-expand-c-tag-namelist): Do not split out a typedef'd
- inline type if it is an anonymous type.
- (semantic-c-reconstitute-token): Use the optional initializers as
- a clue that some function is probably a constructor.
- When defining the type of these constructors, split the parent name,
- and use only the class part, if applicable.
-
- * semantic/bovine/c-by.el:
- * semantic/wisent/python-wy.el: Regenerate.
-
-2010-07-20 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/db-file.el (object-write): Fix typo in docstring.
-
-2010-06-03 Eric Ludlam <zappo@gnu.org>
-
- * semantic/lex-spp.el
- (semantic-lex-spp-table-write-slot-value): Instead of erroring on
- invalid values during save, just save a nil (Bug#6324).
-
-2010-05-31 Jonathan Marchand <jonathlela@gmail.com> (tiny change)
-
- * ede/cpp-root.el (ede-set-project-variables): Fix feature name
- (bug#6231).
-
-2010-05-02 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Use a mode-line spec rather than a static string in Semantic.
- * semantic/util-modes.el:
- (semantic-minor-modes-format): New var to replace...
- (semantic-minor-modes-status): Remove.
- (semantic-mode-line-update): Construct a mode-line spec rather than
- a static string so that mouse buttons can be used on individual minor
- modes and so that semantic-mode-line-update only needs to be called
- when global settings are changed.
- (semantic-add-minor-mode, semantic-toggle-minor-mode-globally):
- Call semantic-mode-line-update.
- (semantic-toggle-minor-mode-globally): Don't assume mode is on
- minor-mode-alist, check semantic-minor-mode-alist as well.
- (semantic-stickyfunc-mode, semantic-show-parser-state-auto-marker)
- (semantic-show-parser-state-marker, semantic-show-parser-state-mode)
- (semantic-show-unmatched-syntax-mode, semantic-highlight-edits-mode):
- * semantic/mru-bookmark.el (semantic-mru-bookmark-mode):
- * semantic/idle.el (semantic-idle-scheduler-mode)
- (define-semantic-idle-service, semantic-idle-summary-mode):
- * semantic/decorate/mode.el (semantic-decoration-mode):
- Don't call semantic-mode-line-update any more.
-
-2010-05-02 Stefan Monnier <monnier@iro.umontreal.ca>
-
- Use define-minor-mode in CEDET where applicable.
-
- * srecode/mode.el (srecode-minor-mode, global-srecode-minor-mode):
- Use define-minor-mode.
-
- * semantic/util-modes.el (semantic-add-minor-mode):
- Remove unused arg `keymap' and code redundant with define-minor-mode.
- (semantic-toggle-minor-mode-globally): Only handle arg -1 and 1.
- (semantic-stickyfunc-mode, global-semantic-show-unmatched-syntax-mode)
- (semantic-highlight-func-mode, global-semantic-show-parser-state-mode)
- (global-semantic-highlight-edits-mode, semantic-highlight-edits-mode)
- (semantic-show-unmatched-syntax-mode, semantic-show-parser-state-mode)
- (global-semantic-stickyfunc-mode, global-semantic-highlight-func-mode):
- Use define-minor-mode.
- (semantic-stickyfunc-mode-setup, semantic-highlight-edits-mode-setup)
- (semantic-show-unmatched-syntax-mode-setup)
- (semantic-show-parser-state-mode-setup)
- (semantic-highlight-func-mode-setup): Inline into sole caller.
-
- * semantic/mru-bookmark.el (global-semantic-mru-bookmark-mode)
- (semantic-mru-bookmark-mode): Use define-minor-mode.
- (semantic-mru-bookmark-mode-setup): Inline into sole caller.
-
- * semantic/idle.el (define-semantic-idle-service):
- Use define-minor-mode and inline setup function into its sole caller.
- (semantic-idle-scheduler-mode-setup)
- (semantic-idle-summary-mode-setup): Inline into sole caller.
- (global-semantic-idle-scheduler-mode, semantic-idle-scheduler-mode):
- Use define-minor-mode.
-
- * semantic/decorate/mode.el (global-semantic-decoration-mode)
- (semantic-decoration-mode): Use define-minor-mode.
- (semantic-decoration-mode-setup): Inline into sole caller.
-
- * ede/dired.el (ede-dired-minor-mode): Initialize in declaration.
- (ede-dired-minor-mode): Use define-minor-mode and derived-mode-p.
- (ede-dired-add-to-target): Use dolist.
-
-2010-04-29 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic.el (semantic-completion-at-point-function):
- New function.
- (semantic-mode): Use semantic-completion-at-point-function for
- completion-at-point-functions instead.
-
-2010-04-28 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic.el (semantic-mode): When enabled, add
- semantic-ia-complete-symbol to completion-at-point-functions.
-
- * semantic/ia.el (semantic-ia-complete-symbol): Return nil
- if Semantic is not active.
-
-2010-04-19 Chong Yidong <cyd@stupidchicken.com>
-
- * ede/pmake.el (ede-proj-makefile-insert-variables):
- Don't destroy list before using it.
-
-2010-04-02 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/imenu.el (semantic-imenu-bucketize-type-members)
- (semantic-create-imenu-directory-index): Fix typos in docstrings.
- (semantic-imenu-goto-function): Reflow docstring.
-
-2010-03-24 Juanma Barranquero <lekktu@gmail.com>
-
- * srecode/table.el (srecode-template-table): Fix docstring typo.
-
-2010-03-24 Glenn Morris <rgm@gnu.org>
-
- * semantic/bovine/c.el (semantic-c-describe-environment):
- Consistently check ede-object is bound throughout.
-
- * ede/project-am.el (ede-shell-run-something): Declare.
-
-2010-03-13 Eric M. Ludlam <zappo@gnu.org>
-
- * semantic/imenu.el: New file, from the CEDET repository
- (Bug#5412).
-
-2010-03-06 Glenn Morris <rgm@gnu.org>
-
- * semantic/grammar.el (semantic-grammar-header-template):
- Update template copyright to GPLv3+.
-
-2010-02-28 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/db-find.el
- (semanticdb-find-translate-path-brutish-default):
- * ede/make.el (ede-make-check-version):
- Use with-current-buffer instead of save-excursion.
-
-2010-02-24 Eduard Wiebe <usenet@pusto.de>
-
- * semantic/wisent/javascript.el (wisent-javascript-jv-expand-tag):
- Avoid c(ad)ddr and use c(ad)r of cddr (Bug#5640).
-
-2010-02-16 Chong Yidong <cyd@stupidchicken.com>
-
- * data-debug.el (data-debug): Move to extensions group.
-
- * ede.el (ede):
- * srecode.el (srecode):
- * semantic.el (semantic): Put in tools and extensions group.
-
-2010-02-14 Juanma Barranquero <lekktu@gmail.com>
-
- * ede.el (ede-run-target, project-delete-target)
- (project-dist-files, ede-name, ede-documentation, ede-parent-project)
- (ede-adebug-project, ede-adebug-project-parent)
- (ede-adebug-project-root): Fix typos in docstrings.
-
-2010-01-18 Juanma Barranquero <lekktu@gmail.com>
-
- * ede/locate.el (ede-locate-file-in-project)
- (ede-locate-file-in-project-impl): Fix typos in docstrings.
- (ede-enable-locate-on-project): Fix typos in error messages.
-
- * semantic/util-modes.el (semantic-unmatched-syntax-face)
- (semantic-stickyfunc-old-hlf, semantic-stickyfunc-header-line-format)
- (semantic-stickyfunc-sticky-classes, semantic-highlight-func-mode-setup)
- (semantic-stickyfunc-fetch-stickyline): Fix typos in docstrings.
- (semantic-stickyfunc-popup-menu, semantic-highlight-func-popup-menu):
- Fix typos in menu help.
-
- * semantic.el (semantic-require-version, semantic--buffer-cache)
- (semantic-unmatched-syntax-cache-check, semantic-unmatched-syntax-hook)
- (semantic--before-fetch-tags-hook, semantic-new-buffer-fcn-was-run)
- (semantic--umatched-syntax-needs-refresh-p, semantic-elapsed-time)
- (semantic-parse-stream, semantic-parse-region)
- (semantic-parse-region-default, semantic--set-buffer-cache)
- (semantic-minimum-working-buffer-size, semantic-refresh-tags-safe)
- (semantic-bovinate-toplevel, semantic-load-system-cache-loaded)
- (semantic-default-submodes):
- * semantic/db-ebrowse.el (semanticdb-table-ebrowse)
- (semanticdb-create-ebrowse-database)
- (semanticdb-find-tags-for-completion-method)
- (semanticdb-find-tags-by-class-method)
- (semanticdb-deep-find-tags-by-name-method)
- (semanticdb-deep-find-tags-for-completion-method):
- * semantic/db-el.el (semanticdb-elisp-mapatom-collector)
- (semanticdb-find-tags-by-name-method, emacs-lisp-mode)
- (semanticdb-find-tags-for-completion-method)
- (semanticdb-find-tags-by-class-method)
- (semanticdb-deep-find-tags-for-completion-method):
- * semantic/db-find.el (semanticdb-find-translate-path)
- (semanticdb-find-need-cache-update-p, semanticdb-find-result-with-nil-p)
- (semanticdb-find-scanned-include-tags, semanticdb-find-tags-collector)
- (semanticdb-find-tags-by-name-method)
- (semanticdb-find-tags-by-name-regexp-method)
- (semanticdb-find-tags-for-completion-method)
- (semanticdb-find-tags-by-class-method)
- (semanticdb-find-tags-external-children-of-type-method)
- (semanticdb-find-tags-subclasses-of-type-method)
- (semanticdb-deep-find-tags-by-name-method)
- (semanticdb-deep-find-tags-by-name-regexp-method)
- (semanticdb-deep-find-tags-for-completion-method):
- * semantic/db-global.el (semanticdb-enable-gnu-global-hook)
- (semanticdb-enable-gnu-global-in-buffer)
- (semanticdb-find-tags-for-completion-method)
- (semanticdb-deep-find-tags-by-name-method)
- (semanticdb-deep-find-tags-for-completion-method):
- * semantic/db-javascript.el (semanticdb-javascript-tags)
- (javascript-mode, semanticdb-find-translate-path)
- (semanticdb-find-tags-for-completion-method)
- (semanticdb-find-tags-by-class-method)
- (semanticdb-deep-find-tags-by-name-method)
- (semanticdb-deep-find-tags-for-completion-method)
- (semanticdb-find-tags-external-children-of-type-method):
- * semantic/idle.el (semantic-idle-work-core-handler)
- (define-semantic-idle-service, semantic-idle-summary-useful-context-p)
- (global-semantic-idle-scheduler-mode):
- * srecode/dictionary.el (srecode-field-value)
- (srecode-dictionary-add-section-dictionary):
- Fix typos in docstrings.
-
-2010-01-17 Glenn Morris <rgm@gnu.org>
-
- * semantic/idle.el (semantic-idle-work-for-one-buffer): Doc fix.
-
-2010-01-17 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic.el (semantic-mode): Fix typos in docstrings.
-
-2010-01-16 Mario Lang <mlang@delysid.org>
-
- * ede/cpp-root.el (ede-cpp-root-project):
- * ede/files.el (ede-expand-filename):
- * ede/simple.el (ede-simple-project):
- * semantic/complete.el (semantic-complete-read-tag-engine)
- (semantic-complete-inline-tag-engine):
- * semantic/db-el.el (semanticdb-equivalent-mode):
- * semantic/db-global.el (semanticdb-equivalent-mode):
- * semantic/db-javascript.el (semanticdb-equivalent-mode):
- * semantic/db.el (semanticdb-equivalent-mode):
- * semantic/decorate/include.el (semantic-decoration-unknown-include-describe):
- * semantic/idle.el (semantic-idle-work-for-one-buffer):
- Remove duplicated words in doc-strings.
-
-2010-01-14 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/edit.el (semantic-reparse-needed-change-hook)
- (semantic-no-reparse-needed-change-hook):
- * srecode/insert.el (srecode-resolve-argument-list)
- (srecode-template-inserter-blank, srecode-template-inserter-variable)
- (srecode-template-inserter-ask, srecode-template-inserter-width)
- (srecode-template-inserter-section-start)
- (srecode-template-inserter-section-end, srecode-insert-method):
- Fix typos in docstrings.
-
-2010-01-12 Juanma Barranquero <lekktu@gmail.com>
-
- * data-debug.el (data-debug): Fix customization group reference.
-
-2010-01-12 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/analyze.el (semantic-analyze-push-error)
- (semantic-analyze-context, semantic-analyze-context-assignment)
- (semantic-analyze-find-tag-sequence, semantic-analyze-find-tag):
- * semantic/java.el (java-mode, semantic-tag-include-filename)
- (semantic-java-doc-keywords-map):
- * semantic/bovine/c.el (c-mode, semantic-c-member-of-autocast)
- (semantic-lex-c-nested-namespace-ignore-second, semantic-parse-region)
- (semantic-c-parse-lexical-token, semantic-c-debug-mode-init-pch)
- (semantic-c-classname, semantic-format-tag-uml-prototype)
- (semantic-c-dereference-namespace, semantic-analyze-type-constants):
- * semantic/bovine/el.el (semantic-elisp-form-to-doc-string)
- (semantic-emacs-lisp-obsoleted-doc, semantic-up-context)
- (semantic-get-local-variables, semantic-end-of-command)
- (semantic-beginning-of-command, semantic-ctxt-current-class-list)
- (lisp-mode):
- * semantic/bovine/make.el (makefile-mode):
- * semantic/wisent/python.el (wisent-python-string-re)
- (wisent-python-implicit-line-joining-p, wisent-python-forward-string)
- (wisent-python-lex-beginning-of-line, wisent-python-lex-end-of-line)
- (semantic-lex, semantic-get-local-variables, python-mode):
- * semantic/wisent/python-wy.el (wisent-python-wy--keyword-table):
- * srecode/extract.el (srecode-extract-state-set)
- (srecode-extract-method): Fix typos in docstrings.
-
-2010-01-10 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic.el (semantic-new-buffer-setup-functions):
- Add python parser.
-
-2010-01-10 Richard Kim <emacs18@gmail.com>
-
- * semantic/wisent/python-wy.el:
- * semantic/wisent/python.el: New files.
-
-2010-01-02 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/db-typecache.el (semanticdb-typecache-find-default):
- Fix typo in docstring.
-
-2009-12-14 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/mru-bookmark.el (global-semantic-mru-bookmark-mode)
- (semantic-mru-bookmark-mode): Doc fixes.
-
- * semantic/db.el (semanticdb-cache-get): Use error instead
- of assert.
-
-2009-12-05 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/ia.el (semantic-ia-complete-symbol):
- Make argument optional.
-
-2009-12-05 Eric Ludlam <zappo@gnu.org>
-
- * semantic/bovine/c.el (semantic-c-describe-environment):
- Describe project macro symbols.
-
- * semantic/complete.el (semantic-complete-do-completion):
- Don't call semantic-collector-current-exact-match.
-
- * ede.el (ede-apply-preprocessor-map): Accept lists of
- ede-objects as targets.
-
- * ede/pmake.el (ede-proj-makefile-insert-variables):
- Output a target's object list even if compiler vars are already in the
- Makefile.
-
- * ede/emacs.el (ede-preprocessor-map): Add config.h to the
- list of headers producing necessary macros.
-
-2009-11-24 Glenn Morris <rgm@gnu.org>
-
- * semantic/idle.el (global-semantic-idle-scheduler-mode):
- Move after definition of global-semantic-idle-tag-highlight-mode.
-
-2009-11-22 Chong Yidong <cyd@stupidchicken.com>
-
- * srecode/map.el (srecode-get-maps):
- * semantic/wisent/wisent.el (wisent-parse-toggle-verbose-flag):
- * semantic/wisent/comp.el (wisent-toggle-verbose-flag):
- * semantic/decorate/mode.el (semantic-decoration-mode)
- (semantic-toggle-decoration-style):
- * semantic/decorate/include.el
- (semantic-decoration-include-describe)
- (semantic-decoration-unknown-include-describe)
- (semantic-decoration-unparsed-include-describe)
- (semantic-decoration-all-include-summary):
- * semantic/bovine/c.el (semantic-c-debug-mode-init):
- * semantic/analyze/complete.el
- (semantic-analyze-possible-completions):
- * semantic/util-modes.el (semantic-highlight-edits-mode)
- (semantic-show-unmatched-syntax-mode)
- (semantic-show-parser-state-mode, semantic-stickyfunc-mode)
- (semantic-highlight-func-mode):
- * semantic/util.el (semantic-describe-buffer):
- * semantic/symref.el (semantic-symref-find-references-by-name)
- (semantic-symref-find-tags-by-name)
- (semantic-symref-find-tags-by-regexp)
- (semantic-symref-find-tags-by-completion)
- (semantic-symref-find-file-references-by-name)
- (semantic-symref-find-text):
- * semantic/senator.el (senator-copy-tag, senator-kill-tag)
- (senator-yank-tag):
- * semantic/scope.el (semantic-calculate-scope):
- * semantic/mru-bookmark.el (semantic-mru-bookmark-mode):
- * semantic/idle.el (semantic-idle-scheduler-mode)
- (define-semantic-idle-service):
- * semantic/complete.el (semantic-complete-analyze-inline)
- (semantic-complete-analyze-inline-idle):
- * semantic/analyze.el (semantic-analyze-current-context):
- * mode-local.el (describe-mode-local-bindings)
- (describe-mode-local-bindings-in-mode):
- * ede/make.el (ede-make-check-version):
- * ede/locate.el (ede-enable-locate-on-project):
- * cedet-idutils.el (cedet-idutils-expand-filename)
- (cedet-idutils-version-check):
- * cedet-global.el (cedet-gnu-global-expand-filename)
- (cedet-gnu-global-version-check):
- * cedet-cscope.el (cedet-cscope-expand-filename)
- (cedet-cscope-version-check): Use called-interactively-p instead
- of interactive-p.
-
- * semantic/ia.el (semantic-ia-completion-format-tag-function):
- Use semantic-format-tag-prototype.
-
-2009-11-21 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/complete.el (semantic-complete-read-tag-engine)
- (semantic-complete-jump-local, semantic-complete-jump):
- Improve prompt string.
-
-2009-11-20 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/complete.el (semantic-complete-inline-map): Doc fix.
-
- * semantic/idle.el (define-semantic-idle-service)
- (semantic-idle-summary-mode, semantic-idle-completions): Doc fix.
-
-2009-11-20 Chong Yidong <cyd@stupidchicken.com>
-
- * cedet.el (cedet-menu-map): Re-order menu items.
-
- * semantic.el: Enable idle-mode menu items only if
- global-semantic-idle-scheduler-mode is enabled.
- (semantic-default-submodes): Doc fix.
-
- * semantic/idle.el (global-semantic-idle-scheduler-mode):
- When turning off, disable other idle modes.
-
-2009-11-15 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/idle.el (semantic-idle-summary-mode)
- (semantic-idle-summary-mode): Define using define-minor-mode
- instead of define-semantic-idle-service.
- (semantic-idle-summary-mode): New function.
- (semantic-idle-summary-mode-setup): Use pre-command-hook to ensure
- that mouse motion does not reset the echo area.
-
-2009-11-08 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/ctxt.el (semantic-get-local-variables):
- Disable the progress reporter entirely.
-
-2009-11-03 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/fw.el (semantic/loaddefs):
- * srecode.el (srecode/loaddefs):
- * ede.el (ede/loaddefs): Load rather than require.
- * ede/cpp-root.el:
- * ede/emacs.el:
- * ede/files.el:
- * ede/linux.el:
- * ede/locate.el:
- * ede/make.el:
- * ede/shell.el:
- * ede/speedbar.el:
- * ede/system.el:
- * ede/util.el:
- * semantic/analyze.el:
- * semantic/bovine.el:
- * semantic/complete.el:
- * semantic/ctxt.el:
- * semantic/db-file.el:
- * semantic/db-find.el:
- * semantic/db-global.el:
- * semantic/db-mode.el:
- * semantic/db-typecache.el:
- * semantic/db.el:
- * semantic/debug.el:
- * semantic/dep.el:
- * semantic/doc.el:
- * semantic/edit.el:
- * semantic/find.el:
- * semantic/format.el:
- * semantic/html.el:
- * semantic/ia-sb.el:
- * semantic/ia.el:
- * semantic/idle.el:
- * semantic/lex-spp.el:
- * semantic/lex.el:
- * semantic/mru-bookmark.el:
- * semantic/scope.el:
- * semantic/senator.el:
- * semantic/sort.el:
- * semantic/symref.el:
- * semantic/tag-file.el:
- * semantic/tag-ls.el:
- * semantic/tag-write.el:
- * semantic/tag.el:
- * semantic/util-modes.el:
- * semantic/analyze/complete.el:
- * semantic/analyze/refs.el:
- * semantic/bovine/c.el:
- * semantic/bovine/gcc.el:
- * semantic/bovine/make.el:
- * semantic/bovine/scm.el:
- * semantic/decorate/include.el:
- * semantic/decorate/mode.el:
- * semantic/symref/cscope.el:
- * semantic/symref/global.el:
- * semantic/symref/grep.el:
- * semantic/symref/idutils.el:
- * semantic/symref/list.el:
- * semantic/wisent/java-tags.el:
- * semantic/wisent/javascript.el:
- * srecode/compile.el:
- * srecode/cpp.el:
- * srecode/document.el:
- * srecode/el.el:
- * srecode/expandproto.el:
- * srecode/getset.el:
- * srecode/insert.el:
- * srecode/java.el:
- * srecode/map.el:
- * srecode/mode.el:
- * srecode/template.el:
- * srecode/texi.el: Remove the file-local setting of
- generated-autoload-feature.
-
-2009-11-03 Glenn Morris <rgm@gnu.org>
-
- * mode-local.el (with-mode-local): Doc fix.
-
-2009-10-31 Chong Yidong <cyd@stupidchicken.com>
-
- * cedet.el (cedet-menu-map): Remove Semantic and EDE menu
- items.
-
- * ede.el (ede-minor-mode):
- * semantic.el (semantic-mode): Toggle menu separators.
-
-2009-10-31 Glenn Morris <rgm@gnu.org>
-
- * semantic/tag.el (semantic--tag-link-list-to-buffer):
- Use mapc rather than mapcar because the return value is never used.
-
- * srecode/template.el, semantic/wisent/javascript.el:
- * semantic/wisent/java-tags.el, semantic/texi.el:
- * semantic/html.el:
- Suppress harmless warnings about setting up semantic-imenu (not
- part of Emacs) variables.
-
-2009-10-30 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * srecode/srt-mode.el (semantic-analyze-possible-completions):
- * semantic/symref/list.el (semantic-symref-rb-toggle-expand-tag):
- * semantic/symref/grep.el (semantic-symref-perform-search):
- * semantic/bovine/gcc.el (semantic-gcc-query):
- * semantic/bovine/c.el (semantic-c-parse-lexical-token):
- * semantic/analyze/debug.el (semantic-analyzer-debug-add-buttons)
- (semantic-analyzer-debug-global-symbol)
- (semantic-analyzer-debug-missing-innertype)
- (semantic-analyzer-debug-insert-include-summary):
- * semantic/util.el (semantic-file-tag-table)
- (semantic-describe-buffer-var-helper, semantic-something-to-tag-table)
- (semantic-recursive-find-nonterminal-by-name):
- * semantic/tag-ls.el (semantic-tag-calculate-parent-default):
- * semantic/tag-file.el (semantic-prototype-file):
- * semantic/symref.el (semantic-symref-parse-tool-output):
- * semantic/sb.el (semantic-sb-fetch-tag-table):
- * semantic/lex-spp.el (semantic-lex-spp-lex-text-string):
- * semantic/idle.el (semantic-idle-work-for-one-buffer)
- (semantic-idle-summary-maybe-highlight):
- * semantic/ia-sb.el (semantic-ia-speedbar)
- (semantic-ia-sb-tag-info):
- * semantic/grammar.el (semantic-analyze-possible-completions):
- * semantic/find.el (semantic-brute-find-tag-by-position):
- * semantic/ede-grammar.el (project-compile-target)
- (ede-proj-makefile-insert-variables):
- * semantic/debug.el (semantic-debug-set-parser-location)
- (semantic-debug-set-source-location, semantic-debug-interface-layout)
- (semantic-debug-mode, semantic-debug):
- * semantic/db.el (semanticdb-needs-refresh-p):
- * semantic/db-typecache.el (semanticdb-typecache-refresh-for-buffer):
- * semantic/db-javascript.el (semanticdb-equivalent-mode):
- * semantic/db-find.el (semanticdb-find-log-new-search)
- (semanticdb-find-translate-path-includes--internal)
- (semanticdb-reset-log, semanticdb-find-log-activity):
- * semantic/db-file.el (object-write):
- * semantic/db-el.el (semanticdb-equivalent-mode):
- * semantic/db-ebrowse.el (semanticdb-ebrowse-C-file-p)
- (semanticdb-create-ebrowse-database):
- * semantic/db-debug.el (semanticdb-table-sanity-check):
- * semantic/complete.el (semantic-displayor-focus-request)
- (semantic-collector-calculate-completions-raw)
- (semantic-complete-read-tag-analyzer):
- * semantic/analyze.el (semantic-analyze-pulse):
- * ede/util.el (ede-update-version-in-source):
- * ede/proj.el (project-delete-target):
- * ede/proj-elisp.el (ede-update-version-in-source)
- (ede-proj-flush-autoconf):
- * ede/pconf.el (ede-proj-configure-synchronize)
- (ede-proj-configure-synchronize):
- * ede/locate.el (ede-locate-file-in-project-impl):
- * ede/linux.el (ede-linux-version):
- * ede/emacs.el (ede-emacs-version):
- * ede/dired.el (ede-dired-add-to-target):
- * ede.el (ede-buffer-header-file, ede-find-target)
- (ede-buffer-documentation-files, ede-project-buffers, ede-set)
- (ede-target-buffers, ede-buffers, ede-make-project-local-variable):
- * cedet-idutils.el (cedet-idutils-fnid-call)
- (cedet-idutils-lid-call, cedet-idutils-expand-filename)
- (cedet-idutils-version-check):
- * cedet-global.el (cedet-gnu-global-call)
- (cedet-gnu-global-expand-filename, cedet-gnu-global-root)
- (cedet-gnu-global-version-check, cedet-gnu-global-scan-hits):
- * cedet-cscope.el (cedet-cscope-call)
- (cedet-cscope-expand-filename, cedet-cscope-version-check):
- Use with-current-buffer.
- * ede.el (ede-make-project-local-variable)
- (ede-set-project-variables, ede-set): Use dolist.
-
-2009-10-28 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * mode-local.el (make-obsolete-overload): Add `when' argument.
- (overload-docstring-extension): Use that info.
- * semantic/fw.el (semantic-alias-obsolete): Pass the `when' info.
- * semantic/idle.el (semantic-eldoc-current-symbol-info):
- * semantic/tag-ls.el (semantic-nonterminal-protection)
- (semantic-nonterminal-abstract, semantic-nonterminal-leaf)
- (semantic-nonterminal-full-name): Add the new `when' info.
- * semantic/decorate/mode.el (semantic/decorate): Require CL for
- `assert'.
-
-2009-10-25 Stefan Monnier <monnier@iro.umontreal.ca>
-
- * semantic/fw.el (semantic-alias-obsolete)
- (semantic-varalias-obsolete): Make the `when' arg mandatory.
- (define-mode-overload-implementation):
- * semantic/decorate/mode.el (semantic-decorate-pending-decoration-hooks):
- * semantic/wisent.el (wisent-lex-make-token-table):
- * semantic/util.el (semantic-file-token-stream)
- (semantic-something-to-stream):
- * semantic/tag.el (semantic-tag-make-assoc-list)
- (semantic-expand-nonterminal):
- * semantic/tag-file.el (semantic-find-nonterminal)
- (semantic-find-dependency, semantic-find-nonterminal)
- (semantic-find-dependency):
- * semantic/lex.el (semantic-flex-start, semantic-flex-end)
- (semantic-flex-text, semantic-flex-make-keyword-table)
- (semantic-flex-keyword-p, semantic-flex-keyword-put)
- (semantic-flex-keyword-get, semantic-flex-map-keywords)
- (semantic-flex-keywords, semantic-flex-buffer, semantic-flex-list):
- * semantic/java.el (semantic-java-prototype-nonterminal):
- * semantic/idle.el (semantic-before-idle-scheduler-reparse-hooks)
- (semantic-after-idle-scheduler-reparse-hooks):
- * semantic/edit.el (semantic-edits-incremental-reparse-failed-hooks):
- * semantic/db-mode.el (semanticdb-mode-hooks):
- * semantic.el (semantic-toplevel-bovine-table)
- (semantic-toplevel-bovine-cache)
- (semantic-before-toplevel-bovination-hook, semantic-init-hooks)
- (semantic-init-mode-hooks, semantic-init-db-hooks)
- (semantic-bovination-working-type): Provide the `when' arg.
-
-2009-10-24 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic/util.el (semantic-recursive-find-nonterminal-by-name):
- * semantic/tag.el (semantic-token-type-parent): Add WHEN
- argument to make-obsolete.
-
- * semantic/fw.el (semantic-alias-obsolete)
- (semantic-varalias-obsolete): Add optional WHEN argument.
-
-2009-10-21 Eric Ludlam <zappo@gnu.org>
-
- * semantic/bovine/c.el (semantic-c-debug-mode-init)
- (semantic-c-debug-mode-init-pch): New functions.
- (semantic-c-debug-mode-init-last-mode): New var.
- (semantic-c-parse-lexical-token): Use them.
-
- * semantic/lex-spp.el (semantic-lex-spp-anlyzer-do-replace):
- When extracting the argument list, limit only by point-max.
-
-2009-10-17 Chong Yidong <cyd@stupidchicken.com>
-
- * srecode/srt.el:
- * srecode/compile.el:
- * semantic/mru-bookmark.el:
- * semantic/debug.el:
- * semantic/complete.el:
- * semantic/analyze.el: Require CL when compiling.
-
-2009-10-17 Eric Ludlam <zappo@gnu.org>
-
- * semantic/scope.el
- (semantic-analyze-scoped-inherited-tag-map): Wrap calculation of
- tmpscope so that the regular scope will continue to work.
-
- * semantic/idle.el (semantic-idle-tag-highlight):
- Use semantic-idle-summary-highlight-face as the highlighting.
-
- * ede/project-am.el (project-run-target): New method.
- (project-run-target): New method.
-
- * ede.el (ede-target): Add run target menu item.
- (ede-project, ede-minor-keymap): Add ede-run-target binding.
- (ede-run-target): New function.
- (ede-target::project-run-target): New method.
-
- * ede/proj.el (project-run-target): New method.
-
- * ede/proj-shared.el (ede-gcc-libtool-shared-compiler)
- (ede-g++-libtool-shared-compiler): Remove SHELL. Remove COMMANDS.
- Add :rules.
- (ede-proj-target-makefile-shared-object): Only libtool compilers
- now available. Add linkers for libtool.
- (ede-cc-linker-libtool, ede-g++-linker-libtool): New.
- (ede-proj-makefile-target-name): Always use .la extension.
-
- * ede/proj-prog.el (project-run-target): New method.
-
- * ede/proj-obj.el (ede-cc-linker): Rename from ede-gcc-linker.
- (ede-g++-linker): Change link lines.
-
- * ede/pmake.el (ede-pmake-insert-variable-shared):
- When searching for old variables, go to the end of the buffer and
- search backward from there.
- (ede-proj-makefile-automake-insert-subdirs)
- (ede-proj-makefile-automake-insert-extradist): New methods.
- (ede-proj-makefile-create): Use them.
-
- * ede/pconf.el (ede-proj-configure-test-required-file):
- Force FILE to expand to the current target. Use file-exists-p to
- check that it exists.
-
- * ede/linux.el (ede-linux-version): Don't call "head".
- (ede-linux-load): Wrap dir in file-name-as-directory.
- Set :version slot.
-
- * ede/files.el (ede-get-locator-object): When enabling
- locate, do so on "top".
-
- * ede/emacs.el (ede-emacs-file-existing): Wrap "dir" in
- file-name-as-directory during compare.
- (ede-emacs-version): Return Emacs/XEmacs differentiator.
- Get version number from different places. Don't call egrep.
- (ede-emacs-load): Set :version slot. Call file-name-as-directory
- to set the directory.
-
- * ede/shell.el: New file.
-
- * inversion.el (inversion-decoders): Allow for stray . in
- alpha/beta variants.
-
-2009-10-17 Glenn Morris <rgm@gnu.org>
-
- * semantic/grammar.el (semantic-grammar--lex-delim-spec):
- All errors should have messages.
-
-2009-10-10 Sascha Wilde <wilde@sha-bang.de>
-
- * ede/proj-shared.el (ede-proj-makefile-target-name):
- Use .la for Automake.
-
-2009-10-09 Chong Yidong <cyd@stupidchicken.com>
-
- * ede/pconf.el (ede-proj-configure-synchronize):
- Use "autoreconf -i". Suggested by Andreas Schwab.
-
-2009-10-08 Chong Yidong <cyd@stupidchicken.com>
-
- * ede/proj.el (project-make-dist, project-compile-project):
- Fix filename test.
- (ede-proj-dist-makefile): Use expand-file-name instead of concat
- to expand file names.
-
-2009-10-08 Chong Yidong <cyd@stupidchicken.com>
-
- * ede/proj-obj.el (ede-gcc-linker): New var.
- (ede-proj-target-makefile-objectcode): Use it.
-
- * ede/source.el (ede-want-any-source-files-p)
- (ede-want-any-auxiliary-files-p, ede-want-any-files-p):
- Return search result. This error was introduced while merging.
-
-2009-10-04 Chong Yidong <cyd@stupidchicken.com>
-
- * semantic.el (semantic-new-buffer-setup-functions): New option.
- (semantic-new-buffer-fcn): Call parser setup functions here.
- (semantic-mode): Don't call parser setup functions here, it's done
- in semantic-new-buffer-fcn now.
- (semantic-mode): Parse all existing buffers when enabled.
-
- * srecode/compile.el (srecode-compile-file):
- Call semantic-new-buffer-fcn if the buffer has not been parsed.
-
-2009-10-04 Chong Yidong <cyd@stupidchicken.com>
-
- * ede/pmake.el (ede-pmake-insert-variable-once): Delete.
-
- * ede/proj-comp.el: Don't require ede/pmake at toplevel.
- (proj-comp-insert-variable-once): New macro, renamed from
- ede-pmake-insert-variable-once in ede/pmake.edl.
- (ede-proj-makefile-insert-variables): Use it.
-
-2009-10-04 Juanma Barranquero <lekktu@gmail.com>
-
- * ede/makefile-edit.el (makefile-beginning-of-command)
- (makefile-end-of-command):
- * srecode/srt-mode.el (semantic-beginning-of-context)
- (semantic-end-of-context): Fix previous change. Doc fixes.
-
-2009-10-04 Juanma Barranquero <lekktu@gmail.com>
-
- * ede/makefile-edit.el (makefile-beginning-of-command)
- (makefile-end-of-command):
- * semantic/lex.el (semantic-lex-token):
- * semantic/analyze/fcn.el
- (semantic-analyze-dereference-metatype-1):
- * semantic/bovine/c.el (semantic-lex-cpp-define)
- (semantic-lex-cpp-undef):
- * semantic/wisent/wisent.el (wisent-skip-block):
- * srecode/srt-mode.el (semantic-beginning-of-context)
- (semantic-end-of-context): Fix typos in docstrings.
-
-2009-10-04 Chong Yidong <cyd@stupidchicken.com>
-
- * ede.el (ede-project-placeholder-cache-file):
- * semantic/db-file.el (semanticdb-default-save-directory):
- * srecode/map.el (srecode-map-save-file):
- Use locate-user-emacs-file. Suggested by Juanma Barranquero.
-
-2009-10-03 Chong Yidong <cyd@stupidchicken.com>
-
- * srecode/insert.el: Require srecode/args.
-
- * srecode/args.el: Require srecode/dictionary instead of
- srecode/insert.
-
- * srecode/srt-mode.el (srecode-template-mode): Doc fix.
-
- * semantic.el (semantic-mode):
- Handle srecode-template-mode-hook as well.
- (semantic-mode): Use js-mode-hook for Javascript hook.
-
- * srecode/template.el: Remove hook variable.
-
- * ede/proj-comp.el: Require ede/pmake when compiling.
-
- * ede.el (ede-target-forms-menu): Don't enable if no
- projects exist.
- (ede-project-placeholder-cache-file): Default to a file in
- user-emacs-directory.
-
- * srecode/map.el (srecode-map-base-template-dir): Look for
- templates in data-directory.
- (srecode-map-save-file): Default to a file in user-emacs-directory.
-
- * ede/srecode.el (ede-srecode-setup): Use default templates
- directory.
-
-2009-09-30 Eric Ludlam <zappo@gnu.org>
-
- * semantic/util-modes.el (semantic-highlight-func-mode):
- Doc fix.
-
- * ede/proj-comp.el (ede-proj-makefile-insert-variables):
- Only insert each variable once.
-
- * ede/pmake.el (ede-pmake-insert-variable-once): New macro.
- (ede-pmake-insert-variable-shared): Use it.
-
- * ede/cpp-root.el (ede-preprocessor-map): Do not deref table
- for lexical table iff table is nil.
-
-2009-10-01 Glenn Morris <rgm@gnu.org>
-
- * semantic/bovine/gcc.el
- (semantic-c-reset-preprocessor-symbol-map): Fix declaration.
- (semantic-gcc-get-include-paths, semantic-gcc-setup-data): Doc fixes.
-
-2009-10-03 Glenn Morris <rgm@gnu.org>
-
- * semantic/db-find.el (data-debug-insert-tag-list): Comment out
- declaration, currently false.
-
-2009-10-01 Glenn Morris <rgm@gnu.org>
-
- * cedet-files.el (cedet-directory-name-to-file-name):
- * cedet-idutils.el (cedet-idutils-search)
- (cedet-idutils-expand-filename, cedet-idutils-support-for-directory)
- (cedet-idutils-version-check):
- * cedet.el (cedet-version):
- * data-debug.el (data-debug-insert-overlay-button)
- (data-debug-insert-overlay-list-button)
- (data-debug-insert-buffer-button)
- (data-debug-insert-buffer-list-button)
- (data-debug-insert-process-button, data-debug-insert-ring-button)
- (data-debug-insert-widget, data-debug-insert-stuff-list-button)
- (data-debug-insert-stuff-vector-button)
- (data-debug-insert-symbol-button, data-debug-insert-string)
- (data-debug-insert-number, data-debug-insert-lambda-expression)
- (data-debug-insert-nil, data-debug-insert-simple-thing)
- (data-debug-insert-custom, data-debug-edebug-expr):
- * ede.el (ede-auto-add-method, ede-project-class-files)
- (global-ede-mode-map, ede-new, ede-debug-target)
- (ede-customize-current-target, ede-buffers, ede-map-buffers, ede-set):
- * semantic.el (semantic-minimum-working-buffer-size)
- (semantic-fetch-tags, semantic-submode-list)
- (semantic-default-submodes):
- * ede/source.el (ede-source-match):
- * ede/project-am.el (project-am-type-alist, project-add-file)
- (project-am-package-info):
- * ede/proj.el (ede-proj-target, project-new-target):
- * ede/proj-elisp.el (ede-proj-tweak-autoconf):
- * ede/proj-comp.el (ede-current-build-list):
- * ede/makefile-edit.el (makefile-move-to-macro):
- * ede/files.el (ede-toplevel-project-or-nil):
- * ede/cpp-root.el (initialize-instance):
- * ede/autoconf-edit.el (autoconf-find-last-macro)
- (autoconf-parameter-strip, autoconf-insert-new-macro):
- * semantic/wisent.el (wisent-lex-eoi):
- * semantic/util-modes.el (global-semantic-show-parser-state-mode)
- (semantic-show-parser-state-mode):
- * semantic/texi.el (semantic-texi-environment-regexp):
- * semantic/tag.el (semantic-tag-new-variable)
- (semantic-tag-class, semantic-tag-new-variable, semantic-tag-copy)
- (semantic--tag-deep-copy-attributes, semantic--tag-deep-copy-value)
- (semantic--tag-deep-copy-tag-list)
- (semantic-tag-components-with-overlays-default):
- * semantic/symref.el (semantic-symref-find-text):
- * semantic/senator.el (senator-yank-tag)
- (senator-transpose-tags-up):
- * semantic/scope.el (semantic-analyze-scoped-tags-default)
- (semantic-analyze-scoped-inherited-tags, semantic-scope-find):
- * semantic/sb.el (semantic-sb-autoexpand-length):
- * semantic/lex.el (semantic-lex-comment-regex)
- (semantic-lex-maximum-depth, define-lex, semantic-lex-token)
- (semantic-lex-unterminated-syntax-protection, define-lex-analyzer):
- * semantic/lex-spp.el
- (semantic-lex-spp-dynamic-macro-symbol-obarray-stack)
- (semantic-lex-spp-symbol, semantic-lex-spp-one-token-to-txt):
- * semantic/idle.el
- (semantic-idle-summary-current-symbol-info-brutish)
- (semantic-idle-summary-current-symbol-info-default):
- * semantic/grammar.el (semantic-grammar-recreate-package)
- (semantic--grammar-macro-compl-dict):
- * semantic/grammar-wy.el (semantic-grammar-wy--parse-table):
- * semantic/format.el (semantic-format-tag-custom-list)
- (semantic-format-tag-canonical-name-default):
- * semantic/find.el (semantic-find-tag-by-overlay-in-region)
- (semantic-find-tags-for-completion)
- (semantic-find-tags-by-scope-protection-default)
- (semantic-deep-find-tags-for-completion):
- * semantic/edit.el
- (semantic-edits-incremental-reparse-failed-hook)
- (semantic-edits-verbose-flag, semantic-edits-assert-valid-region)
- (semantic-edits-splice-remove, semantic-edits-splice-replace):
- * semantic/doc.el (semantic-documentation-comment-preceeding-tag):
- * semantic/dep.el (semantic-dependency-include-path):
- * semantic/db.el (semanticdb-default-find-index-class)
- (semanticdb-match-any-mode, semanticdb-with-match-any-mode)
- (semanticdb-project-roots):
- * semantic/db-find.el (semanticdb-implied-include-tags)
- (semanticdb-find-adebug-insert-scanned-tag-cons)
- (semanticdb-find-log-buffer-name, semanticdb-find-result-mapc)
- (semanticdb-brute-deep-find-tags-for-completion):
- * semantic/db-ebrowse.el (semanticdb-ebrowse-add-tree-to-table):
- * semantic/ctxt.el (semantic-beginning-of-context-default)
- (semantic-end-of-context-default)
- (semantic-ctxt-current-function-default)
- (semantic-ctxt-scoped-types-default):
- * semantic/complete.el (semantic-complete-read-tag-engine)
- (semantic-complete-inline-tag-engine)
- (semantic-complete-inline-custom-type)
- (semantic-complete-read-tag-analyzer):
- * semantic/chart.el (semantic-chart-tags-by-class)
- (semantic-chart-database-size):
- * semantic/analyze.el (semantic-analyze-current-symbol)
- (semantic-analyze-current-context):
- * semantic/symref/list.el (semantic-symref)
- (semantic-symref-hide-buffer, semantic-symref-symbol):
- * semantic/symref/grep.el (semantic-symref-grep-use-template):
- * semantic/symref/filter.el (semantic-symref-hits-in-region):
- * semantic/bovine/el.el (semantic-elisp-form-to-doc-string):
- * semantic/bovine/c.el (semantic-lex-c-preprocessor-symbol-map)
- (semantic-c-parse-token-hack-depth, semantic-c--template-name-1)
- (semantic-c-dereference-template):
- * semantic/analyze/refs.el (semantic--analyze-refs-full-lookup)
- (semantic--analyze-refs-full-lookup-with-parents)
- (semantic--analyze-refs-full-lookup-simple):
- * semantic/analyze/complete.el
- (semantic-analyze-possible-completions):
- * srecode/table.el (srecode-mode-table-new):
- * srecode/srt.el (srecode-read-variable-name):
- * srecode/srt-mode.el (srecode-macro-help, srecode-in-macro-p):
- * srecode/semantic.el (srecode-semantic-handle-:tag)
- (srecode-semantic-handle-:tagtype, srecode-semantic-insert-tag):
- * srecode/map.el (srecode-current-map):
- * srecode/insert.el (srecode-insert)
- (srecode-insert-variable-secondname-handler, srecode-insert-method)
- (srecode-template-inserter-point-override)
- (srecode-insert-include-lookup):
- * srecode/getset.el (srecode-auto-choose-class):
- * srecode/extract.el (srecode-inserter-extract):
- * srecode/document.el
- (srecode-document-autocomment-return-last-alist)
- (srecode-document-autocomment-param-type-alist)
- (srecode-document-insert-function-comment)
- (srecode-document-insert-variable-one-line-comment)
- (srecode-document-function-name-comment):
- * srecode/dictionary.el (srecode-create-dictionary)
- (srecode-compound-toString):
- * srecode/compile.el (srecode-flush-active-templates):
- * srecode/args.el (srecode-semantic-handle-:blank):
- Doc/message fixes.
-
-2009-10-01 Juanma Barranquero <lekktu@gmail.com>
-
- * semantic/wisent/javat-wy.el
- (wisent-java-tags-wy--keyword-table): Use \000 instead of literal ^@.
-
-2009-09-30 Juanma Barranquero <lekktu@gmail.com>
-
- * srecode/expandproto.el: Fix provide statement.
-
-2009-09-30 Sascha Wilde <wilde@sha-bang.de>
-
- * ede/srecode.el: Fix provide statement.
-
-2009-09-30 Glenn Morris <rgm@gnu.org>
-
- * ede/proj.el (ede-proj-target-makefile-miscelaneous):
- * ede/proj-aux.el (ede-aux-source):
- * ede/proj-misc.el (ede-proj-target-makefile-miscelaneous)
- (ede-misc-source):
- * semantic/mru-bookmark.el (semantic-mrub-completing-read)
- (semantic-mrub-switch-tags): Fix doc typos.
-
- * semantic/db-global.el (data-debug-new-buffer)
- (data-debug-insert-thing): Remove unneeded declarations (one broken).
- (semanticdb-enable-gnu-global-databases): Fix prompt typo.
-
- * semantic/analyze/fcn.el (semantic-scope-find): Fix declaration.
-
- * semantic/bovine/gcc.el (semantic-gcc-setup): Replace runtime
- use of CL function `remove-if-not'.
-
-2009-09-29 Glenn Morris <rgm@gnu.org>
-
- * semantic/symref/idutils.el:
- * semantic/symref/list.el: Relicense under GPLv3+.
-
- * ede/srecode.el (srecode-resolve-arguments): Fix declaration.
-
- * semantic/complete.el (semantic-displayor-focus-abstract-child-p):
- * semantic/tag-file.el (semanticdb-table-child-p):
- * srecode/compile.el (srecode-template-inserter-newline-child-p):
- Mark declarations not understood by check-declare.
-
-2009-09-28 Eric Ludlam <zappo@gnu.org>
-
- CEDET (development tools) package merged.
-
- * *.el:
- * ede/*.el:
- * semantic/*.el:
- * srecode/*.el: New files.
-
-2009-09-28 Eric Ludlam <zappo@gnu.org>
-
- * cedet-cscope.el:
- * cedet-files.el:
- * cedet-global.el:
- * cedet-idutils.el:
- * data-debug.el:
- * inversion.el:
- * mode-local.el:
- * pulse.el: New files.
-
-;; Local Variables:
-;; coding: utf-8
-;; End:
-
- Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
+++ /dev/null
-;;; cedet-cscope.el --- CScope support for CEDET -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Package: cedet
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Support using CScope for symbol lookups.
-
-;;; Code:
-
-(defvar cedet-cscope-min-version "15.7"
- "Minimum version of CScope required.")
-
-(defcustom cedet-cscope-command "cscope"
- "Command name for the CScope executable."
- :type 'string
- :group 'cedet)
-
-(defun cedet-cscope-search (searchtext texttype type _scope)
- "Perform a search with CScope, return the created buffer.
-SEARCHTEXT is text to find.
-TEXTTYPE is the type of text, such as `regexp', `string', `tagname',
-`tagregexp', or `tagcompletions'.
-TYPE is the type of search, meaning that SEARCHTEXT is compared to
-filename, tagname (tags table), references (uses of a tag) , or
-symbol (uses of something not in the tag table.)
-SCOPE is the scope of the search, such as `project' or `subdir'."
- ;; CScope is an interactive program. It uses number flags
- ;; in order to perform command line searches. Useful for this
- ;; tool are:
- ;;
- ;; -0 = Find C symbol
- ;; -1 = Find global definition
- ;; -3 = Find references
- ;; -6 = Find grep -E pattern
- ;; -7 = Find file
- (let ((idx (cond ((eq type 'file)
- "-7")
- ;; Non files are symbols and such
- ((eq texttype 'tagname)
- "-1")
- ((eq texttype 'tagregexp)
- "-0")
- ((eq texttype 'tagcompletions)
- (setq searchtext (concat "^" searchtext ".*"))
- "-1")
- ((eq texttype 'regexp)
- "-5")
- (t
- "-3")
- )
- )
- )
- (cedet-cscope-call (list "-d" "-L" idx searchtext))))
-
-(defun cedet-cscope-create (flags)
- "Create a CScope database at the current directory.
-FLAGS are additional flags to pass to cscope beyond the
-options -cR."
- (cedet-cscope-call (append (list "-cR") flags)))
-
-(defun cedet-cscope-call (flags)
- "Call CScope with the list of FLAGS."
- (let ((b (get-buffer-create "*CEDET CScope*"))
- (cd default-directory)
- )
- (with-current-buffer b
- (setq default-directory cd)
- (erase-buffer))
- (apply #'call-process cedet-cscope-command
- nil b nil
- flags)
- b))
-
-(defun cedet-cscope-expand-filename (filename)
- "Expand the FILENAME with CScope.
-Return a fully qualified filename."
- (interactive "sFile: ")
- (let* ((ans1 (with-current-buffer
- (cedet-cscope-call (list "-d" "-L" "-7" filename))
- (goto-char (point-min))
- (if (looking-at "[^ \n]*cscope: ")
- (error "CScope not available")
- (split-string (buffer-string) "\n" t))))
- (ans2 (mapcar (lambda (hit)
- (expand-file-name (car (split-string hit " "))))
- ans1)))
- (when (called-interactively-p 'interactive)
- (if ans2
- (if (= (length ans2) 1)
- (message "%s" (car ans2))
- (message "%s + %d others" (car ans2)
- (length (cdr ans2))))
- (error "No file found")))
- ans2))
-
-(defun cedet-cscope-support-for-directory (&optional dir)
- "Return non-nil if CScope has a support file for DIR.
-If DIR is not supplied, use the current default directory.
-This works by running cscope on a bogus symbol, and looking for
-the error code."
- (interactive "DDirectory: ")
- (save-excursion
- (let ((default-directory (or dir default-directory)))
- (set-buffer (cedet-cscope-call (list "-d" "-L" "-7" "moose")))
- (goto-char (point-min))
- (let ((ans (looking-at "[^ \n]*cscope: ")))
- (if (called-interactively-p 'interactive)
- (if ans
- (message "No support for CScope in %s" default-directory)
- (message "CScope is supported in %s" default-directory))
- (if ans
- nil
- t))))))
-
-(defun cedet-cscope-version-check (&optional noerror)
- "Check the version of the installed CScope command.
-If optional programmatic argument NOERROR is non-nil,
-then instead of throwing an error if CScope isn't available,
-return nil."
- (interactive)
- (let ((b (condition-case nil
- (cedet-cscope-call (list "-V"))
- (error nil)))
- (rev nil))
- (if (not b)
- (progn
- (when (called-interactively-p 'interactive)
- (message "CScope not found."))
- nil)
- (with-current-buffer b
- (goto-char (point-min))
- (re-search-forward "cscope: version \\([0-9.]+\\)" nil t)
- (setq rev (match-string 1))
- (if (version< rev cedet-cscope-min-version)
- (if noerror
- nil
- (error "Version of CScope is %s. Need at least %s"
- rev cedet-cscope-min-version))
- ;; Else, return TRUE, as in good enough.
- (when (called-interactively-p 'interactive)
- (message "CScope %s - Good enough for CEDET." rev))
- t)))))
-
-(defun cedet-cscope-create/update-database (&optional dir)
- "Create a CScope database in DIR.
-CScope will automatically choose incremental rebuild if
-there is already a database in DIR."
- (interactive "DDirectory: ")
- (let ((default-directory dir))
- (cedet-cscope-create nil)))
-
-(provide 'cedet-cscope)
-
-;;; cedet-cscope.el ends here
+++ /dev/null
-;;; cedet-files.el --- Common routines dealing with file names. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Package: cedet
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Various useful routines for dealing with file names in the tools
-;; which are a part of CEDET.
-
-;;; Code:
-
-(defun cedet-directory-name-to-file-name (referencedir &optional testmode)
- "Convert the REFERENCEDIR (a full path name) into a filename.
-Convert directory separation characters into ! characters.
-Optional argument TESTMODE is used by tests to avoid conversion
-to the file's truename, and dodging platform tricks."
- (let ((file referencedir))
- ;; Expand to full file name
- (when (not testmode)
- (setq file (file-truename file)))
- ;; If FILE is a directory, then force it to end in /.
- (when (file-directory-p file)
- (setq file (file-name-as-directory file)))
- ;; Handle Windows Special cases
- (when (or (memq system-type '(windows-nt ms-dos)) testmode)
- ;; Replace any invalid file-name characters (for the
- ;; case of backing up remote files).
- (when (not testmode)
- (setq file (expand-file-name (convert-standard-filename file))))
- ;; Normalize DOSish file names.
- (if (eq (aref file 1) ?:)
- (setq file (concat "/"
- "drive_"
- (char-to-string (downcase (aref file 0)))
- (if (eq (aref file 2) ?/)
- ""
- "/")
- (substring file 2)))))
- ;; Make the name unique by substituting directory
- ;; separators. It may not really be worth bothering about
- ;; doubling `!'s in the original name...
- (setq file (subst-char-in-string
- ?/ ?!
- (string-replace "!" "!!" file)))
- file))
-
-(defun cedet-file-name-to-directory-name (referencefile &optional testmode)
- "Reverse the process of `cedet-directory-name-to-file-name'.
-Convert REFERENCEFILE to a directory name replacing ! with /.
-Optional TESTMODE is used in tests to avoid doing some platform
-specific conversions during tests."
- (let ((file referencefile))
- ;; Replace the ! with /
- (setq file (subst-char-in-string ?! ?/ file))
- ;; Occurrences of // meant there was once a single !.
- (setq file (string-replace "//" "!" file))
-
- ;; Handle Windows special cases
- (when (or (memq system-type '(windows-nt ms-dos)) testmode)
-
- ;; Handle drive letters from DOSish file names.
- (when (string-match "^/drive_\\([a-z]\\)/" file)
- (let ((driveletter (match-string 1 file))
- )
- (setq file (concat driveletter ":"
- (substring file (match-end 1))))))
-
- ;; Handle the \\file\name nomenclature on some Windows boxes.
- (when (string-match "^!" file)
- (setq file (concat "//" (substring file 1)))))
- file))
-
-(defun cedet-files-list-recursively (dir re)
- "Return list of files in directory matching to given regex."
- (when (file-accessible-directory-p dir)
- (let ((files (directory-files dir t))
- matched)
- (dolist (file files matched)
- (let ((fname (file-name-nondirectory file)))
- (cond
- ((or (string= fname ".")
- (string= fname "..")) nil)
- ((and (file-regular-p file)
- (string-match re fname))
- (setq matched (cons file matched)))
- ((file-directory-p file)
- (let ((tfiles (cedet-files-list-recursively file re)))
- (when tfiles (setq matched (append matched tfiles)))))))))))
-
-
-(provide 'cedet-files)
-
-;;; cedet-files.el ends here
+++ /dev/null
-;;; cedet-global.el --- GNU Global support for CEDET. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Package: cedet
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Basic support for calling GNU Global, and testing version numbers.
-
-(defvar cedet-global-min-version "5.0"
- "Minimum version of GNU Global required.")
-
-(defcustom cedet-global-command "global"
- "Command name for the GNU Global executable."
- :type 'string
- :group 'cedet)
-
-(defcustom cedet-global-gtags-command "gtags"
- "Command name for the GNU Global gtags executable.
-GTAGS is used to create the tags table queried by the `global' command."
- :type 'string
- :group 'cedet)
-
-;;; Code:
-(defun cedet-gnu-global-search (searchtext texttype type scope)
- "Perform a search with GNU Global, return the created buffer.
-SEARCHTEXT is text to find.
-TEXTTYPE is the type of text, such as `regexp', `string', `tagname',
-`tagregexp', or `tagcompletions'.
-TYPE is the type of search, meaning that SEARCHTEXT is compared to
-filename, tagname (tags table), references (uses of a tag) , or
-symbol (uses of something not in the tag table.)
-SCOPE is the scope of the search, such as `project' or `subdirs'."
- (let ((flgs (cond ((eq type 'file)
- "-a")
- (t "-xa")))
- (scopeflgs (cond
- ((eq scope 'project)
- ""
- )
- ((eq scope 'target)
- "l")))
- (stflag (cond ((or (eq texttype 'tagname)
- (eq texttype 'tagregexp))
- "")
- ((eq texttype 'tagcompletions)
- "c")
- ((eq texttype 'regexp)
- "g")
- (t "r"))))
- (cedet-gnu-global-call (list (concat flgs scopeflgs stflag)
- searchtext))))
-
-(defun cedet-gnu-global-call (flags)
- "Call GNU Global with the list of FLAGS."
- (let ((b (get-buffer-create "*CEDET Global*"))
- (cd default-directory))
- (with-current-buffer b
- (setq default-directory cd)
- (erase-buffer))
- (apply #'call-process cedet-global-command
- nil b nil
- flags)
- b))
-
-(defun cedet-gnu-global-gtags-call (flags)
- "Create GNU Global TAGS using gtags with FLAGS."
- (let ((b (get-buffer-create "*CEDET Global gtags*"))
- (cd default-directory)
- )
- (with-current-buffer b
- (setq default-directory cd)
- (erase-buffer))
- (apply #'call-process cedet-global-gtags-command
- nil b nil
- flags)
-
- ;; Check for warnings.
- (with-current-buffer b
- (goto-char (point-min))
- (when (re-search-forward "Error\\|Warning\\|invalid" nil t)
- (error "Output:\n%S" (buffer-string))))
-
- b))
-
-(defun cedet-gnu-global-expand-filename (filename)
- "Expand the FILENAME with GNU Global.
-Return a list of absolute filenames or nil if none found.
-Signal an error if GNU global not available."
- (interactive "sFile: ")
- (let ((ans (with-current-buffer (cedet-gnu-global-call (list "-Pa" filename))
- (goto-char (point-min))
- (if (looking-at "global: ")
- (error "GNU Global not available")
- (split-string (buffer-string) "\n" t)))))
- (when (called-interactively-p 'interactive)
- (if ans
- (if (= (length ans) 1)
- (message "%s" (car ans))
- (message "%s + %d others" (car ans)
- (length (cdr ans))))
- (error "No file found")))
- ans))
-
-(defun cedet-gnu-global-show-root ()
- "Show the root of a GNU Global area under the current buffer."
- (interactive)
- (message "%s" (cedet-gnu-global-root)))
-
-(defun cedet-gnu-global-root (&optional dir)
- "Return the root of any GNU Global scanned project containing DIR.
-Returns nil if no GNU Global project can be found.
-DIR defaults to `default-directory'."
- (let ((default-directory (or dir default-directory)))
- (with-current-buffer (cedet-gnu-global-call (list "-pq"))
- (goto-char (point-min))
- (when (not (eobp))
- (file-name-as-directory
- (buffer-substring (point) (line-end-position)))))))
-
-(defun cedet-gnu-global-version-check (&optional noerror)
- "Check the version of the installed GNU Global command.
-If optional programmatic argument NOERROR is non-nil,
-then instead of throwing an error if Global isn't available,
-return nil."
- (interactive)
- (let ((b (condition-case nil
- (cedet-gnu-global-call (list "--version"))
- (error nil)))
- (rev nil))
- (if (not b)
- (progn
- (when (called-interactively-p 'interactive)
- (message "GNU Global not found."))
- nil)
- (with-current-buffer b
- (goto-char (point-min))
- (re-search-forward
- (rx (or
- ;; global (Global) 6.6.10
- "global (Global)"
- (seq (opt "(") "GNU GLOBAL" (opt ")")))
- " "
- (group (one-or-more (any "0-9."))))
- nil t)
- (setq rev (match-string 1))
- (if (version< rev cedet-global-min-version)
- (if noerror
- nil
- (error "Version of GNU Global is %s. Need at least %s"
- rev cedet-global-min-version))
- ;; Else, return TRUE, as in good enough.
- (when (called-interactively-p 'interactive)
- (message "GNU Global %s - Good enough for CEDET." rev))
- t)))))
-
-(defun cedet-gnu-global-scan-hits (buffer)
- "Scan all the hits from the GNU Global output BUFFER."
- (let ((hits nil)
- (r1 "^\\([^ ]+\\) +\\([0-9]+\\) \\([^ ]+\\) "))
- (with-current-buffer buffer
- (goto-char (point-min))
- (while (re-search-forward r1 nil t)
- (setq hits (cons (cons (string-to-number (match-string 2))
- (match-string 3))
- hits)))
- ;; Return the results
- (nreverse hits))))
-
-(defun cedet-gnu-global-create/update-database (&optional dir)
- "Create a GNU Global database in DIR.
-If a database already exists, then just update it."
- (interactive "DDirectory: ")
- (let ((root (cedet-gnu-global-root dir)))
- (if root (setq dir root))
- (let ((default-directory dir))
- (if root
- ;; Incremental update. This can be either "gtags -i" or
- ;; "global -u"; the gtags manpage says it's better to use
- ;; "global -u".
- (cedet-gnu-global-call (list "-u"))
- (cedet-gnu-global-gtags-call nil)
- )
- )))
-
-(provide 'cedet-global)
-
-;;; cedet-global.el ends here
+++ /dev/null
-;;; cedet-idutils.el --- ID Utils support for CEDET. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2009-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Old-Version: 0.2
-;; Keywords: OO, lisp
-;; Package: cedet
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Basic support calling ID Utils functions, and checking version
-;; numbers.
-
-;;; Code:
-
-(defvar cedet-idutils-min-version "4.0"
- "Minimum version of ID Utils required.")
-
-(defcustom cedet-idutils-file-command "fnid"
- "Command name for the ID Utils executable for searching file names."
- :type 'string
- :group 'cedet)
-
-(defcustom cedet-idutils-token-command "lid"
- "Command name for the ID Utils executable for searching for tokens."
- :type 'string
- :group 'cedet)
-
-(defcustom cedet-idutils-make-command "mkid"
- "Command name for the ID Utils executable for creating token databases."
- :type 'string
- :group 'cedet)
-
-(defun cedet-idutils-search (searchtext texttype type _scope)
- "Perform a search with ID Utils, return the created buffer.
-SEARCHTEXT is text to find.
-TEXTTYPE is the type of text, such as `regexp', `string', `tagname',
-`tagregexp', or `tagcompletions'.
-TYPE is the type of search, meaning that SEARCHTEXT is compared to
-filename, tagname (tags table), references (uses of a tag) , or
-symbol (uses of something not in the tag table.)
-SCOPE is the scope of the search, such as `project' or `subdirs'.
-Note: Scope is not yet supported."
- (if (eq type 'file)
- ;; Calls for file stuff is very simple.
- (cedet-idutils-fnid-call (list searchtext))
- ;; Calls for text searches is more complex.
- (let* ((resultflg (if (eq texttype 'tagcompletions)
- (list "--key=token")
- (list "--result=grep")))
- ;; (scopeflgs (cond ((eq scope 'project) "" ) ((eq scope 'target) "l")))
- (stflag (cond ((or (eq texttype 'tagname)
- (eq texttype 'tagregexp))
- (list "-r" "-w"))
- ((eq texttype 'tagcompletions)
- ;; Add regex to search text for beginning of char.
- (setq searchtext (concat "^" searchtext))
- (list "-r" "-s" ))
- ((eq texttype 'regexp)
- (list "-r"))
- ;; t means 'symbol
- (t (list "-l" "-w"))))
- )
- (cedet-idutils-lid-call (append resultflg nil stflag ;; scopeflgs
- (list searchtext))))))
-
-(defun cedet-idutils-fnid-call (flags)
- "Call ID Utils fnid with the list of FLAGS.
-Return the created buffer with program output."
- (let ((b (get-buffer-create "*CEDET fnid*"))
- (cd default-directory)
- )
- (with-current-buffer b
- (setq default-directory cd)
- (erase-buffer))
- (apply #'call-process cedet-idutils-file-command
- nil b nil
- flags)
- b))
-
-(defun cedet-idutils-lid-call (flags)
- "Call ID Utils lid with the list of FLAGS.
-Return the created buffer with program output."
- (let ((b (get-buffer-create "*CEDET lid*"))
- (cd default-directory)
- )
- (with-current-buffer b
- (setq default-directory cd)
- (erase-buffer))
- (apply #'call-process cedet-idutils-token-command
- nil b nil
- flags)
- b))
-
-(defun cedet-idutils-mkid-call (flags)
- "Call ID Utils mkid with the list of FLAGS.
-Return the created buffer with program output."
- (let ((b (get-buffer-create "*CEDET mkid*"))
- (cd default-directory)
- )
- (with-current-buffer b
- (setq default-directory cd)
- (erase-buffer))
- (apply #'call-process cedet-idutils-make-command
- nil b nil
- flags)
- b))
-
-;;; UTIL CALLS
-;;
-(defun cedet-idutils-expand-filename (filename)
- "Expand the FILENAME with ID Utils.
-Return a filename relative to the default directory."
- (interactive "sFile: ")
- (let ((ans (with-current-buffer (cedet-idutils-fnid-call (list filename))
- (goto-char (point-min))
- (if (looking-at "[^ \n]*fnid: ")
- (error "ID Utils not available")
- (split-string (buffer-string) "\n" t)))))
- (setq ans (mapcar #'expand-file-name ans))
- (when (called-interactively-p 'interactive)
- (if ans
- (if (= (length ans) 1)
- (message "%s" (car ans))
- (message "%s + %d others" (car ans)
- (length (cdr ans))))
- (error "No file found")))
- ans))
-
-(defun cedet-idutils-support-for-directory (&optional dir)
- "Return non-nil if ID Utils has a support file for DIR.
-If DIR is not supplied, use the current default directory.
-This works by running lid on a bogus symbol, and looking for
-the error code."
- (save-excursion
- (let ((default-directory (or dir default-directory)))
- (condition-case nil
- (progn
- (set-buffer (cedet-idutils-fnid-call '("moose")))
- (goto-char (point-min))
- (if (looking-at "[^ \n]*fnid: ")
- nil
- t))
- (error nil)))))
-
-(defun cedet-idutils-version-check (&optional noerror)
- "Check the version of the installed ID Utils command.
-If optional programmatic argument NOERROR is non-nil,
-then instead of throwing an error if Global isn't available,
-return nil."
- (interactive)
- (let ((b (condition-case nil
- (cedet-idutils-fnid-call (list "--version"))
- (error nil)))
- (rev nil))
- (if (not b)
- (progn
- (when (called-interactively-p 'interactive)
- (message "ID Utils not found."))
- nil)
- (with-current-buffer b
- (goto-char (point-min))
- (if (re-search-forward "fnid - \\([0-9.]+\\)" nil t)
- (setq rev (match-string 1))
- (setq rev "0"))
- (if (version< rev cedet-idutils-min-version)
- (if noerror
- nil
- (error "Version of ID Utils is %s. Need at least %s"
- rev cedet-idutils-min-version))
- ;; Else, return TRUE, as in good enough.
- (when (called-interactively-p 'interactive)
- (message "ID Utils %s - Good enough for CEDET." rev))
- t)))))
-
-(defun cedet-idutils-create/update-database (&optional dir)
- "Create an IDUtils database in DIR.
-IDUtils must start from scratch when updating a database."
- (interactive "DDirectory: ")
- (let ((default-directory dir))
- (cedet-idutils-mkid-call nil)))
-
-(provide 'cedet-idutils)
-
-;;; cedet-idutils.el ends here
+++ /dev/null
-;;; cedet.el --- Setup CEDET environment -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-
-;; Author: David Ponce <david@dponce.com>
-;; Maintainer: Eric M. Ludlam <zappo@gnu.org>
-;; Version: 2.0
-;; Keywords: OO, lisp
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;;; Code:
-
-(declare-function inversion-find-version "inversion")
-
-(defconst cedet-version "2.0"
- "Current version of CEDET.")
-(make-obsolete-variable 'cedet-version 'emacs-version "29.1")
-
-(defconst cedet-packages
- `(
- ;;PACKAGE MIN-VERSION INSTALLDIR DOCDIR
- (cedet ,cedet-version "common" "common" )
- (eieio "1.4" nil "eieio" )
- (semantic "2.2" nil "semantic/doc")
- (srecode "1.2" nil "srecode" )
- (ede "1.2" nil "ede" )
- )
- "Table of CEDET packages to install.")
-(make-obsolete-variable 'cedet-packages 'package-built-in-p "29.1")
-
-(defvar cedet-menu-map ;(make-sparse-keymap "CEDET menu")
- (let ((map (make-sparse-keymap "CEDET menu")))
- (define-key map [semantic-force-refresh] #'undefined)
- (define-key map [semantic-edit-menu] #'undefined)
- (define-key map [navigate-menu] #'undefined)
- (define-key map [semantic-options-separator] #'undefined)
- (define-key map [global-semantic-highlight-func-mode] #'undefined)
- (define-key map [global-semantic-stickyfunc-mode] #'undefined)
- (define-key map [global-semantic-decoration-mode] #'undefined)
- (define-key map [global-semantic-idle-completions-mode] #'undefined)
- (define-key map [global-semantic-idle-summary-mode] #'undefined)
- (define-key map [global-semantic-idle-scheduler-mode] #'undefined)
- (define-key map [global-semanticdb-minor-mode] #'undefined)
- (define-key map [cedet-menu-separator] #'undefined)
- (define-key map [ede-find-file] #'undefined)
- (define-key map [ede-speedbar] #'undefined)
- (define-key map [ede] #'undefined)
- (define-key map [ede-new] #'undefined)
- (define-key map [ede-target-options] #'undefined)
- (define-key map [ede-project-options] #'undefined)
- (define-key map [ede-build-forms-menu] #'undefined)
- map)
- "Menu keymap for the CEDET package.
-This is used by `semantic-mode' and `global-ede-mode'.")
-
-(defun cedet-version ()
- "Display all active versions of CEDET and dependent packages.
-
-The PACKAGE column is the name of a given package from CEDET.
-
-REQUESTED VERSION is the version requested by the CEDET load script.
-See `cedet-packages' for details.
-
-FILE VERSION is the version number found in the source file
-for the specified PACKAGE.
-
-LOADED VERSION is the version of PACKAGE currently loaded in Emacs
-memory and (presumably) running in this Emacs instance. Value is X
-if the package has not been loaded."
- (declare (obsolete emacs-version "28.1"))
- (interactive)
- (require 'inversion)
- (with-output-to-temp-buffer "*CEDET*"
- (princ "CEDET Version:\t") (princ cedet-version)
- (princ "\n \t\t\tRequested\tFile\t\tLoaded")
- (princ "\n Package\t\tVersion\t\tVersion\t\tVersion")
- (princ "\n ----------------------------------------------------------")
- (let ((p cedet-packages))
- (while p
- (let ((sym (symbol-name (car (car p)))))
- (princ "\n ")
- (princ sym)
- (princ ":\t")
- (if (< (length sym) 5)
- (princ "\t"))
- (if (< (length sym) 13)
- (princ "\t"))
- (let ((reqver (nth 1 (car p)))
- (filever (car (inversion-find-version sym)))
- (loadver (when (featurep (car (car p)))
- (symbol-value (intern-soft (concat sym "-version"))))))
- (princ reqver)
- (if (< (length reqver) 8) (princ "\t"))
- (princ "\t")
- (if (string= filever reqver)
- ;; I tried the words "check" and "match", but that
- ;; just looked lame.
- (princ "ok\t")
- (princ filever)
- (if (< (length filever) 8) (princ "\t")))
- (princ "\t")
- (if loadver
- (if (string= loadver reqver)
- (princ "ok")
- (princ loadver))
- (princ "Not Loaded"))
- ))
- (setq p (cdr p))))
- (princ "\n\n\nC-h f cedet-version RET\n for details on output format.")
- ))
-
-(provide 'cedet)
-
-;;; cedet.el ends here
+++ /dev/null
-;;; data-debug.el --- Data structure debugger -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Old-Version: 0.2
-;; Keywords: OO, lisp
-;; Package: cedet
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Provide a simple way to investigate particularly large and complex
-;; data structures.
-;;
-;; The best way to get started is to bind M-: to 'data-debug-eval-expression.
-;;
-;; (global-set-key "\M-:" 'data-debug-eval-expression)
-;;
-;; If you write functions with complex output that need debugging, you
-;; can make them interactive with data-debug-show-stuff. For example:
-;;
-;; (defun my-complex-output-fcn ()
-;; "Calculate something complicated at point, and return it."
-;; (interactive) ;; function not normally interactive
-;; (let ((stuff (do-stuff)))
-;; (when (called-interactively-p 'interactive)
-;; (data-debug-show-stuff stuff "myStuff"))
-;; stuff))
-
-(require 'ring)
-
-;;; Code:
-
-;;; Compatibility
-;;
-(define-obsolete-function-alias 'data-debug-overlay-properties #'overlay-properties "28.1")
-(define-obsolete-function-alias 'data-debug-overlay-p #'overlayp "28.1")
-(define-obsolete-function-alias 'dd-propertize #'propertize "28.1")
-
-;;; GENERIC STUFF
-;;
-(defun data-debug-insert-property-list (proplist prefix &optional parent)
- "Insert the property list PROPLIST.
-Each line starts with PREFIX.
-The attributes belong to the tag PARENT."
- (while proplist
- (let ((pretext (concat (symbol-name (car proplist)) " : ")))
- (data-debug-insert-thing (car (cdr proplist))
- prefix
- pretext
- parent))
- (setq proplist (cdr (cdr proplist)))))
-
-;;; overlays
-;;
-(defun data-debug-insert-overlay-props (overlay prefix)
- "Insert all the parts of OVERLAY.
-PREFIX specifies what to insert at the start of each line."
- (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
- (proplist (overlay-properties overlay)))
- (data-debug-insert-property-list
- proplist attrprefix)
- )
- )
-
-(defun data-debug-insert-overlay-from-point (point)
- "Insert the overlay found at the overlay button at POINT."
- (let ((overlay (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start
- )
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-overlay-props overlay
- (concat (make-string indent ? )
- "| "))
- (goto-char start)
- ))
-
-(defun data-debug-insert-overlay-button (overlay prefix prebuttontext)
- "Insert a button representing OVERLAY.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the overlay button."
- (let ((start (point))
- (end nil)
- (str (format "%s" overlay))
- ) ;; (tip nil)
- (insert prefix prebuttontext str)
- (setq end (point))
- (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
- (put-text-property start end 'ddebug overlay)
- (put-text-property start end 'ddebug-indent(length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- ;; (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-overlay-from-point)
- (insert "\n")
- )
- )
-
-;;; overlay list
-;;
-(defun data-debug-insert-overlay-list (overlaylist prefix)
- "Insert all the parts of OVERLAYLIST.
-PREFIX specifies what to insert at the start of each line."
- (while overlaylist
- (data-debug-insert-overlay-button (car overlaylist)
- prefix
- "")
- (setq overlaylist (cdr overlaylist))))
-
-(defun data-debug-insert-overlay-list-from-point (point)
- "Insert the overlay found at the overlay list button at POINT."
- (let ((overlaylist (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start
- )
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-overlay-list overlaylist
- (concat (make-string indent ? )
- "* "))
- (goto-char start)
- ))
-
-(defun data-debug-insert-overlay-list-button (overlaylist
- prefix
- prebuttontext)
- "Insert a button representing OVERLAYLIST.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the overlay list button."
- (let ((start (point))
- (end nil)
- (str (format "#<overlay list: %d entries>" (length overlaylist)))
- ) ;; (tip nil)
- (insert prefix prebuttontext str)
- (setq end (point))
- (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
- (put-text-property start end 'ddebug overlaylist)
- (put-text-property start end 'ddebug-indent(length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- ;; (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-overlay-list-from-point)
- (insert "\n")
- )
- )
-
-;;; buffers
-;;
-(defun data-debug-insert-buffer-props (buffer prefix)
- "Insert all the parts of BUFFER.
-PREFIX specifies what to insert at the start of each line."
- (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
- (proplist
- (list :filename (buffer-file-name buffer)
- :live (buffer-live-p buffer)
- :modified (buffer-modified-p buffer)
- :size (buffer-size buffer)
- :process (get-buffer-process buffer)
- :localvars (buffer-local-variables buffer)
- )))
- (data-debug-insert-property-list
- proplist attrprefix)
- )
- )
-
-(defun data-debug-insert-buffer-from-point (point)
- "Insert the buffer found at the buffer button at POINT."
- (let ((buffer (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start
- )
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-buffer-props buffer
- (concat (make-string indent ? )
- "| "))
- (goto-char start)
- ))
-
-(defun data-debug-insert-buffer-button (buffer prefix prebuttontext)
- "Insert a button representing BUFFER.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the buffer button."
- (let ((start (point))
- (end nil)
- (str (format "%S" buffer))
- ) ;; (tip nil)
- (insert prefix prebuttontext str)
- (setq end (point))
- (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
- (put-text-property start end 'ddebug buffer)
- (put-text-property start end 'ddebug-indent(length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- ;; (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-buffer-from-point)
- (insert "\n")
- )
- )
-
-;;; buffer list
-;;
-(defun data-debug-insert-buffer-list (bufferlist prefix)
- "Insert all the parts of BUFFERLIST.
-PREFIX specifies what to insert at the start of each line."
- (while bufferlist
- (data-debug-insert-buffer-button (car bufferlist)
- prefix
- "")
- (setq bufferlist (cdr bufferlist))))
-
-(defun data-debug-insert-buffer-list-from-point (point)
- "Insert the buffer found at the buffer list button at POINT."
- (let ((bufferlist (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start
- )
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-buffer-list bufferlist
- (concat (make-string indent ? )
- "* "))
- (goto-char start)
- ))
-
-(defun data-debug-insert-buffer-list-button (bufferlist
- prefix
- prebuttontext)
- "Insert a button representing BUFFERLIST.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the buffer list button."
- (let ((start (point))
- (end nil)
- (str (format "#<buffer list: %d entries>" (length bufferlist)))
- ) ;; (tip nil)
- (insert prefix prebuttontext str)
- (setq end (point))
- (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
- (put-text-property start end 'ddebug bufferlist)
- (put-text-property start end 'ddebug-indent(length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- ;; (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-buffer-list-from-point)
- (insert "\n")
- )
- )
-
-;;; processes
-;;
-(defun data-debug-insert-process-props (process prefix)
- "Insert all the parts of PROCESS.
-PREFIX specifies what to insert at the start of each line."
- (let ((attrprefix (concat (make-string (length prefix) ? ) "# "))
- (id (process-id process))
- (tty (process-tty-name process))
- (pcontact (process-contact process t))
- (proplist (process-plist process)))
- (data-debug-insert-property-list
- (append
- (if id (list 'id id))
- (if tty (list 'tty tty))
- (if pcontact pcontact)
- proplist)
- attrprefix)
- )
- )
-
-(defun data-debug-insert-process-from-point (point)
- "Insert the process found at the process button at POINT."
- (let ((process (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start
- )
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-process-props process
- (concat (make-string indent ? )
- "| "))
- (goto-char start)
- ))
-
-(defun data-debug-insert-process-button (process prefix prebuttontext)
- "Insert a button representing PROCESS.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the process button."
- (let ((start (point))
- (end nil)
- (str (format "%S : %s" process (process-status process)))
- ) ;; (tip nil)
- (insert prefix prebuttontext str)
- (setq end (point))
- (put-text-property (- end (length str)) end 'face 'font-lock-comment-face)
- (put-text-property start end 'ddebug process)
- (put-text-property start end 'ddebug-indent(length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- ;; (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-process-from-point)
- (insert "\n")
- )
- )
-
-;;; Rings
-;;
-;; A ring (like kill-ring, or whatever.)
-(defun data-debug-insert-ring-contents (ring prefix)
- "Insert all the parts of RING.
-PREFIX specifies what to insert at the start of each line."
- (let ((len (ring-length ring))
- (idx 0)
- )
- (while (< idx len)
- (data-debug-insert-thing (ring-ref ring idx) prefix "")
- (setq idx (1+ idx))
- )))
-
-(defun data-debug-insert-ring-items-from-point (point)
- "Insert the ring found at the ring button at POINT."
- (let ((ring (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start
- )
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-ring-contents ring
- (concat (make-string indent ? )
- "} "))
- (goto-char start)
- ))
-
-(defun data-debug-insert-ring-button (ring
- prefix
- prebuttontext)
- "Insert a button representing RING.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the stuff list button."
- (let* ((start (point))
- (end nil)
- (str (format "#<RING: %d, %d max>"
- (ring-length ring)
- (ring-size ring)))
- ;; (ringthing
- ;; (if (= (ring-length ring) 0) nil (ring-ref ring 0)))
- (tip (format "Ring max-size %d, length %d."
- (ring-size ring)
- (ring-length ring)))
- )
- (insert prefix prebuttontext str)
- (setq end (point))
- (put-text-property (- end (length str)) end 'face 'font-lock-type-face)
- (put-text-property start end 'ddebug ring)
- (put-text-property start end 'ddebug-indent(length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-ring-items-from-point)
- (insert "\n")
- )
- )
-
-\f
-;;; Hash-table
-;;
-
-(defun data-debug-insert-hash-table (hash-table prefix)
- "Insert the contents of HASH-TABLE inserting PREFIX before each element."
- (maphash
- (lambda (key value)
- (data-debug-insert-thing
- key prefix
- (propertize "key " 'face font-lock-comment-face))
- (data-debug-insert-thing
- value prefix
- (propertize "val " 'face font-lock-comment-face)))
- hash-table))
-
-(defun data-debug-insert-hash-table-from-point (point)
- "Insert the contents of the hash-table button at POINT."
- (let ((hash-table (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start)
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-hash-table
- hash-table
- (concat (make-string indent ? ) "> "))
- (goto-char start))
- )
-
-(defun data-debug-insert-hash-table-button (hash-table prefix prebuttontext)
- "Insert HASH-TABLE as expandable button, using PREFIX and PREBUTTONTEXT.
-PREFIX is a recursive prefix and PREBUTTONTEXT is text to be inserted
-in front of the button text."
- (let ((string (propertize (format "%s" hash-table)
- 'face 'font-lock-keyword-face)))
- (insert (propertize
- (concat prefix prebuttontext string)
- 'ddebug hash-table
- 'ddebug-indent (length prefix)
- 'ddebug-prefix prefix
- 'help-echo
- (format "Hash-table\nTest: %s\nWeakness: %s\nElements: %d (of %d)"
- (hash-table-test hash-table)
- (if (hash-table-weakness hash-table) "yes" "no")
- (hash-table-count hash-table)
- (hash-table-size hash-table))
- 'ddebug-function
- 'data-debug-insert-hash-table-from-point)
- "\n"))
- )
-
-;;; Widget
-;;
-;; Widgets have a long list of properties
-(defun data-debug-insert-widget-properties (widget prefix)
- "Insert the contents of WIDGET inserting PREFIX before each element."
- (let (;; (type (car widget))
- (rest (cdr widget)))
- (while rest
- (data-debug-insert-thing (car (cdr rest))
- prefix
- (concat
- (propertize (format "%s" (car rest))
- 'face font-lock-comment-face)
- " : "))
- (setq rest (cdr (cdr rest))))
- ))
-
-(defun data-debug-insert-widget-from-point (point)
- "Insert the contents of the widget button at POINT."
- (let ((widget (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start)
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-widget-properties
- widget (concat (make-string indent ? ) "# "))
- (goto-char start))
- )
-
-(defun data-debug-insert-widget (widget prefix prebuttontext)
- "Insert one WIDGET.
-A Symbol is a simple thing, but this provides some face and prefix rules.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the thing."
- (let ((string (propertize (format "#<WIDGET %s>" (car widget))
- 'face 'font-lock-keyword-face)))
- (insert (propertize
- (concat prefix prebuttontext string)
- 'ddebug widget
- 'ddebug-indent (length prefix)
- 'ddebug-prefix prefix
- 'help-echo
- (format "Widget\nType: %s\n# Properties: %d"
- (car widget)
- (/ (1- (length widget)) 2))
- 'ddebug-function
- 'data-debug-insert-widget-from-point)
- "\n")))
-
-;;; list of stuff
-;;
-;; just a list. random stuff inside.
-(defun data-debug-insert-stuff-list (stufflist prefix)
- "Insert all the parts of STUFFLIST.
-PREFIX specifies what to insert at the start of each line."
- (while stufflist
- (data-debug-insert-thing
- ;; Some lists may put a value in the CDR
- (if (listp stufflist) (car stufflist) stufflist)
- prefix
- "")
- (setq stufflist
- (if (listp stufflist)
- (cdr-safe stufflist)
- nil))))
-
-(defun data-debug-insert-stuff-list-from-point (point)
- "Insert the stuff found at the stuff list button at POINT."
- (let ((stufflist (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start
- )
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-stuff-list stufflist
- (concat (make-string indent ? )
- "> "))
- (goto-char start)
- ))
-
-(defun data-debug-insert-stuff-list-button (stufflist
- prefix
- prebuttontext)
- "Insert a button representing STUFFLIST.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the stuff list button."
- (let ((start (point))
- (end nil)
- (str
- (condition-case nil
- (format "#<list o' stuff: %d entries>" (safe-length stufflist))
- (error "#<list o' stuff>")))
- (tip (if (or (listp (car stufflist))
- (vectorp (car stufflist)))
- ""
- (format "%s" stufflist))))
- (insert prefix prebuttontext str)
- (setq end (point))
- (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face)
- (put-text-property start end 'ddebug stufflist)
- (put-text-property start end 'ddebug-indent (length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-stuff-list-from-point)
- (insert "\n")
- )
- )
-
-;;; vector of stuff
-;;
-;; just a vector. random stuff inside.
-(defun data-debug-insert-stuff-vector (stuffvector prefix)
- "Insert all the parts of STUFFVECTOR.
-PREFIX specifies what to insert at the start of each line."
- (let ((idx 0))
- (while (< idx (length stuffvector))
- (data-debug-insert-thing
- ;; Some vectors may put a value in the CDR
- (aref stuffvector idx)
- prefix
- "")
- (setq idx (1+ idx)))))
-
-(defun data-debug-insert-stuff-vector-from-point (point)
- "Insert the stuff found at the stuff vector button at POINT."
- (let ((stuffvector (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start
- )
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-stuff-vector stuffvector
- (concat (make-string indent ? )
- "[ "))
- (goto-char start)
- ))
-
-(defun data-debug-insert-stuff-vector-button (stuffvector
- prefix
- prebuttontext)
- "Insert a button representing STUFFVECTOR.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the stuff vector button."
- (let* ((start (point))
- (end nil)
- (str (format "#<vector o' stuff: %d entries>" (length stuffvector)))
- (tip str))
- (insert prefix prebuttontext str)
- (setq end (point))
- (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face)
- (put-text-property start end 'ddebug stuffvector)
- (put-text-property start end 'ddebug-indent (length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-stuff-vector-from-point)
- (insert "\n")
- )
- )
-
-(defun data-debug-insert-stuff-record-button (stuffvector
- prefix
- prebuttontext)
- "Insert a button representing STUFFVECTOR.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the stuff vector button."
- (let* ((start (point))
- (end nil)
- (str (format "#<record o' stuff: %d entries>" (length stuffvector)))
- (tip str))
- (insert prefix prebuttontext str)
- (setq end (point))
- (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face)
- (put-text-property start end 'ddebug stuffvector)
- (put-text-property start end 'ddebug-indent (length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-stuff-vector-from-point)
- (insert "\n")
- )
- )
-
-;;; Symbol
-;;
-
-(defun data-debug-insert-symbol-from-point (point)
- "Insert attached properties and possibly the value of symbol at POINT."
- (let ((symbol (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start)
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (when (and (not (fboundp symbol)) (boundp symbol))
- (data-debug-insert-thing
- (symbol-value symbol)
- (concat (make-string indent ? ) "> ")
- (concat
- (propertize "value"
- 'face 'font-lock-comment-face)
- " ")))
- (data-debug-insert-property-list
- (symbol-plist symbol)
- (concat (make-string indent ? ) "> "))
- (goto-char start))
- )
-
-(defun data-debug-insert-symbol-button (symbol prefix prebuttontext)
- "Insert a button representing SYMBOL.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the symbol button."
- (let ((string
- (cond ((fboundp symbol)
- (propertize (concat "#'" (symbol-name symbol))
- 'face 'font-lock-function-name-face))
- ((boundp symbol)
- (propertize (concat "'" (symbol-name symbol))
- 'face 'font-lock-variable-name-face))
- (t (format "'%s" symbol)))))
- (insert (propertize
- (concat prefix prebuttontext string)
- 'ddebug symbol
- 'ddebug-indent (length prefix)
- 'ddebug-prefix prefix
- 'help-echo ""
- 'ddebug-function
- 'data-debug-insert-symbol-from-point)
- "\n"))
- )
-
-;;; String
-(defun data-debug-insert-string (thing prefix prebuttontext)
- "Insert one symbol THING.
-A Symbol is a simple thing, but this provides some face and prefix rules.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the thing."
- (let ((newstr thing))
- (while (string-match "\n" newstr)
- (setq newstr (replace-match "\\n" t t newstr)))
- (while (string-match "\t" newstr)
- (setq newstr (replace-match "\\t" t t newstr)))
- (insert prefix prebuttontext
- (propertize (format "\"%s\"" newstr)
- 'face font-lock-string-face)
- "\n" )))
-
-;;; Number
-(defun data-debug-insert-number (thing prefix prebuttontext)
- "Insert one symbol THING.
-A Symbol is a simple thing, but this provides some face and prefix rules.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the thing."
- (insert prefix prebuttontext
- (propertize (format "%S" thing)
- 'face font-lock-string-face)
- "\n"))
-
-;;; Lambda Expression
-(defun data-debug-insert-lambda-expression (thing prefix prebuttontext)
- "Insert one lambda expression THING.
-A Symbol is a simple thing, but this provides some face and prefix rules.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the thing."
- (let ((txt (prin1-to-string thing)))
- (data-debug-insert-simple-thing
- txt prefix prebuttontext 'font-lock-keyword-face))
- )
-
-;;; nil thing
-(defun data-debug-insert-nil (_thing prefix prebuttontext)
- "Insert one simple THING with a face.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the thing.
-FACE is the face to use."
- (insert prefix prebuttontext)
- (insert ": ")
- (let ((start (point))
- (end nil))
- (insert "nil")
- (setq end (point))
- (insert "\n" )
- (put-text-property start end 'face 'font-lock-variable-name-face)
- ))
-
-;;; simple thing
-(defun data-debug-insert-simple-thing (thing prefix prebuttontext face)
- "Insert one simple THING with a face.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the thing.
-FACE is the face to use."
- (insert prefix prebuttontext)
- (let ((start (point))
- (end nil))
- (insert (format "%s" thing))
- (setq end (point))
- (insert "\n" )
- (put-text-property start end 'face face)
- ))
-
-;;; custom thing
-(defun data-debug-insert-custom (thingstring prefix prebuttontext face)
- "Insert one simple THINGSTRING with a face.
-Use for simple items that need a custom insert.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the thing.
-FACE is the face to use."
- (insert prefix prebuttontext)
- (let ((start (point))
- (end nil))
- (insert thingstring)
- (setq end (point))
- (insert "\n" )
- (put-text-property start end 'face face)
- ))
-
-
-(defvar data-debug-thing-alist
- '(
- ;; nil
- (null . data-debug-insert-nil)
-
- ;; Overlay
- (overlayp . data-debug-insert-overlay-button)
-
- ;; Overlay list
- ((lambda (thing) (and (consp thing) (overlayp (car thing)))) .
- data-debug-insert-overlay-list-button)
-
- ;; Buffer
- (bufferp . data-debug-insert-buffer-button)
-
- ;; Buffer list
- ((lambda (thing) (and (consp thing) (bufferp (car thing)))) .
- data-debug-insert-buffer-list-button)
-
- ;; Process
- (processp . data-debug-insert-process-button)
-
- ;; String
- (stringp . data-debug-insert-string)
-
- ;; Number
- (numberp . data-debug-insert-number)
-
- ;; Symbol
- (symbolp . data-debug-insert-symbol-button)
-
- ;; Ring
- (ring-p . data-debug-insert-ring-button)
-
- ;; Lambda Expression
- ((lambda (thing) (and (consp thing) (eq (car thing) 'lambda))) .
- data-debug-insert-lambda-expression)
-
- ;; Hash-table
- (hash-table-p . data-debug-insert-hash-table-button)
-
- ;; Widgets
- (widgetp . data-debug-insert-widget)
-
- ;; List of stuff
- (listp . data-debug-insert-stuff-list-button)
-
- ;; Vector of stuff
- (vectorp . data-debug-insert-stuff-vector-button)
-
- ;; Record of stuff
- (recordp . data-debug-insert-stuff-record-button)
- )
- "Alist of methods used to insert things into an Ddebug buffer.")
-
-;; An augmentation function for the thing alist.
-(defun data-debug-add-specialized-thing (predicate fcn)
- "Add a new specialized thing to display with data-debug.
-PREDICATE is a function that returns t if a thing is this new type.
-FCN is a function that will display stuff in the data debug buffer."
- (let ((entry (cons predicate fcn))
- ;; Specialized entries show up AFTER nil,
- ;; but before listp, vectorp, symbolp, and
- ;; other general things. Splice it into
- ;; the beginning.
- (first (nthcdr 0 data-debug-thing-alist))
- (second (nthcdr 1 data-debug-thing-alist))
- )
- (when (not (member entry data-debug-thing-alist))
- (setcdr first (cons entry second)))))
-
-;; uber insert method
-(defun data-debug-insert-thing (thing prefix prebuttontext &optional parent)
- "Insert THING with PREFIX.
-PREBUTTONTEXT is some text to insert between prefix and the thing
-that is not included in the indentation calculation of any children.
-If PARENT is non-nil, it is somehow related as a parent to thing."
- (let ((inhibit-read-only t))
- (when (catch 'done
- (dolist (test data-debug-thing-alist)
- (when (funcall (car test) thing)
- (condition-case nil
- (progn
- (funcall (cdr test) thing prefix prebuttontext parent)
- (throw 'done nil))
- (error
- (condition-case nil
- (progn
- (funcall (cdr test) thing prefix prebuttontext)
- (throw 'done nil))
- (error nil))))
- ;; Only throw the 'done if no error was caught.
- ;; If an error was caught, skip this predicate as being
- ;; unsuccessful, and move on.
- ))
- nil)
- (data-debug-insert-simple-thing (format "%S" thing)
- prefix
- prebuttontext
- 'bold)))
- (set-buffer-modified-p nil))
-
-;;; MAJOR MODE
-;;
-;; The Ddebug major mode provides an interactive space to explore
-;; complicated data structures.
-;;
-(defgroup data-debug nil
- "data-debug group."
- :group 'extensions)
-
-(defvar data-debug-mode-syntax-table
- (let ((table (make-syntax-table (standard-syntax-table))))
- (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
- (modify-syntax-entry ?\n ">" table) ;; Comment end
- (modify-syntax-entry ?\" "\"" table) ;; String
- (modify-syntax-entry ?\- "_" table) ;; Symbol
- (modify-syntax-entry ?\\ "\\" table) ;; Quote
- (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
- (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
- (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
-
- table)
- "Syntax table used in data-debug macro buffers.")
-
-(defvar data-debug-mode-map
- (let ((km (make-sparse-keymap)))
- (suppress-keymap km)
- (define-key km [mouse-2] #'data-debug-expand-or-contract-mouse)
- (define-key km " " #'data-debug-expand-or-contract)
- (define-key km "\C-m" #'data-debug-expand-or-contract)
- (define-key km "n" #'data-debug-next)
- (define-key km "p" #'data-debug-prev)
- (define-key km "N" #'data-debug-next-expando)
- (define-key km "P" #'data-debug-prev-expando)
- km)
- "Keymap used in data-debug.")
-
-(defcustom data-debug-mode-hook nil
- "Hook run when data-debug starts."
- :type 'hook)
-
-(define-derived-mode data-debug-mode fundamental-mode "DATA-DEBUG"
- "Major-mode for the Analyzer debugger.
-
-\\{data-debug-mode-map}"
- (setq comment-start ";;"
- comment-end ""
- buffer-read-only t)
- (setq-local comment-start-skip
- "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
- (buffer-disable-undo)
- (setq-local font-lock-global-modes nil)
- (font-lock-mode -1))
-
-;;;###autoload
-(defun data-debug-new-buffer (name)
- "Create a new data-debug buffer with NAME."
- (let ((b (get-buffer-create name)))
- (pop-to-buffer b)
- (set-buffer b)
- (setq buffer-read-only nil) ; disable read-only
- (erase-buffer)
- (data-debug-mode)
- b))
-
-;;; Ddebug mode commands
-;;
-(defun data-debug-next ()
- "Go to the next line in the Ddebug buffer."
- (interactive)
- (forward-line 1)
- (beginning-of-line)
- (skip-chars-forward "- *><[]" (line-end-position)))
-
-(defun data-debug-prev ()
- "Go to the previous line in the Ddebug buffer."
- (interactive)
- (forward-line -1)
- (beginning-of-line)
- (skip-chars-forward "- *><[]" (line-end-position)))
-
-(defun data-debug-next-expando ()
- "Go to the next line in the Ddebug buffer.
-Contract the current line (if open) and expand the line
-we move to."
- (interactive)
- (data-debug-contract-current-line)
- (data-debug-next)
- (data-debug-expand-current-line)
- )
-
-(defun data-debug-prev-expando ()
- "Go to the previous line in the Ddebug buffer.
-Contract the current line (if open) and expand the line
-we move to."
- (interactive)
- (data-debug-contract-current-line)
- (data-debug-prev)
- (data-debug-expand-current-line)
- )
-
-(defun data-debug-current-line-expanded-p ()
- "Return non-nil if the current line is expanded."
- (let ((ti (current-indentation))
- (ni (condition-case nil
- (save-excursion
- (end-of-line)
- (forward-char 1)
- (current-indentation))
- (error 0))))
- (> ni ti)))
-
-(defun data-debug-line-expandable-p ()
- "Return non-nil if the current line is expandable.
-Lines that are not expandable are assumed to not be contractible."
- (not (get-text-property (point) 'ddebug-noexpand)))
-
-(defun data-debug-expand-current-line ()
- "Expand the current line (if possible).
-Do nothing if already expanded."
- (when (or (not (data-debug-line-expandable-p))
- (not (data-debug-current-line-expanded-p)))
- ;; If the next line is the same or less indentation, expand.
- (let ((fcn (get-text-property (point) 'ddebug-function))
- (inhibit-read-only t))
- (when fcn
- (funcall fcn (point))
- (beginning-of-line)
- ))))
-
-(defun data-debug-contract-current-line ()
- "Contract the current line (if possible).
-Do nothing if already contracted."
- (when (and (data-debug-current-line-expanded-p)
- ;; Don't contract if the current line is not expandable.
- (get-text-property (point) 'ddebug-function))
- (let ((ti (current-indentation))
- (inhibit-read-only t)
- )
- ;; If next indentation is larger, collapse.
- (end-of-line)
- (forward-char 1)
- (let ((start (point))
- (end nil))
- (condition-case nil
- (progn
- ;; Keep checking indentation
- (while (or (> (current-indentation) ti)
- (looking-at "^\\s-*$"))
- (end-of-line)
- (forward-char 1))
- (setq end (point))
- )
- (error (setq end (point-max))))
- (delete-region start end)
- (forward-char -1)
- (beginning-of-line))))
- (set-buffer-modified-p nil))
-
-(defun data-debug-expand-or-contract ()
- "Expand or contract anything at the current point."
- (interactive)
- (if (and (data-debug-line-expandable-p)
- (data-debug-current-line-expanded-p))
- (data-debug-contract-current-line)
- (data-debug-expand-current-line))
- (skip-chars-forward "- *><[]" (line-end-position)))
-
-(defun data-debug-expand-or-contract-mouse (event)
- "Expand or contract anything at event EVENT."
- (interactive "e")
- (let* ((win (car (car (cdr event))))
- )
- (select-window win t)
- (save-excursion
- ;(goto-char (window-start win))
- (mouse-set-point event)
- (data-debug-expand-or-contract))
- ))
-
-;;; GENERIC STRUCTURE DUMP
-;;
-(defun data-debug-show-stuff (stuff name)
- "Data debug STUFF in a buffer named *NAME DDebug*."
- (data-debug-new-buffer (concat "*" name " DDebug*"))
- (data-debug-insert-thing stuff "?" "")
- (goto-char (point-min))
- (when (data-debug-line-expandable-p)
- (data-debug-expand-current-line)))
-
-;;; DEBUG COMMANDS
-;;
-;; Various commands for displaying complex data structures.
-
-(defun data-debug-edebug-expr (expr)
- "Dump out the contents of some expression EXPR in edebug with ddebug."
- (interactive
- (list (read-from-minibuffer "Eval: "
- nil read-expression-map t
- 'read-expression-history)))
- (let ((v (eval expr t)))
- (if (not v)
- (message "Expression %s is nil." expr)
- (data-debug-show-stuff v "expression"))))
-
-(defun data-debug-eval-expression (expr)
- "Evaluate EXPR and display the value.
-If the result is something simple, show it in the echo area.
-If the result is a list or vector, then use the data debugger to display it."
- (interactive
- (list (read-from-minibuffer "Eval: "
- nil read-expression-map t
- 'read-expression-history)))
-
- (let (result)
- (if (null eval-expression-debug-on-error)
- (setq result (values--store-value (eval expr t)))
- (let ((old-value (make-symbol "t")) new-value)
- ;; Bind debug-on-error to something unique so that we can
- ;; detect when evalled code changes it.
- (let ((debug-on-error old-value))
- (setq result (values--store-value (eval expr t)))
- (setq new-value debug-on-error))
- ;; If evalled code has changed the value of debug-on-error,
- ;; propagate that change to the global binding.
- (unless (eq old-value new-value)
- (setq debug-on-error new-value))))
-
- (if (or (consp result) (vectorp result))
- (let ((v result))
- (data-debug-show-stuff v "Expression"))
- ;; Old style
- (prog1
- (prin1 result t)
- (let ((str (eval-expression-print-format result)))
- (if str (princ str t)))))))
-
-(provide 'data-debug)
-
-;;; data-debug.el ends here
+++ /dev/null
-;;; ede.el --- Emacs Development Environment gloss -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-;; Version: 2.0
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; EDE is the top level Lisp interface to a project management scheme
-;; for Emacs. Emacs does many things well, including editing,
-;; building, and debugging. Folks migrating from other IDEs don't
-;; seem to think this qualifies, however, because they still have to
-;; write the makefiles, and specify parameters to programs.
-;;
-;; This EDE mode will attempt to link these diverse programs together
-;; into a comprehensive single interface, instead of a bunch of
-;; different ones.
-
-;;; Install
-;;
-;; This command enables project mode on all files.
-;;
-;; (global-ede-mode t)
-
-;;; Code:
-
-(require 'cedet)
-(require 'cl-lib)
-(require 'eieio)
-(require 'cl-generic)
-(require 'eieio-speedbar)
-(require 'ede/source)
-(require 'ede/base)
-(require 'ede/auto)
-(require 'ede/detect)
-
-(eval-and-compile
- (load "ede/loaddefs" nil 'nomessage))
-
-(declare-function ede-commit-project "ede/custom")
-(declare-function ede-convert-path "ede/files")
-(declare-function ede-directory-get-open-project "ede/files")
-(declare-function ede-directory-get-toplevel-open-project "ede/files")
-(declare-function ede-directory-project-p "ede/files")
-(declare-function ede-find-subproject-for-directory "ede/files")
-(declare-function ede-project-directory-remove-hash "ede/files")
-(declare-function ede-toplevel "ede/base")
-(declare-function ede-toplevel-project "ede/files")
-(declare-function ede-up-directory "ede/files")
-(declare-function semantic-lex-make-spp-table "semantic/lex-spp")
-
-(defconst ede-version "2.0"
- "Current version of the Emacs EDE.")
-(make-obsolete-variable 'ede-version 'emacs-version "29.1")
-
-(defun ede-version ()
- "Display the current running version of EDE."
- (declare (obsolete emacs-version "29.1"))
- (interactive) (message "EDE %s" ede-version))
-
-(defgroup ede nil
- "Emacs Development Environment."
- :group 'tools
- :group 'extensions)
-
-(defcustom ede-auto-add-method 'ask
- "Whether a new source file should be automatically added to a target.
-Whenever a new file is encountered in a directory controlled by a
-project file, all targets are queried to see if it should be added.
-If the value is `always', then the new file is added to the first
-target encountered. If the value is `multi-ask', then if more than one
-target wants the file, the user is asked. If only one target wants
-the file, then it is automatically added to that target. If the
-value is `ask', then the user is always asked, unless there is no
-target willing to take the file. `never' means never perform the check."
- :type '(choice (const always)
- (const multi-ask)
- (const ask)
- (const never)))
-
-(defcustom ede-debug-program-function 'gdb
- "Default Emacs command used to debug a target."
- :type 'function) ; make this be a list of options some day
-
-(defcustom ede-project-directories nil
- "Directories in which EDE may search for project files.
-If the value is t, EDE may search in any directory.
-
-If the value is a function, EDE calls that function with one
-argument, the directory name; the function should return t if
-EDE should look for project files in the directory.
-
-Otherwise, the value should be a list of fully-expanded directory
-names. EDE searches for project files only in those directories.
-If you invoke the commands \\[ede] or \\[ede-new] on a directory
-that is not listed, Emacs will offer to add it to the list.
-
-Any other value disables searching for EDE project files."
- :type '(choice (const :tag "Any directory" t)
- (repeat :tag "List of directories"
- (directory))
- (function :tag "Predicate"))
- :version "23.4"
- :risky t)
-
-(defun ede-directory-safe-p (dir)
- "Return non-nil if DIR is a safe directory to load projects from.
-Projects that do not load a project definition as Emacs Lisp code
-are safe, and can be loaded automatically. Other project types,
-such as those created with Project.ede files, are safe only if
-specified by `ede-project-directories'."
- (setq dir (directory-file-name (expand-file-name dir)))
- ;; Load only if allowed by `ede-project-directories'.
- (or (eq ede-project-directories t)
- (and (functionp ede-project-directories)
- (funcall ede-project-directories dir))
- (and (listp ede-project-directories)
- (member dir ede-project-directories))))
-
-\f
-;;; Management variables
-
-(defvar ede-projects nil
- "A list of all active projects currently loaded in Emacs.")
-
-(defvar-local ede-object-root-project nil
- "The current buffer's current root project.
-If a file is under a project, this specifies the project that is at
-the root of a project tree.")
-
-(defvar-local ede-object-project nil
- "The current buffer's current project at that level.
-If a file is under a project, this specifies the project that contains the
-current target.")
-
-(defvar-local ede-object nil
- "The current buffer's target object.
-This object's class determines how to compile and debug from a buffer.")
-
-(defvar ede-selected-object nil
- "The currently user-selected project or target.
-If `ede-object' is nil, then commands will operate on this object.")
-
-(defvar ede-constructing nil
- "Non-nil when constructing a project hierarchy.
-If the project is being constructed from an autoload, then the
-value is the autoload object being used.")
-
-(defvar ede-deep-rescan nil
- "Non-nil means scan down a tree, otherwise rescans are top level only.
-Do not set this to non-nil globally. It is used internally.")
-
-\f
-;;; Prompting
-;;
-(defun ede-singular-object (prompt)
- "Using PROMPT, choose a single object from the current buffer."
- (if (listp ede-object)
- (ede-choose-object prompt ede-object)
- ede-object))
-
-(defun ede-choose-object (prompt list-o-o)
- "Using PROMPT, ask the user which OBJECT to use based on the name field.
-Argument LIST-O-O is the list of objects to choose from."
- (let* ((al (object-assoc-list 'name list-o-o))
- (ans (completing-read prompt al nil t)))
- (setq ans (assoc ans al))
- (cdr ans)))
-\f
-;;; Menu and Keymap
-
-(declare-function ede-speedbar "ede/speedbar" ())
-
-(defvar ede-minor-mode-map
- (let ((map (make-sparse-keymap))
- (pmap (make-sparse-keymap)))
- (define-key pmap "e" #'ede-edit-file-target)
- (define-key pmap "a" #'ede-add-file)
- (define-key pmap "d" #'ede-remove-file)
- (define-key pmap "t" #'ede-new-target)
- (define-key pmap "g" #'ede-rescan-toplevel)
- (define-key pmap "s" #'ede-speedbar)
- (define-key pmap "f" #'ede-find-file)
- (define-key pmap "C" #'ede-compile-project)
- (define-key pmap "c" #'ede-compile-target)
- (define-key pmap "\C-c" #'ede-compile-selected)
- (define-key pmap "D" #'ede-debug-target)
- (define-key pmap "R" #'ede-run-target)
- ;; bind our submap into map
- (define-key map "\C-c." pmap)
- map)
- "Keymap used in project minor mode.")
-
-(defvar global-ede-mode-map
- (let ((map (make-sparse-keymap)))
- (define-key map [menu-bar cedet-menu]
- (cons "Development" cedet-menu-map))
- map)
- "Keymap used in `global-ede-mode'.")
-
-;; Activate the EDE items in cedet-menu-map
-
-(define-key cedet-menu-map [ede-find-file]
- '(menu-item "Find File in Project..." ede-find-file :enable ede-object
- :visible global-ede-mode))
-(define-key cedet-menu-map [ede-speedbar]
- '(menu-item "View Project Tree" ede-speedbar :enable ede-object
- :visible global-ede-mode))
-(define-key cedet-menu-map [ede]
- '(menu-item "Load Project" ede
- :visible global-ede-mode))
-(define-key cedet-menu-map [ede-new]
- '(menu-item "Create Project" ede-new
- :enable (not ede-object)
- :visible global-ede-mode))
-(define-key cedet-menu-map [ede-target-options]
- '(menu-item "Target Options" ede-target-options
- :filter ede-target-forms-menu
- :visible global-ede-mode))
-(define-key cedet-menu-map [ede-project-options]
- '(menu-item "Project Options" ede-project-options
- :filter ede-project-forms-menu
- :visible global-ede-mode))
-(define-key cedet-menu-map [ede-build-forms-menu]
- '(menu-item "Build Project" ede-build-forms-menu
- :filter ede-build-forms-menu
- :enable ede-object
- :visible global-ede-mode))
-
-(defun ede-buffer-belongs-to-target-p ()
- "Return non-nil if this buffer belongs to at least one target."
- (let ((obj ede-object))
- (if (consp obj)
- (setq obj (car obj)))
- (and obj (obj-of-class-p obj 'ede-target))))
-
-(defun ede-buffer-belongs-to-project-p ()
- "Return non-nil if this buffer belongs to at least one project."
- (if (or (null ede-object) (consp ede-object)) nil
- (obj-of-class-p ede-object-project 'ede-project)))
-
-(defun ede-menu-obj-of-class-p (class)
- "Return non-nil if some member of `ede-object' is a child of CLASS."
- (if (listp ede-object)
- (cl-some (lambda (o) (obj-of-class-p o class)) ede-object)
- (obj-of-class-p ede-object class)))
-
-(defun ede-build-forms-menu (_menu-def)
- "Create a sub menu for building different parts of an EDE system.
-Argument MENU-DEF is the menu definition to use."
- (easy-menu-filter-return
- (easy-menu-create-menu
- "Build Forms"
- (let ((obj (ede-current-project))
- (newmenu nil) ;'([ "Build Selected..." ede-compile-selected t ]))
- targets
- targitems
- ede-obj
- (tskip nil))
- (if (not obj)
- nil
- (setq targets (when (slot-boundp obj 'targets)
- (oref obj targets))
- ede-obj (if (listp ede-object) ede-object (list ede-object)))
- ;; First, collect the build items from the project
- (setq newmenu (append newmenu (ede-menu-items-build obj t)))
- ;; Second, declare the current target menu items
- (if (and ede-obj (ede-menu-obj-of-class-p 'ede-target))
- (while ede-obj
- (setq newmenu (append newmenu
- (ede-menu-items-build (car ede-obj) t))
- tskip (car ede-obj)
- ede-obj (cdr ede-obj))))
- ;; Third, by name, enable builds for other local targets
- (while targets
- (unless (eq tskip (car targets))
- (setq targitems (ede-menu-items-build (car targets) nil))
- (setq newmenu
- (append newmenu
- (if (= 1 (length targitems))
- targitems
- (cons (ede-name (car targets))
- targitems))))
- )
- (setq targets (cdr targets)))
- ;; Fourth, build sub projects.
- ;; -- nerp
- ;; Fifth, add make distribution
- (append newmenu (list [ "Make distribution" ede-make-dist t ]))
- )))))
-
-(defun ede-target-forms-menu (_menu-def)
- "Create a target MENU-DEF based on the object belonging to this buffer."
- (easy-menu-filter-return
- (easy-menu-create-menu
- "Target Forms"
- (let ((obj (or ede-selected-object ede-object)))
- (append
- '([ "Add File" ede-add-file
- (and (ede-current-project)
- (oref (ede-current-project) targets)) ]
- [ "Remove File" ede-remove-file
- (ede-buffer-belongs-to-project-p) ]
- "-")
- (if (not obj)
- nil
- (if (and (not (listp obj)) (oref obj menu))
- (oref obj menu)
- (when (listp obj)
- ;; This is bad, but I'm not sure what else to do.
- (oref (car obj) menu)))))))))
-
-(defun ede-project-forms-menu (_menu-def)
- "Create a target MENU-DEF based on the object belonging to this buffer."
- (easy-menu-filter-return
- (easy-menu-create-menu
- "Project Forms"
- (let* ((obj (ede-current-project))
- (class (if obj (eieio-object-class obj)))
- (menu nil))
- (condition-case err
- (progn
- (while (and class (slot-exists-p class 'menu))
- ;;(message "Looking at class %S" class)
- (setq menu (append menu (oref-default class menu))
- class (eieio-class-parent class))
- (if (listp class) (setq class (car class))))
- (append
- '( [ "Add Target" ede-new-target (ede-current-project) ]
- [ "Remove Target" ede-delete-target ede-object ]
- ( "Default configuration" :filter ede-configuration-forms-menu )
- "-")
- menu
- ))
- (error (message "Err found: %S" err)
- menu)
- )))))
-
-(defun ede-configuration-forms-menu (_menu-def)
- "Create a submenu for selecting the default configuration for this project.
-The current default is in the current object's CONFIGURATION-DEFAULT slot.
-All possible configurations are in CONFIGURATIONS.
-Argument MENU-DEF specifies the menu being created."
- (easy-menu-filter-return
- (easy-menu-create-menu
- "Configurations"
- (let* ((obj (ede-current-project))
- (conf (when obj (oref obj configurations)))
- (cdef (when obj (oref obj configuration-default)))
- (menu nil))
- (dolist (C conf)
- (setq menu (cons (vector C (list 'ede-project-configurations-set C)
- :style 'toggle
- :selected (string= C cdef))
- menu))
- )
- (nreverse menu)))))
-
-(defun ede-project-configurations-set (newconfig)
- "Set the current project's current configuration to NEWCONFIG.
-This function is designed to be used by `ede-configuration-forms-menu'
-but can also be used interactively."
- (interactive
- (list (let* ((proj (ede-current-project))
- (configs (oref proj configurations)))
- (completing-read "New configuration: "
- configs nil t
- (oref proj configuration-default)))))
- (oset (ede-current-project) configuration-default newconfig)
- (message "%s will now build in %s mode."
- (eieio-object-name (ede-current-project))
- newconfig))
-
-(defun ede-customize-forms-menu (_menu-def)
- "Create a menu of the project, and targets that can be customized.
-Argument MENU-DEF is the definition of the current menu."
- (easy-menu-filter-return
- (easy-menu-create-menu
- "Customize Project"
- (let* ((obj (ede-current-project))
- targ)
- (when obj
- (setq targ (when (and obj (slot-boundp obj 'targets))
- (oref obj targets)))
- ;; Make custom menus for everything here.
- (append (list
- (cons (concat "Project " (ede-name obj))
- (eieio-customize-object-group obj))
- [ "Reorder Targets" ede-project-sort-targets t ]
- )
- (mapcar (lambda (o)
- (cons (concat "Target " (ede-name o))
- (eieio-customize-object-group o)))
- targ)))))))
-
-
-(defun ede-apply-object-keymap (&optional _default)
- "Add target specific keybindings into the local map.
-Optional argument DEFAULT indicates if this should be set to the default
-version of the keymap."
- (let ((object (or ede-object ede-selected-object))
- (proj ede-object-project))
- (condition-case nil
- (let ((keys (ede-object-keybindings object)))
- (dolist (key
- ;; Add keys for the project to whatever is in the current
- ;; object so long as it isn't the same.
- (if (eq object proj)
- keys
- (append keys (ede-object-keybindings proj))))
- (local-set-key (concat "\C-c." (car key)) (cdr key))))
- (error nil))))
-
-;;; Menu building methods for building
-;;
-(cl-defmethod ede-menu-items-build ((obj ede-project) &optional current)
- "Return a list of menu items for building project OBJ.
-If optional argument CURRENT is non-nil, return sub-menu code."
- (if current
- (list [ "Build Current Project" ede-compile-project t ])
- (list (vector
- (list
- (concat "Build Project " (ede-name obj))
- `(project-compile-project ,obj))))))
-
-(cl-defmethod ede-menu-items-build ((obj ede-target) &optional current)
- "Return a list of menu items for building target OBJ.
-If optional argument CURRENT is non-nil, return sub-menu code."
- (if current
- (list [ "Build Current Target" ede-compile-target t ])
- (list (vector
- (concat "Build Target " (ede-name obj))
- `(project-compile-target ,obj)
- t))))
-\f
-;;; Mode Declarations
-;;
-
-(defun ede-apply-target-options ()
- "Apply options to the current buffer for the active project/target."
- (ede-apply-project-local-variables)
- ;; Apply keymaps and preprocessor symbols.
- (ede-apply-object-keymap)
- (ede-apply-preprocessor-map)
- )
-
-(defun ede-turn-on-hook ()
- "Turn on EDE minor mode in the current buffer if needed.
-To be used in hook functions."
- (if (or (and (stringp (buffer-file-name))
- (stringp default-directory))
- ;; Emacs 21 has no buffer file name for directory edits.
- ;; so we need to add these hacks in.
- (eq major-mode 'dired-mode)
- (eq major-mode 'vc-dir-mode))
- (ede-minor-mode 1)))
-
-(define-minor-mode ede-minor-mode
- "Toggle EDE (Emacs Development Environment) minor mode.
-
-If this file is contained, or could be contained in an EDE
-controlled project, then this mode is activated automatically
-provided `global-ede-mode' is enabled."
- :global nil
- (cond ((or (eq major-mode 'dired-mode)
- (eq major-mode 'vc-dir-mode))
- (ede-dired-minor-mode (if ede-minor-mode 1 -1)))
- (ede-minor-mode
- (if (not ede-constructing)
- (ede-initialize-state-current-buffer)
- ;; If we fail to have a project here, turn it back off.
- (ede-minor-mode -1)))))
-
-(declare-function ede-directory-project-cons "ede/files" (dir &optional force))
-(declare-function ede-toplevel-project-or-nil "ede/files" (dir))
-
-(defun ede-initialize-state-current-buffer ()
- "Initialize the current buffer's state for EDE.
-Sets buffer local variables for EDE."
- ;; due to inode recycling, make sure we don't
- ;; we flush projects deleted off the system.
- (ede-flush-deleted-projects)
-
- ;; Init the buffer.
- (let* ((ROOT nil)
- (proj (ede-directory-get-open-project default-directory
- (gv-ref ROOT))))
-
- (when (not proj)
- ;; If there is no open project, look up the project
- ;; autoloader to see if we should initialize.
- (let ((projdetect (ede-directory-project-cons default-directory)))
-
- (when projdetect
- ;; No project was loaded, but we have a project description
- ;; object. This means that we try to load it.
- ;;
- ;; Before loading, we need to check if it is a safe
- ;; project to load before requesting it to be loaded.
-
- (when (or (oref (cdr projdetect) safe-p)
- ;; The project style is not safe, so check if it is
- ;; in `ede-project-directories'.
- (let ((top (car projdetect)))
- (ede-directory-safe-p top)))
-
- ;; The project is safe, so load it in.
- (setq proj (ede-load-project-file default-directory projdetect
- (gv-ref ROOT)))))))
-
- ;; If PROJ is now loaded in, we can initialize our buffer to it.
- (when proj
-
- ;; ede-object represents the specific EDE related class that best
- ;; represents this buffer. It could be a project (for a project file)
- ;; or a target. Also save off ede-object-project, the project that
- ;; the buffer belongs to for the case where ede-object is a target.
- (setq ede-object (ede-buffer-object (current-buffer)
- 'ede-object-project))
-
- ;; Every project has a root. It might be the same as ede-object.
- ;; Cache that also as the root is a very common thing to need.
- (setq ede-object-root-project
- (or ROOT (ede-project-root ede-object-project)))
-
- ;; Check to see if we want to add this buffer to a target.
- (if (and (not ede-object) ede-object-project)
- (ede-auto-add-to-target))
-
- ;; Apply any options from the found target.
- (ede-apply-target-options))))
-
-(defun ede-reset-all-buffers ()
- "Reset all the buffers due to change in EDE."
- (interactive)
- (dolist (b (buffer-list))
- (when (buffer-file-name b)
- (with-current-buffer b
- ;; Reset all state variables
- (setq ede-object nil
- ede-object-project nil
- ede-object-root-project nil)
- ;; Now re-initialize this buffer.
- (ede-initialize-state-current-buffer)))))
-
-;;;###autoload
-(define-minor-mode global-ede-mode
- "Toggle global EDE (Emacs Development Environment) mode.
-
-This global minor mode enables `ede-minor-mode' in all buffers in
-an EDE controlled project."
- :global t
- (if global-ede-mode
- ;; Turn on global-ede-mode
- (progn
- (if semantic-mode
- (define-key cedet-menu-map [cedet-menu-separator] '("--")))
- (add-hook 'semanticdb-project-predicate-functions #'ede-directory-project-p)
- (add-hook 'semanticdb-project-root-functions #'ede-toplevel-project-or-nil)
- (add-hook 'ecb-source-path-functions #'ede-ecb-project-paths)
- ;; Append our hook to the end. This allows mode-local to finish
- ;; it's stuff before we start doing misc file loads, etc.
- (add-hook 'find-file-hook #'ede-turn-on-hook t)
- (add-hook 'dired-mode-hook #'ede-turn-on-hook)
- (add-hook 'kill-emacs-hook #'ede-save-cache)
- (ede-load-cache)
- (ede-reset-all-buffers))
- ;; Turn off global-ede-mode
- (define-key cedet-menu-map [cedet-menu-separator] nil)
- (remove-hook 'semanticdb-project-predicate-functions #'ede-directory-project-p)
- (remove-hook 'semanticdb-project-root-functions #'ede-toplevel-project-or-nil)
- (remove-hook 'ecb-source-path-functions #'ede-ecb-project-paths)
- (remove-hook 'find-file-hook #'ede-turn-on-hook)
- (remove-hook 'dired-mode-hook #'ede-turn-on-hook)
- (remove-hook 'kill-emacs-hook #'ede-save-cache)
- (ede-save-cache)
- (ede-reset-all-buffers)))
-
-(defvar ede-ignored-file-alist
- '( "\\.cvsignore$"
- "\\.#"
- "~$"
- )
- "List of file name patterns that EDE will never ask about.")
-
-(defun ede-ignore-file (filename)
- "Should we ignore FILENAME?"
- (let ((any nil)
- (F ede-ignored-file-alist))
- (while (and (not any) F)
- (when (string-match (car F) filename)
- (setq any t))
- (setq F (cdr F)))
- any))
-
-(defun ede-auto-add-to-target ()
- "Look for a target that wants to own the current file.
-Follow the preference set with `ede-auto-add-method' and get the list
-of objects with the `ede-want-file-p' method."
- (if ede-object (error "ede-object already defined for %s" (buffer-name)))
- (if (or (eq ede-auto-add-method 'never)
- (ede-ignore-file (buffer-file-name)))
- nil
- (let (desires)
- (dolist (want (oref (ede-current-project) targets));Find all the objects.
- (if (ede-want-file-p want (buffer-file-name))
- (push want desires)))
- (if desires
- (cond ((or (eq ede-auto-add-method 'ask)
- (and (eq ede-auto-add-method 'multi-ask)
- (< 1 (length desires))))
- (let* ((al (append
- ;; some defaults
- '(("none" . nil)
- ("new target" . new))
- ;; If we are in an unparented subdir,
- ;; offer new a subproject
- (if (ede-directory-project-p default-directory)
- ()
- '(("create subproject" . project)))
- ;; Here are the existing objects we want.
- (object-assoc-list 'name desires)))
- (case-fold-search t)
- (ans (completing-read
- (format "Add %s to target: " (buffer-file-name))
- al nil t)))
- (setq ans (assoc ans al))
- (cond ((eieio-object-p (cdr ans))
- (ede-add-file (cdr ans)))
- ((eq (cdr ans) 'new)
- (ede-new-target))
- (t nil))))
- ((or (eq ede-auto-add-method 'always)
- (and (eq ede-auto-add-method 'multi-ask)
- (= 1 (length desires))))
- (ede-add-file (car desires)))
- (t nil))))))
-
-\f
-;;; Interactive method invocations
-;;
-(defun ede (dir)
- "Start up EDE for directory DIR.
-If DIR has an existing project file, load it.
-Otherwise, create a new project for DIR."
- (interactive
- ;; When choosing a directory to turn on, and we see some directory here,
- ;; provide that as the default.
- (let* ((top (ede-toplevel-project default-directory))
- (promptdflt (or top default-directory)))
- (list (read-directory-name "Project directory: "
- promptdflt promptdflt t))))
- (unless (file-directory-p dir)
- (error "%s is not a directory" dir))
- (when (ede-directory-get-open-project dir)
- (error "%s already has an open project associated with it" dir))
-
- ;; Check if the directory has been added to the list of safe
- ;; directories. It can also add the directory to the safe list if
- ;; the user chooses.
- (if (ede-check-project-directory dir)
- (progn
- ;; Load the project in DIR, or make one.
- ;; @TODO - IS THIS REAL?
- (ede-load-project-file dir)
-
- ;; Check if we loaded anything on the previous line.
- (if (ede-current-project dir)
-
- ;; We successfully opened an existing project. Some open
- ;; buffers may also be referring to this project.
- ;; Resetting all the buffers will get them to also point
- ;; at this new open project.
- (ede-reset-all-buffers)
-
- ;; ELSE
- ;; There was no project, so switch to `ede-new' which is how
- ;; a user can select a new kind of project to create.
- (let ((default-directory (expand-file-name dir)))
- (call-interactively 'ede-new))))
-
- ;; If the proposed directory isn't safe, then say so.
- (error "%s is not an allowed project directory in `ede-project-directories'"
- dir)))
-
-(defvar ede-check-project-query-fcn 'y-or-n-p
- "Function used to ask the user if they want to permit a project to load.
-This is abstracted out so that tests can answer this question.")
-
-(defun ede-check-project-directory (dir)
- "Check if DIR should be in `ede-project-directories'.
-If it is not, try asking the user if it should be added; if so,
-add it and save `ede-project-directories' via Customize.
-Return nil if DIR should not be in `ede-project-directories'."
- (setq dir (directory-file-name (expand-file-name dir))) ; strip trailing /
- (or (eq ede-project-directories t)
- (and (functionp ede-project-directories)
- (funcall ede-project-directories dir))
- ;; If `ede-project-directories' is a list, maybe add it.
- (when (listp ede-project-directories)
- (or (member dir ede-project-directories)
- (when (funcall ede-check-project-query-fcn
- (format-message
- "`%s' is not listed in `ede-project-directories'.
-Add it to the list of allowed project directories? "
- dir))
- (push dir ede-project-directories)
- ;; If possible, save `ede-project-directories'.
- (if (or custom-file user-init-file)
- (let ((coding-system-for-read nil))
- (customize-save-variable
- 'ede-project-directories
- ede-project-directories)))
- t)))))
-
-(defun ede-new (type &optional name)
- "Create a new project starting from project type TYPE.
-Optional argument NAME is the name to give this project."
- (interactive
- (list (completing-read "Project Type: "
- (object-assoc-list
- 'name
- (let* ((l ede-project-class-files)
- (cp (ede-current-project))
- (cs (when cp (eieio-object-class cp)))
- (r nil))
- (while l
- (if cs
- (if (eq (oref (car l) class-sym)
- cs)
- (setq r (cons (car l) r)))
- (if (oref (car l) new-p)
- (setq r (cons (car l) r))))
- (setq l (cdr l)))
- (when (not r)
- (if cs
- (error "No valid interactive sub project types for %s"
- cs)
- (error "EDE error: Can't find project types to create")))
- r)
- )
- nil t)))
- (require 'ede/custom)
- ;; Make sure we have a valid directory
- (when (not (file-exists-p default-directory))
- (error "Cannot create project in non-existent directory %s" default-directory))
- (when (not (file-writable-p default-directory))
- (error "No write permissions for %s" default-directory))
- (unless (ede-check-project-directory default-directory)
- (error "%s is not an allowed project directory in `ede-project-directories'"
- default-directory))
- ;; Make sure the project directory is loadable in the future.
- (ede-check-project-directory default-directory)
- ;; Create the project
- (let* ((obj (object-assoc type 'name ede-project-class-files))
- (nobj (let ((f (oref obj file))
- (pf (oref obj proj-file)))
- ;; We are about to make something new, changing the
- ;; state of existing directories.
- (ede-project-directory-remove-hash default-directory)
- ;; Make sure this class gets loaded!
- (require f)
- (make-instance (oref obj class-sym)
- :name (or name (read-string "Name: "))
- :directory default-directory
- :file (cond ((stringp pf)
- (expand-file-name pf))
- ((fboundp pf)
- (funcall pf))
- (t
- (error
- "Unknown file name specifier %S"
- pf)))
- :targets nil)
-
- ))
- (inits (oref obj initializers)))
- ;; Force the name to match for new objects.
- (setf (slot-value nobj 'object-name) (oref nobj name))
- ;; Handle init args.
- (while inits
- (eieio-oset nobj (car inits) (car (cdr inits)))
- (setq inits (cdr (cdr inits))))
- (let ((pp (ede-parent-project)))
- (when pp
- (ede-add-subproject pp nobj)
- (ede-commit-project pp)))
- (ede-commit-project nobj))
- ;; Once the project is created, load it again. This used to happen
- ;; lazily, but with project loading occurring less often and with
- ;; security in mind, this is now the safe time to reload.
- (ede-load-project-file default-directory)
- ;; Have the menu appear
- (setq ede-minor-mode t)
- ;; Allert the user
- (message "Project created and saved. You may now create targets."))
-
-(cl-defmethod ede-add-subproject ((proj-a ede-project) proj-b)
- "Add into PROJ-A, the subproject PROJ-B."
- (oset proj-a subproj (cons proj-b (oref proj-a subproj))))
-
-(defun ede-invoke-method (sym &rest args)
- "Invoke method SYM on the current buffer's project object.
-ARGS are additional arguments to pass to method SYM."
- (if (not ede-object)
- (error "Cannot invoke %s for %s" (symbol-name sym)
- (buffer-name)))
- ;; Always query a target. There should never be multiple
- ;; projects in a single buffer.
- (apply sym (ede-singular-object "Target: ") args))
-
-(defun ede-rescan-toplevel ()
- "Rescan all project files."
- (interactive)
- (when (not (ede-toplevel))
- ;; This directory isn't open. Can't rescan.
- (error "Attempt to rescan a project that isn't open"))
-
- ;; Continue
- (let ((root (ede-toplevel))
- (ede-deep-rescan t))
-
- (project-rescan root)
- (ede-reset-all-buffers)
- ))
-
-(defun ede-new-target (&rest args)
- "Create a new target specific to this type of project file.
-Different projects accept different arguments ARGS.
-Typically you can specify NAME, target TYPE, and AUTOADD, where AUTOADD is
-a string \"y\" or \"n\", which answers the y/n question done interactively."
- (interactive)
- (apply #'project-new-target (ede-current-project) args)
- (when (and buffer-file-name
- (not (file-directory-p buffer-file-name)))
- (setq ede-object nil)
- (setq ede-object (ede-buffer-object (current-buffer)))
- (ede-apply-target-options)))
-
-(defun ede-new-target-custom ()
- "Create a new target specific to this type of project file."
- (interactive)
- (project-new-target-custom (ede-current-project)))
-
-(defun ede-delete-target (target)
- "Delete TARGET from the current project."
- (interactive (list
- (let ((ede-object (ede-current-project)))
- (ede-invoke-method 'project-interactive-select-target
- "Target: "))))
- ;; Find all sources in buffers associated with the condemned buffer.
- (let ((condemned (ede-target-buffers target)))
- (project-delete-target target)
- ;; Loop over all project controlled buffers
- (save-excursion
- (while condemned
- (set-buffer (car condemned))
- (setq ede-object nil)
- (setq ede-object (ede-buffer-object (current-buffer)))
- (setq condemned (cdr condemned))))
- (ede-apply-target-options)))
-
-(defun ede-add-file (target)
- "Add the current buffer to a TARGET in the current project."
- (interactive (list
- (let ((ede-object (ede-current-project)))
- (ede-invoke-method 'project-interactive-select-target
- "Target: "))))
- (when (stringp target)
- (let* ((proj (ede-current-project))
- (ob (object-assoc-list 'name (oref proj targets))))
- (setq target (cdr (assoc target ob)))))
-
- (when (not target)
- (error "Could not find specified target %S" target))
-
- (project-add-file target (buffer-file-name))
- (setq ede-object nil)
-
- ;; Setup buffer local variables.
- (ede-initialize-state-current-buffer)
-
- (when (not ede-object)
- (error "Can't add %s to target %s: Wrong file type"
- (file-name-nondirectory (buffer-file-name))
- (eieio-object-name target)))
- (ede-apply-target-options))
-
-(defun ede-remove-file (&optional force)
- "Remove the current file from targets.
-Optional argument FORCE forces the file to be removed without asking."
- (interactive "P")
- (if (not ede-object)
- (error "Cannot invoke remove-file for %s" (buffer-name)))
- (let ((eo (if (listp ede-object)
- (prog1
- ede-object
- (setq force nil))
- (list ede-object))))
- (while eo
- (if (or force (y-or-n-p (format "Remove from %s? " (ede-name (car eo)))))
- (project-remove-file (car eo) (buffer-file-name)))
- (setq eo (cdr eo)))
- (setq ede-object nil)
- (setq ede-object (ede-buffer-object (current-buffer)))
- (ede-apply-target-options)))
-
-(defun ede-edit-file-target ()
- "Enter the project file to hand edit the current buffer's target."
- (interactive)
- (ede-invoke-method 'project-edit-file-target))
-
-;;; Compilation / Debug / Run
-;;
-(defun ede-compile-project ()
- "Compile the current project."
- (interactive)
- ;; @TODO - This just wants the root. There should be a better way.
- (let ((cp (ede-current-project)))
- (while (ede-parent-project cp)
- (setq cp (ede-parent-project cp)))
- (let ((ede-object cp))
- (ede-invoke-method 'project-compile-project))))
-
-(defun ede-compile-selected (target)
- "Compile some TARGET from the current project."
- (interactive (list (project-interactive-select-target (ede-current-project)
- "Target to Build: ")))
- (project-compile-target target))
-
-(defun ede-compile-target ()
- "Compile the current buffer's associated target."
- (interactive)
- (ede-invoke-method 'project-compile-target))
-
-(defun ede-debug-target ()
- "Debug the current buffer's associated target."
- (interactive)
- (ede-invoke-method 'project-debug-target))
-
-(defun ede-run-target ()
- "Run the current buffer's associated target."
- (interactive)
- (ede-invoke-method 'project-run-target))
-
-(defun ede-make-dist ()
- "Create a distribution from the current project."
- (interactive)
- (let ((ede-object (ede-toplevel)))
- (ede-invoke-method 'project-make-dist)))
-
-\f
-;;; EDE project target baseline methods.
-;;
-;; If you are developing a new project type, you need to implement
-;; all of these methods, unless, of course, they do not make sense
-;; for your particular project.
-;;
-;; Your targets should inherit from `ede-target', and your project
-;; files should inherit from `ede-project'. Create the appropriate
-;; methods based on those below.
-
-(cl-defmethod project-interactive-select-target ((this ede-project-placeholder) prompt)
- ; checkdoc-params: (prompt)
- "Make sure placeholder THIS is replaced with the real thing, and pass through."
- (project-interactive-select-target this prompt))
-
-(cl-defmethod project-interactive-select-target ((this ede-project) prompt)
- "Interactively query for a target that exists in project THIS.
-Argument PROMPT is the prompt to use when querying the user for a target."
- (let ((ob (object-assoc-list 'name (oref this targets))))
- (cdr (assoc (completing-read prompt ob nil t) ob))))
-
-(cl-defmethod project-add-file ((this ede-project-placeholder) file)
- ; checkdoc-params: (file)
- "Make sure placeholder THIS is replaced with the real thing, and pass through."
- (project-add-file this file))
-
-(cl-defmethod project-add-file ((ot ede-target) _file)
- "Add the current buffer into project target OT.
-Argument FILE is the file to add."
- (error "add-file not supported by %s" (eieio-object-name ot)))
-
-(cl-defmethod project-remove-file ((ot ede-target) _fnnd)
- "Remove the current buffer from project target OT.
-Argument FNND is an argument."
- (error "remove-file not supported by %s" (eieio-object-name ot)))
-
-(cl-defmethod project-edit-file-target ((_ot ede-target))
- "Edit the target OT associated with this file."
- (find-file (oref (ede-current-project) file)))
-
-(cl-defmethod project-new-target ((proj ede-project) &rest _args)
- "Create a new target. It is up to the project PROJ to get the name."
- (error "new-target not supported by %s" (eieio-object-name proj)))
-
-(cl-defmethod project-new-target-custom ((proj ede-project))
- "Create a new target. It is up to the project PROJ to get the name."
- (error "New-target-custom not supported by %s" (eieio-object-name proj)))
-
-(cl-defmethod project-delete-target ((ot ede-target))
- "Delete the current target OT from its parent project."
- (error "add-file not supported by %s" (eieio-object-name ot)))
-
-(cl-defmethod project-compile-project ((obj ede-project) &optional _command)
- "Compile the entire current project OBJ.
-Argument COMMAND is the command to use when compiling."
- (error "compile-project not supported by %s" (eieio-object-name obj)))
-
-(cl-defmethod project-compile-target ((obj ede-target) &optional _command)
- "Compile the current target OBJ.
-Argument COMMAND is the command to use for compiling the target."
- (error "compile-target not supported by %s" (eieio-object-name obj)))
-
-(cl-defmethod project-debug-target ((obj ede-target))
- "Run the current project target OBJ in a debugger."
- (error "debug-target not supported by %s" (eieio-object-name obj)))
-
-(cl-defmethod project-run-target ((obj ede-target))
- "Run the current project target OBJ."
- (error "run-target not supported by %s" (eieio-object-name obj)))
-
-(cl-defmethod project-make-dist ((this ede-project))
- "Build a distribution for the project based on THIS project."
- (error "Make-dist not supported by %s" (eieio-object-name this)))
-
-(cl-defmethod project-dist-files ((this ede-project))
- "Return a list of files that constitute a distribution of THIS project."
- (error "Dist-files is not supported by %s" (eieio-object-name this)))
-
-(cl-defmethod project-rescan ((this ede-project))
- "Rescan the EDE project THIS."
- (error "Rescanning a project is not supported by %s" (eieio-object-name this)))
-
-(defun ede-ecb-project-paths ()
- "Return a list of all paths for all active EDE projects.
-This functions is meant for use with ECB."
- (let ((p ede-projects)
- (d nil))
- (while p
- (setq d (cons (file-name-directory (oref (car p) file))
- d)
- p (cdr p)))
- d))
-
-;;; PROJECT LOADING/TRACKING
-;;
-(defun ede-add-project-to-global-list (proj)
- "Add the project PROJ to the master list of projects.
-On success, return the added project."
- (when (not proj)
- (error "No project created to add to master list"))
- (when (not (eieio-object-p proj))
- (error "Attempt to add non-object to master project list"))
- (when (not (obj-of-class-p proj 'ede-project-placeholder))
- (error "Attempt to add a non-project to the ede projects list"))
- (add-to-list 'ede-projects proj)
- proj)
-
-(defun ede-delete-project-from-global-list (proj)
- "Remove project PROJ from the master list of projects."
- (setq ede-projects (remove proj ede-projects)))
-
-(defun ede-flush-deleted-projects ()
- "Scan the projects list for projects which no longer exist.
-Flush the dead projects from the project cache."
- (interactive)
- (let ((dead nil))
- (dolist (P ede-projects)
- (when (not (file-exists-p (oref P file)))
- (cl-pushnew P dead :test #'equal)))
- (dolist (D dead)
- (ede-delete-project-from-global-list D))
- ))
-
-(defvar ede--disable-inode) ;Defined in ede/files.el.
-(declare-function ede--project-inode "ede/files" (proj))
-
-(defun ede-global-list-sanity-check ()
- "Perform a sanity check to make sure there are no duplicate projects."
- (interactive)
- (let ((scanned nil))
- (dolist (P ede-projects)
- (if (member (oref P directory) scanned)
- (error "Duplicate project (by dir) found in %s!" (oref P directory))
- (push (oref P directory) scanned)))
- (unless ede--disable-inode
- (setq scanned nil)
- (dolist (P ede-projects)
- (if (member (ede--project-inode P) scanned)
- (error "Duplicate project (by inode) found in %s!" (ede--project-inode P))
- (push (ede--project-inode P) scanned))))
- (message "EDE by directory %sis still sane." (if ede--disable-inode "" "& inode "))))
-
-(defun ede-load-project-file (dir &optional detectin rootreturn)
- "Project file independent way to read a project in from DIR.
-Optional DETECTIN is an autoload cons from `ede-detect-directory-for-project'
-which can be passed in to save time.
-Optional ROOTRETURN reference will return the root project for DIR."
- ;; Don't do anything if we are in the process of
- ;; constructing an EDE object.
- ;;
- ;; Prevent recursion.
- (unless ede-constructing
-
- ;; Only load if something new is going on. Flush the dirhash.
- (ede-project-directory-remove-hash dir)
-
- ;; Do the load
- ;;(message "EDE LOAD : %S" file)
- (let* ((path (file-name-as-directory (expand-file-name dir)))
- (detect (or detectin (ede-directory-project-cons path)))
- (autoloader nil)
- (toppath nil)
- (o nil))
-
- (when detect
- (setq toppath (car detect))
- (setq autoloader (cdr detect))
-
- ;; See if it's been loaded before. Use exact matching since
- ;; know that 'toppath' is the root of the project.
- (setq o (ede-directory-get-toplevel-open-project toppath 'exact))
-
- ;; If not open yet, load it.
- (unless o
- ;; NOTE: We set ede-constructing to the autoloader we are using.
- ;; Some project types have one class, but many autoloaders
- ;; and this is how we tell the instantiation which kind of
- ;; project to make.
- (let ((ede-constructing autoloader))
-
- ;; This is the only place `ede-auto-load-project' should be called.
-
- (setq o (ede-auto-load-project autoloader toppath))))
-
- ;; Return the found root project.
- (when rootreturn (if (symbolp rootreturn) (set rootreturn o)
- (setf (gv-deref rootreturn) o)))
-
- ;; The project has been found (in the global list) or loaded from
- ;; disk (via autoloader.) We can now search for the project asked
- ;; for from DIR in the sub-list.
- (ede-find-subproject-for-directory o path)
-
- ;; Return the project.
- o))))
-
-;;; PROJECT ASSOCIATIONS
-;;
-;; Moving between relative projects. Associating between buffers and
-;; projects.
-(defun ede-parent-project (&optional obj)
- "Return the project belonging to the parent directory.
-Return nil if there is no previous directory.
-Optional argument OBJ is an object to find the parent of."
- (let* ((proj (or obj ede-object-project)) ;; Current project.
- (root (if obj (ede-project-root obj)
- ede-object-root-project)))
- ;; This case is a SHORTCUT if the project has defined
- ;; a way to calculate the project root.
- (if (and root proj (eq root proj))
- nil ;; we are at the root.
- ;; Else, we may have a nil proj or root.
- (let* ((thisdir (if obj (oref obj directory)
- default-directory))
- (updir (ede-up-directory thisdir)))
- (when updir
- ;; If there was no root, perhaps we can derive it from
- ;; updir now.
- (let ((root (or root (ede-directory-get-toplevel-open-project updir))))
- (or
- ;; This lets us find a subproject under root based on updir.
- (and root
- (ede-find-subproject-for-directory root updir))
- ;; Try the all structure based search.
- (ede-directory-get-open-project updir))))))))
-
-(defun ede-current-project (&optional dir)
- "Return the current project file.
-If optional DIR is provided, get the project for DIR instead."
- ;; If it matches the current directory, do we have a pre-existing project?
- (let ((proj (when (and (or (not dir) (string= dir default-directory))
- ede-object-project)
- ede-object-project)))
- ;; No current project.
- (if proj
- proj
- (let* ((ldir (or dir default-directory)))
- (ede-directory-get-open-project ldir)))))
-
-(defun ede-buffer-object (&optional buffer projsym)
- "Return the target object for BUFFER.
-This function clears cached values and recalculates.
-Optional PROJSYM is a symbol, which will be set to the project
-that contains the target that becomes buffer's object."
- (save-excursion
- (if (not buffer) (setq buffer (current-buffer)))
- (set-buffer buffer)
- (setq ede-object nil)
- (let* ((localpo (ede-current-project))
- (po localpo)
- (top (ede-toplevel po)))
- (if po (setq ede-object (ede-find-target po buffer)))
- ;; If we get nothing, go with the backup plan of slowly
- ;; looping upward
- (while (and (not ede-object) (not (eq po top)))
- (setq po (ede-parent-project po))
- (if po (setq ede-object (ede-find-target po buffer))))
- ;; Filter down to 1 project if there are dups.
- (if (= (length ede-object) 1)
- (setq ede-object (car ede-object)))
- ;; Track the project, if needed.
- (when (and projsym (symbolp projsym))
- (if ede-object
- ;; If we found a target, then PO is the
- ;; project to use.
- (set projsym po)
- ;; If there is no ede-object, then the projsym
- ;; is whichever part of the project is most local.
- (set projsym localpo))
- ))
- ;; Return our findings.
- ede-object))
-
-(cl-defmethod ede-target-in-project-p ((proj ede-project) target)
- "Is PROJ the parent of TARGET?
-If TARGET belongs to a subproject, return that project file."
- (if (and (slot-boundp proj 'targets)
- (memq target (oref proj targets)))
- proj
- (let ((s (oref proj subproj))
- (ans nil))
- (while (and s (not ans))
- (setq ans (ede-target-in-project-p (car s) target))
- (setq s (cdr s)))
- ans)))
-
-(defun ede-target-parent (target)
- "Return the project which is the parent of TARGET.
-It is recommended you track the project a different way as this function
-could become slow in time."
- (or ede-object-project
- ;; If not cached, derive it from the current directory of the target.
- (let ((ans nil) (projs ede-projects))
- (while (and (not ans) projs)
- (setq ans (ede-target-in-project-p (car projs) target)
- projs (cdr projs)))
- ans)))
-
-(cl-defmethod ede-find-target ((proj ede-project) buffer)
- "Fetch the target in PROJ belonging to BUFFER or nil."
- (with-current-buffer buffer
-
- ;; We can do a short-ut if ede-object local variable is set.
- (if ede-object
- ;; If the buffer is already loaded with good EDE stuff, make sure the
- ;; saved project is the project we're looking for.
- (when (and ede-object-project (eq proj ede-object-project)) ede-object)
-
- ;; If the variable wasn't set, then we are probably initializing the buffer.
- ;; In that case, search the file system.
- (if (ede-buffer-mine proj buffer)
- proj
- (let ((targets (oref proj targets))
- (f nil))
- (while targets
- (if (ede-buffer-mine (car targets) buffer)
- (setq f (cons (car targets) f)))
- (setq targets (cdr targets)))
- f)))))
-
-(cl-defmethod ede-target-buffer-in-sourcelist ((this ede-target) buffer source)
- "Return non-nil if object THIS is in BUFFER to a SOURCE list.
-Handles complex path issues."
- (member (ede-convert-path this (buffer-file-name buffer)) source))
-
-(cl-defmethod ede-buffer-mine ((_this ede-project) _buffer)
- "Return non-nil if object THIS lays claim to the file in BUFFER."
- nil)
-
-(cl-defmethod ede-buffer-mine ((this ede-target) buffer)
- "Return non-nil if object THIS lays claim to the file in BUFFER."
- (condition-case nil
- (ede-target-buffer-in-sourcelist this buffer (oref this source))
- ;; An error implies a bad match.
- (error nil)))
-
-\f
-;;; Project mapping
-;;
-(defun ede-project-buffers (project)
- "Return a list of all active buffers controlled by PROJECT.
-This includes buffers controlled by a specific target of PROJECT."
- (let ((bl (buffer-list))
- (pl nil))
- (while bl
- (with-current-buffer (car bl)
- (when (and ede-object (ede-find-target project (car bl)))
- (setq pl (cons (car bl) pl))))
- (setq bl (cdr bl)))
- pl))
-
-(defun ede-target-buffers (target)
- "Return a list of buffers that are controlled by TARGET."
- (let ((bl (buffer-list))
- (pl nil))
- (while bl
- (with-current-buffer (car bl)
- (if (if (listp ede-object)
- (memq target ede-object)
- (eq ede-object target))
- (setq pl (cons (car bl) pl))))
- (setq bl (cdr bl)))
- pl))
-
-(defun ede-buffers ()
- "Return a list of all buffers controlled by an EDE object."
- (let ((bl (buffer-list))
- (pl nil))
- (while bl
- (with-current-buffer (car bl)
- (if ede-object
- (setq pl (cons (car bl) pl))))
- (setq bl (cdr bl)))
- pl))
-
-(defun ede-map-buffers (proc)
- "Execute PROC on all buffers controlled by EDE."
- (mapcar proc (ede-buffers)))
-
-(cl-defmethod ede-map-project-buffers ((this ede-project) proc)
- "For THIS, execute PROC on all buffers belonging to THIS."
- (mapcar proc (ede-project-buffers this)))
-
-(cl-defmethod ede-map-target-buffers ((this ede-target) proc)
- "For THIS, execute PROC on all buffers belonging to THIS."
- (mapcar proc (ede-target-buffers this)))
-
-;; other types of mapping
-(cl-defmethod ede-map-subprojects ((this ede-project) proc)
- "For object THIS, execute PROC on all direct subprojects.
-This function does not apply PROC to sub-sub projects.
-See also `ede-map-all-subprojects'."
- (mapcar proc (oref this subproj)))
-
-(cl-defmethod ede-map-all-subprojects ((this ede-project) allproc)
- "For object THIS, execute PROC on THIS and all subprojects.
-This function also applies PROC to sub-sub projects.
-See also `ede-map-subprojects'."
- (apply #'append
- (list (funcall allproc this))
- (ede-map-subprojects
- this
- (lambda (sp)
- (ede-map-all-subprojects sp allproc))
- )))
-
-;; (ede-map-all-subprojects (ede-load-project-file "../semantic/") (lambda (sp) (oref sp file)))
-
-(cl-defmethod ede-map-targets ((this ede-project) proc)
- "For object THIS, execute PROC on all targets."
- (mapcar proc (oref this targets)))
-
-(cl-defmethod ede-map-any-target-p ((this ede-project) proc)
- "For project THIS, map PROC to all targets and return if any non-nil.
-Return the first non-nil value returned by PROC."
- (cl-some proc (oref this targets)))
-
-\f
-;;; Some language specific methods.
-;;
-;; These items are needed by ede-cpp-root to add better support for
-;; configuring items for Semantic.
-
-;; Generic paths
-(cl-defmethod ede-system-include-path ((_this ede-project))
- "Get the system include path used by project THIS."
- nil)
-
-(cl-defmethod ede-system-include-path ((_this ede-target))
- "Get the system include path used by project THIS."
- nil)
-
-(cl-defmethod ede-source-paths ((_this ede-project) _mode)
- "Get the base to all source trees in the current project for MODE.
-For example, <root>/src for sources of c/c++, Java, etc,
-and <root>/doc for doc sources."
- nil)
-
-;; C/C++
-(defun ede-apply-preprocessor-map ()
- "Apply preprocessor tables onto the current buffer."
- ;; TODO - what if semantic-mode isn't enabled?
- ;; what if we never want to load a C mode? Does this matter?
- ;; Note: This require is needed for the case where EDE ends up
- ;; in the hook order before Semantic based hooks.
- (require 'semantic/lex-spp)
- (when (and ede-object
- (boundp 'semantic-lex-spp-project-macro-symbol-obarray))
- (let* ((objs ede-object)
- (map (ede-preprocessor-map (if (consp objs)
- (car objs)
- objs))))
- (when map
- ;; We can't do a require for the below symbol.
- (setq semantic-lex-spp-project-macro-symbol-obarray
- (semantic-lex-make-spp-table map)))
- (when (consp objs)
- (message "Choosing preprocessor syms for project %s"
- (eieio-object-name (car objs)))))))
-
-(cl-defmethod ede-system-include-path ((_this ede-project))
- "Get the system include path used by project THIS."
- nil)
-
-(cl-defmethod ede-preprocessor-map ((_this ede-project))
- "Get the pre-processor map for project THIS."
- nil)
-
-(cl-defmethod ede-preprocessor-map ((_this ede-target))
- "Get the pre-processor map for project THIS."
- nil)
-
-;; Java
-(cl-defmethod ede-java-classpath ((_this ede-project))
- "Return the classpath for this project."
- ;; @TODO - Can JDEE add something here?
- nil)
-
-\f
-;;; Project-local variables
-
-(defun ede-set (variable value &optional proj)
- "Set the project local VARIABLE to VALUE.
-If VARIABLE is not project local, just use set. Optional argument PROJ
-is the project to use, instead of `ede-current-project'."
- (interactive "sVariable: \nxExpression: ")
- (let ((p (or proj (ede-toplevel))))
- ;; Make the change
- (ede-make-project-local-variable variable p)
- (ede-set-project-local-variable variable value p)
- (ede-commit-local-variables p)
-
- ;; This is a heavy hammer, but will apply variables properly
- ;; based on stacking between the toplevel and child projects.
- (ede-map-buffers 'ede-apply-project-local-variables)
-
- value))
-
-(defun ede-apply-project-local-variables (&optional buffer)
- "Apply project local variables to the current buffer."
- (with-current-buffer (or buffer (current-buffer))
- ;; Always apply toplevel variables.
- (if (not (eq (ede-current-project) (ede-toplevel)))
- (ede-set-project-variables (ede-toplevel)))
- ;; Next apply more local project's variables.
- (if (ede-current-project)
- (ede-set-project-variables (ede-current-project)))
- ))
-
-(defun ede-make-project-local-variable (variable &optional project)
- "Make VARIABLE project-local to PROJECT."
- (if (not project) (setq project (ede-toplevel)))
- (if (assoc variable (oref project local-variables))
- nil
- (oset project local-variables (cons (list variable)
- (oref project local-variables)))))
-
-(defun ede-set-project-local-variable (variable value &optional project)
- "Set VARIABLE to VALUE for PROJECT.
-If PROJ isn't specified, use the current project.
-This function only assigns the value within the project structure.
-It does not apply the value to buffers."
- (if (not project) (setq project (ede-toplevel)))
- (let ((va (assoc variable (oref project local-variables))))
- (unless va
- (error "Cannot set project variable until it is added with `ede-make-project-local-variable'"))
- (setcdr va value)))
-
-(cl-defmethod ede-set-project-variables ((project ede-project) &optional buffer)
- "Set variables local to PROJECT in BUFFER."
- (if (not buffer) (setq buffer (current-buffer)))
- (with-current-buffer buffer
- (dolist (v (oref project local-variables))
- (make-local-variable (car v))
- (set (car v) (cdr v)))))
-
-(cl-defmethod ede-commit-local-variables ((_proj ede-project))
- "Commit change to local variables in PROJ."
- nil)
-
-;;; Integration with project.el
-
-(defun project-try-ede (dir)
- ;; FIXME: This passes the `ROOT' dynbound variable, but I don't know
- ;; where it comes from!
- (let ((project-dir
- (locate-dominating-file
- dir
- (lambda (dir)
- (ede-directory-get-open-project dir 'ROOT)))))
- (when project-dir
- (ede-directory-get-open-project project-dir 'ROOT))))
-
-(cl-defmethod project-root ((project ede-project))
- (ede-project-root-directory project))
-
-;;; FIXME: Could someone look into implementing `project-ignores' for
-;;; EDE and/or a faster `project-files'?
-
-(add-hook 'project-find-functions #'project-try-ede 50)
-
-(provide 'ede)
-
-;; Include this last because it depends on ede.
-(if t (require 'ede/files)) ;; Don't bother loading it at compile-time.
-
-;; If this does not occur after the provide, we can get a recursive
-;; load. Yuck!
-(with-eval-after-load 'speedbar
- (ede-speedbar-file-setup))
-
-;;; ede.el ends here
+++ /dev/null
-;;; ede/auto.el --- Autoload features for EDE -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2010-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; EDE Autoloads are a way to refer to different project types without
-;; loading those projects into Emacs.
-;;
-;; These routines are used to detect a project in a filesystem before
-;; handing over control to the usual EDE project system.
-
-;;; Code:
-
-(require 'eieio)
-(require 'cl-generic)
-(require 'eieio-base)
-
-(declare-function ede-directory-safe-p "ede")
-(declare-function ede-add-project-to-global-list "ede")
-
-(defclass ede-project-autoload-dirmatch ()
- ((fromconfig :initarg :fromconfig
- :initform nil
- :documentation
- "A config file within which the match pattern lives.")
- (configregex :initarg :configregex
- :initform nil
- :documentation
- "A regexp to identify the dirmatch pattern.")
- (configregexidx :initarg :configregexidx
- :initform nil
- :documentation
- "An index into the match-data of `configregex'.")
- (subdir-only :initarg :subdir-only
- :initform t
- :documentation
- "Non-nil means an exact match to the found directory is a non-match.
-This implies projects exist only in subdirectories of the configuration path.
-If `:subdir-only' is nil, then the directory from the configuration file is the project.")
- (configdatastash :documentation
- "Save discovered match string.")
- )
- "Support complex matches for projects that live in named directories.
-For most cases, a simple string is sufficient. If, however, a project
-location is varied dependent on other complex criteria, this class
-can be used to define that match without loading the specific project
-into memory.")
-
-(cl-defmethod ede-calc-fromconfig ((dirmatch ede-project-autoload-dirmatch))
- "Calculate the value of :fromconfig from DIRMATCH."
- (let* ((fc (oref dirmatch fromconfig))
- (found (cond ((stringp fc) fc)
- ((functionp fc) (funcall fc))
- (t (error "Unknown dirmatch object match style")))))
- (expand-file-name found)
- ))
-
-(cl-defmethod ede-dirmatch-installed ((dirmatch ede-project-autoload-dirmatch))
- "Return non-nil if the tool DIRMATCH might match is installed on the system."
- (file-exists-p (ede-calc-fromconfig dirmatch)))
-
-(cl-defmethod ede-do-dirmatch ((dirmatch ede-project-autoload-dirmatch) file)
- "Does DIRMATCH match the filename FILE."
- (let ((fc (ede-calc-fromconfig dirmatch)))
-
- (cond
- ;; If the thing to match is stored in a config file.
- ((stringp fc)
- (when (file-exists-p fc)
- (let ((matchstring
- (if (slot-boundp dirmatch 'configdatastash)
- (oref dirmatch configdatastash)
- nil)))
- (when (and (not matchstring) (not (slot-boundp dirmatch 'configdatastash)))
- (save-current-buffer
- (let* ((buff (get-file-buffer fc))
- (readbuff
- (let ((find-file-hook nil)) ;; Disable ede from recursing
- (find-file-noselect fc))))
- (set-buffer readbuff)
- (save-excursion
- (goto-char (point-min))
- (when (re-search-forward (oref dirmatch configregex) nil t)
- (setq matchstring
- (match-string (or (oref dirmatch configregexidx) 0)))))
- (if (not buff) (kill-buffer readbuff))))
- (when matchstring
- ;; If this dirmatch only finds subdirs of matchstring, then
- ;; force matchstring to be a directory.
- (when (oref dirmatch subdir-only)
- (setq matchstring (file-name-as-directory matchstring)))
- ;; Convert matchstring to a regexp
- (setq matchstring (concat "^" (regexp-quote matchstring)))
- ;; Stash it for later.
- (oset dirmatch configdatastash matchstring))
- ;; Debug
- ;;(message "Stashing config data for dirmatch %S as %S" (eieio-object-name dirmatch) matchstring)
- )
- ;;(message "dirmatch %s against %s" matchstring (expand-file-name file))
- ;; Match against our discovered string
- (setq file (file-name-as-directory (expand-file-name file)))
- (and matchstring (string-match matchstring (expand-file-name file))
- (or (not (oref dirmatch subdir-only))
- (not (= (match-end 0) (length file))))
- )
- )))
-
- ;; Add new matches here
- ;; ((stringp somenewslot ...)
- ;; )
-
- ;; Error if none others known
- (t
- (error "Unknown dirmatch object match style")))
- ))
-
-(declare-function ede-directory-safe-p "ede")
-(declare-function ede-add-project-to-global-list "ede")
-
-(defclass ede-project-autoload (eieio-named)
- ((name :initarg :name
- :documentation "Name of this project type")
- (file :initarg :file
- :documentation "The lisp file belonging to this class.")
- (proj-file :initarg :proj-file
- :documentation "Name of a project file of this type.")
- (root-only :initarg :root-only
- :initform t ;; Default - majority case.
- :documentation
- "Non-nil if project detection only finds proj-file @ project root.")
- (proj-root-dirmatch :initarg :proj-root-dirmatch
- :initform nil
- :type (or null string ede-project-autoload-dirmatch)
- :documentation
- "To avoid loading a project, check if the directory matches this.
-Specifying this matcher object will allow EDE to perform a complex
-check without loading the project.
-
-NOTE: If you use dirmatch, you may need to set :root-only to nil.
-While it may be a root based project, all subdirs will happen to return
-true for the dirmatch, so for scanning purposes, set it to nil.")
- (proj-root :initarg :proj-root
- :type function
- :documentation "A function symbol to call for the project root.
-This function takes no arguments, and returns the current directories
-root, if available. Leave blank to use the EDE directory walking
-routine instead.")
- (initializers :initarg :initializers
- :initform nil
- :documentation
- "Initializers passed to the project object.
-These are used so there can be multiple types of projects
-associated with a single object class, based on the initializers used.")
- (load-type :initarg :load-type
- :documentation "Fn symbol used to load this project file.")
- (class-sym :initarg :class-sym
- :documentation "Symbol representing the project class to use.")
- (generic-p :initform nil
- :documentation
- "Generic projects are added to the project list at the end.
-The add routine will set this to non-nil so that future non-generic placement will
-be successful.")
- (new-p :initarg :new-p
- :initform t
- :documentation
- "Non-nil if this is an option when a user creates a project.")
- (safe-p :initarg :safe-p
- :initform t
- :documentation
- "Non-nil if the project load files are \"safe\".
-An unsafe project is one that loads project variables via Emacs
-Lisp code. A safe project is one that loads project variables by
-scanning files without loading Lisp code from them.")
- )
- "Class representing minimal knowledge set to run preliminary EDE functions.
-When more advanced functionality is needed from a project type, that projects
-type is required and the load function used.")
-
-(defvar ede-project-class-files
- (list
- (ede-project-autoload :name "Make" :file 'ede/proj
- :proj-file "Project.ede"
- :root-only nil
- :load-type 'ede-proj-load
- :class-sym 'ede-proj-project
- :safe-p nil)
- (ede-project-autoload :name "Automake" :file 'ede/proj
- :proj-file "Project.ede"
- :root-only nil
- :initializers '(:makefile-type Makefile.am)
- :load-type 'ede-proj-load
- :class-sym 'ede-proj-project
- :safe-p nil)
- (ede-project-autoload :name "automake" :file 'ede/project-am
- :proj-file "Makefile.am"
- :root-only nil
- :load-type 'project-am-load
- :class-sym 'project-am-makefile
- :new-p nil
- :safe-p t)
- )
- "List of vectors defining how to determine what type of projects exist.")
-
-(put 'ede-project-class-files 'risky-local-variable t)
-
-(defun ede-show-supported-projects ()
- "Display all the project types registered with EDE."
- (interactive)
- (let ((b (get-buffer-create "*EDE Autodetect Projects*")))
- (set-buffer b)
- (setq buffer-read-only nil)
- (erase-buffer)
- (dolist (prj ede-project-class-files)
- (insert (oref prj name))
- (newline))
- (display-buffer b)
- ))
-
-;;;###autoload
-(defun ede-add-project-autoload (projauto &optional flag)
- "Add PROJAUTO, an EDE autoload definition to `ede-project-class-files'.
-Optional argument FLAG indicates how this autoload should be
-added. Possible values are:
- `generic' - A generic project type. Keep this at the very end.
- `unique' - A unique project type for a specific project. Keep at the very
- front of the list so more generic projects don't get priority."
- ;; First, can we identify PROJAUTO as already in the list? If so, replace.
- (let ((projlist ede-project-class-files)
- (projname (oref projauto name)))
- (while (and projlist (not (string= (oref (car projlist) name) projname)))
- (setq projlist (cdr projlist)))
-
- (if projlist
- ;; Stick the new one into the old slot.
- (setcar projlist projauto)
-
- ;; Else, see where to insert it.
- (cond ((and flag (eq flag 'unique))
- ;; Unique items get stuck right onto the front.
- (setq ede-project-class-files
- (cons projauto ede-project-class-files)))
-
- ;; Generic Projects go at the very end of the list.
- ((and flag (eq flag 'generic))
- (oset projauto generic-p t)
- (setq ede-project-class-files
- (append ede-project-class-files
- (list projauto))))
-
- ;; Normal projects go at the end of the list, but
- ;; before the generic projects.
- (t
- (let ((prev nil)
- (next ede-project-class-files))
- (while (and next (not (oref (car next) generic-p)))
- (setq prev next
- next (cdr next)))
- (when (not prev)
- (error "ede-project-class-files not initialized"))
- ;; Splice into the list.
- (setcdr prev (cons projauto next))))))))
-
-;;; Project Autoload Methods
-;;
-
-;; New method using detect.el
-(cl-defmethod ede-auto-detect-in-dir ((this ede-project-autoload) dir)
- "Return non-nil if THIS project autoload is found in DIR."
- (let* ((d (file-name-as-directory dir))
- (pf (oref this proj-file))
- (f (when (stringp pf) (expand-file-name pf d))))
- (if f
- (and f (file-exists-p f))
- (let ((dirmatch (oref this proj-root-dirmatch)))
- (cond
- ((stringp dirmatch)
- nil) ; <- do something here - maybe obsolete the option?
- ((ede-project-autoload-dirmatch-p dirmatch)
- (if (and dirmatch (ede-dirmatch-installed dirmatch))
- (ede-do-dirmatch dirmatch dir)
- ;(message "Dirmatch %S not installed." dirmatch)
- )))))))
-
-(cl-defmethod ede-auto-load-project ((this ede-project-autoload) dir)
- "Load in the project associated with THIS project autoload description.
-THIS project description should be valid for DIR, where the project will
-be loaded.
-
-NOTE: Do not call this - it should only be called from `ede-load-project-file'."
- ;; Last line of defense: don't load unsafe projects.
- (when (not (or (oref this safe-p)
- (ede-directory-safe-p dir)))
- (error "Attempt to load an unsafe project (bug elsewhere in EDE)"))
- ;; Things are good - so load the project.
- (let ((o (funcall (oref this load-type) dir)))
- (when (not o)
- (error "Project type error: :load-type failed to create a project"))
- (ede-add-project-to-global-list o)
- ;; @TODO - Add to hash over at `ede-inode-directory-hash'.
- ))
-
-
-
-
-
-
-;;; -------- Old Methods
-;; See if we can do without them.
-
-;; @FIXME - delete from loaddefs to remove this.
-(cl-defmethod ede-project-root ((_this ede-project-autoload))
- "If a project knows its root, return it here.
-Allows for one-project-object-for-a-tree type systems."
- nil)
-
-;; @FIXME - delete from loaddefs to remove this.
-(cl-defmethod ede-project-root-directory ((_this ede-project-autoload) &optional _file)
- "" nil)
-
-(provide 'ede/auto)
-
-;;; ede/auto.el ends here
+++ /dev/null
-;;; ede/autoconf-edit.el --- Keymap for autoconf -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2000, 2009-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Autoconf editing and modification support, and compatibility layer
-;; for Emacses w/out autoconf mode built in.
-
-;;; Code:
-(require 'autoconf)
-(declare-function ede-srecode-setup "ede/srecode")
-(declare-function ede-srecode-insert "ede/srecode")
-
-(defun autoconf-new-program (rootdir program testfile)
- "Initialize a new configure.ac in ROOTDIR for PROGRAM using TESTFILE.
-ROOTDIR is the root directory of a given autoconf controlled project.
-PROGRAM is the program to be configured.
-TESTFILE is the file used with AC_INIT."
- (interactive "DRoot Dir: \nsProgram: \nsTest File: ")
- (require 'ede/srecode)
- (if (bufferp rootdir)
- (set-buffer rootdir)
- (let ((cf1 (expand-file-name "configure.in" rootdir))
- (cf2 (expand-file-name "configure.ac" rootdir)))
- (if (and (or (file-exists-p cf1) (file-exists-p cf2))
- (not (y-or-n-p (format "File %s exists. Start Over? "
- (if (file-exists-p cf1)
- cf1 cf2)
- ))))
- (error "Quit"))
- (find-file cf2)))
- ;; Note, we only ask about overwrite if a string/path is specified.
- (erase-buffer)
- (ede-srecode-setup)
- (ede-srecode-insert
- "file:ede-empty"
- "TEST_FILE" testfile
- "PROGRAM" program)
- )
-
-(defvar autoconf-preferred-macro-order
- '("AC_INIT"
- "AC_CONFIG_SRCDIR"
- "AM_INIT_AUTOMAKE"
- "AM_CONFIG_HEADER"
- ;; Arg parsing
- "AC_ARG_ENABLE"
- "AC_ARG_WITH"
- ;; Programs
- "AC_PROG_MAKE_SET"
- "AC_PROG_AWK"
- "AC_PROG_CC"
- "AC_PROG_CC_C_O"
- "AC_PROG_CPP"
- "AC_PROG_CXX"
- "AC_PROG_CXXCPP"
- "AC_ISC_POSIX"
- "AC_PROG_F77"
- "AC_PROG_GCC_TRADITIONAL"
- "AC_PROG_INSTALL"
- "AC_PROG_LEX"
- "AC_PROG_LN_S"
- "AC_PROG_RANLIB"
- "AC_PROG_YACC"
- "AC_CHECK_PROG"
- "AC_CHECK_PROGS"
- "AC_PROG_LIBTOOL"
- ;; Libraries
- "AC_CHECK_LIB"
- "AC_PATH_XTRA"
- ;; Headers
- "AC_HEADER_STDC"
- "AC_HEADER_SYS_WAIT"
- "AC_HEADER_TIME"
- "AC_HEADERS"
- ;; Typedefs, structures
- "AC_TYPE_PID_T"
- "AC_TYPE_SIGNAL"
- "AC_TYPE_UID_T"
- "AC_STRUCT_TM"
- ;; Compiler characteristics
- "AC_CHECK_SIZEOF"
- "AC_C_CONST"
- ;; Library functions
- "AC_CHECK_FUNCS"
- "AC_TRY_LINK"
- ;; System Services
- ;; Other
- "AM_PATH_LISPDIR"
- "AM_INIT_GUILE_MODULE"
- ;; AC_OUTPUT is always last
- "AC_OUTPUT"
- )
- "List of macros in the order that they prefer to occur in.
-This helps when inserting a macro which doesn't yet exist
-by positioning it near other macros which may exist.
-From the autoconf manual:
- `AC_INIT(FILE)'
- checks for programs
- checks for libraries
- checks for header files
- checks for typedefs
- checks for structures
- checks for compiler characteristics
- checks for library functions
- checks for system services
- `AC_OUTPUT([FILE...])'")
-
-(defvar autoconf-multiple-macros
- '("AC_ARG_ENABLE"
- "AC_ARG_WITH"
- "AC_CHECK_PROGS"
- "AC_CHECK_LIB"
- "AC_CHECK_SIZEOF"
- "AC_TRY_LINK"
- )
- "Macros which appear multiple times.")
-
-(defvar autoconf-multiple-multiple-macros
- '("AC_HEADERS" "AC_CHECK_FUNCS")
- "Macros which appear multiple times, and perform multiple queries.")
-
-(defun autoconf-in-macro (macro)
- "Non-nil if point is in a macro of type MACRO."
- (save-excursion
- (beginning-of-line)
- (looking-at (concat "\\(A[CM]_" macro "\\|" macro "\\)"))))
-
-(defun autoconf-find-last-macro (macro &optional ignore-bol)
- "Move to the last occurrence of MACRO, and return that point.
-The last macro is usually the one in which we would like to insert more
-items such as CHECK_HEADERS."
- (let ((op (point)) (atbol (if ignore-bol "" "^")))
- (goto-char (point-max))
- (if (re-search-backward (concat atbol (regexp-quote macro) "\\s-*\\((\\|$\\)") nil t)
- (progn
- (unless ignore-bol (beginning-of-line))
- (point))
- (goto-char op)
- nil)))
-
-(defun autoconf-parameter-strip (param)
- "Strip the parameter PARAM of whitespace and miscellaneous characters."
- ;; force greedy match for \n.
- (when (string-match "\\`\n*\\s-*\\[?\\s-*" param)
- (setq param (substring param (match-end 0))))
- (when (string-match "\\s-*\\]?\\s-*\\'" param)
- (setq param (substring param 0 (match-beginning 0))))
- ;; Look for occurrences of backslash newline
- (while (string-match "\\s-*\\\\\\s-*\n\\s-*" param)
- (setq param (replace-match " " t t param)))
- param)
-
-(defun autoconf-parameters-for-macro (macro &optional ignore-bol ignore-case)
- "Retrieve the parameters to MACRO.
-Returns a list of the arguments passed into MACRO as strings."
- (let ((case-fold-search ignore-case))
- (save-excursion
- (when (autoconf-find-last-macro macro ignore-bol)
- (forward-sexp 1)
- (mapcar
- #'autoconf-parameter-strip
- (when (looking-at "(")
- (let* ((start (+ (point) 1))
- (end (save-excursion
- (forward-sexp 1)
- (- (point) 1)))
- (ans (buffer-substring-no-properties start end)))
- (split-string ans "," t))))))))
-
-(defun autoconf-position-for-macro (macro)
- "Position the cursor where a new MACRO could be inserted.
-This will appear at the BEGINNING of the macro MACRO should appear AFTER.
-This is to make it compatible with `autoconf-find-last-macro'.
-Assume that MACRO doesn't appear in the buffer yet, so search
-the ordering list `autoconf-preferred-macro-order'."
- ;; Search this list backwards.. heh heh heh
- ;; This lets us do a reverse search easily.
- (let ((ml (member macro (reverse autoconf-preferred-macro-order))))
- (if (not ml) (error "Don't know how to position for %s yet" macro))
- (setq ml (cdr ml))
- (goto-char (point-max))
- (while (and ml (not (autoconf-find-last-macro (car ml))))
- (setq ml (cdr ml)))
- (if (not ml) (error "Could not find context for positioning %s" macro))))
-
-(defun autoconf-insert-macro-at-point (macro &optional param)
- "Add MACRO at the current point with PARAM."
- (insert macro)
- (if param
- (progn
- (insert "(" param ")")
- (if (< (current-column) 3) (insert " dnl")))))
-
-(defun autoconf-insert-new-macro (macro &optional param)
- "Add a call to MACRO in the current autoconf file.
-Deals with macro order. See `autoconf-preferred-macro-order' and
-`autoconf-multiple-macros'.
-Optional argument PARAM is the parameter to pass to the macro as one string."
- (cond ((member macro autoconf-multiple-macros)
- ;; This occurs multiple times
- (or (autoconf-find-last-macro macro)
- (autoconf-position-for-macro macro))
- (forward-sexp 2)
- (end-of-line)
- (insert "\n")
- (autoconf-insert-macro-at-point macro param))
- ((member macro autoconf-multiple-multiple-macros)
- (if (not param)
- (error "You must have a parameter for %s" macro))
- (if (not (autoconf-find-last-macro macro))
- (progn
- ;; Doesn't exist yet....
- (autoconf-position-for-macro macro)
- (forward-sexp 2)
- (end-of-line)
- (insert "\n")
- (autoconf-insert-macro-at-point macro param))
- ;; Does exist, can we fit onto the current line?
- (forward-sexp 2)
- (down-list -1)
- (if (> (+ (current-column) (length param)) fill-column)
- (insert " " param)
- (up-list 1)
- (end-of-line)
- (insert "\n")
- (autoconf-insert-macro-at-point macro param))))
- ((autoconf-find-last-macro macro)
- ;; If it isn't one of the multi's, it's a singleton.
- ;; If it exists, ignore it.
- nil)
- (t
- (autoconf-position-for-macro macro)
- (forward-sexp 1)
- (if (looking-at "\\s-*(")
- (forward-sexp 1))
- (end-of-line)
- (insert "\n")
- (autoconf-insert-macro-at-point macro param))))
-
-(defun autoconf-find-query-for-header (header)
- "Position the cursor where HEADER is queried."
- (interactive "sHeader: ")
- (let ((op (point))
- (found t))
- (goto-char (point-min))
- (condition-case nil
- (while (not
- (progn
- (re-search-forward
- (concat "\\b" (regexp-quote header) "\\b"))
- (save-excursion
- (beginning-of-line)
- (looking-at "AC_CHECK_HEADERS")))))
- ;; We depend on the search failing to exit our loop on failure.
- (error (setq found nil)))
- (if (not found) (goto-char op))
- found))
-
-(defun autoconf-add-query-for-header (header)
- "Add in HEADER to be queried for in our autoconf file."
- (interactive "sHeader: ")
- (or (autoconf-find-query-for-header header)
- (autoconf-insert-new-macro "AC_CHECK_HEADERS" header)))
-
-
-(defun autoconf-find-query-for-func (func)
- "Position the cursor where FUNC is queried."
- (interactive "sFunction: ")
- (let ((op (point))
- (found t))
- (goto-char (point-min))
- (condition-case nil
- (while (not
- (progn
- (re-search-forward
- (concat "\\b" (regexp-quote func) "\\b"))
- (save-excursion
- (beginning-of-line)
- (looking-at "AC_CHECK_FUNCS")))))
- ;; We depend on the search failing to exit our loop on failure.
- (error (setq found nil)))
- (if (not found) (goto-char op))
- found))
-
-(defun autoconf-add-query-for-func (func)
- "Add in FUNC to be queried for in our autoconf file."
- (interactive "sFunction: ")
- (or (autoconf-find-query-for-func func)
- (autoconf-insert-new-macro "AC_CHECK_FUNCS" func)))
-
-(defvar autoconf-program-builtin
- '(("AWK" . "AC_PROG_AWK")
- ("CC" . "AC_PROG_CC")
- ("CPP" . "AC_PROG_CPP")
- ("CXX" . "AC_PROG_CXX")
- ("CXXCPP" . "AC_PROG_CXXCPP")
- ("F77" . "AC_PROG_F77")
- ("GCC_TRADITIONAL" . "AC_PROG_GCC_TRADITIONAL")
- ("INSTALL" . "AC_PROG_INSTALL")
- ("LEX" . "AC_PROG_LEX")
- ("LN_S" . "AC_PROG_LN_S")
- ("RANLIB" . "AC_PROG_RANLIB")
- ("YACC" . "AC_PROG_YACC")
- )
- "Association list of PROGRAM variables and their built-in MACRO.")
-
-(defun autoconf-find-query-for-program (prog)
- "Position the cursor where PROG is queried.
-PROG is the VARIABLE to use in autoconf to identify the program.
-PROG excludes the _PROG suffix. Thus if PROG were EMACS, then the
-variable in configure.ac would be EMACS_PROG."
- (let ((op (point))
- (found t)
- (builtin (assoc prog autoconf-program-builtin)))
- (goto-char (point-min))
- (condition-case nil
- (re-search-forward
- (concat "^"
- (or (cdr-safe builtin)
- (concat "AC_CHECK_PROG\\s-*(\\s-*" prog "_PROG"))
- "\\>"))
- (error (setq found nil)))
- (if (not found) (goto-char op))
- found))
-
-(defun autoconf-add-query-for-program (prog &optional names)
- "Add in PROG to be queried for in our autoconf file.
-Optional NAMES is for non-built-in programs, and is the list
-of possible names."
- (interactive "sProgram: ")
- (if (autoconf-find-query-for-program prog)
- nil
- (let ((builtin (assoc prog autoconf-program-builtin)))
- (if builtin
- (autoconf-insert-new-macro (cdr builtin))
- ;; Not built in, try the params item
- (autoconf-insert-new-macro "AC_CHECK_PROGS" (concat prog "," names))
- ))))
-
-;;; Scrappy little changes
-;;
-(defvar autoconf-deleted-text nil
- "Set to the last bit of text deleted during an edit.")
-
-(defvar autoconf-inserted-text nil
- "Set to the last bit of text inserted during an edit.")
-
-(defmacro autoconf-edit-cycle (&rest body)
- "Start an edit cycle, unsetting the modified flag if there is no change.
-Optional argument BODY is the code to execute which edits the autoconf file."
- `(let ((autoconf-deleted-text nil)
- (autoconf-inserted-text nil)
- (mod (buffer-modified-p)))
- ,@body
- (if (and (not mod)
- (string= autoconf-deleted-text autoconf-inserted-text))
- (set-buffer-modified-p nil))))
-
-(defun autoconf-parameter-count ()
- "Return the number of parameters to the function on the current line."
- (save-excursion
- (beginning-of-line)
- (let* ((end-of-cmd
- (save-excursion
- (if (re-search-forward "(" (line-end-position) t)
- (progn
- (forward-char -1)
- (forward-sexp 1)
- (point))
- ;; Else, just return EOL.
- (line-end-position))))
- (cnt 0))
- (save-restriction
- (narrow-to-region (line-beginning-position) end-of-cmd)
- (condition-case nil
- (progn
- (down-list 1)
- (while (re-search-forward ", ?" end-of-cmd t)
- (setq cnt (1+ cnt)))
- (cond ((> cnt 1)
- ;; If the # is > 1, then there is one fewer , than args.
- (1+ cnt))
- ((not (looking-at "\\s-*)"))
- ;; If there are 0 args, then we have to see if there is one arg.
- (1+ cnt))
- (t
- ;; Else, just return the 0.
- cnt)))
- (error 0))))))
-
-(defun autoconf-delete-parameter (index)
- "Delete the INDEXth parameter from the macro starting on the current line.
-Leaves the cursor where a new parameter can be inserted.
-INDEX starts at 1."
- (beginning-of-line)
- (down-list 1)
- (re-search-forward ", ?" nil nil (1- index))
- (let ((end (save-excursion
- (re-search-forward ",\\|)" (line-end-position))
- (forward-char -1)
- (point))))
- (setq autoconf-deleted-text (buffer-substring (point) end))
- (delete-region (point) end)))
-
-(defun autoconf-insert (text)
- "Insert TEXT."
- (setq autoconf-inserted-text text)
- (insert text))
-
-(defun autoconf-set-version (version)
- "Set the version used with automake to VERSION."
- (if (not (stringp version))
- (signal 'wrong-type-argument '(stringp version)))
- (if (and (autoconf-find-last-macro "AM_INIT_AUTOMAKE")
- (>= (autoconf-parameter-count) 2))
- ;; We can edit right here.
- nil
- ;; Else, look for AC init instead.
- (if (not (and (autoconf-find-last-macro "AC_INIT")
- (>= (autoconf-parameter-count) 2)))
- (error "Cannot update version")))
-
- ;; Perform the edit.
- (autoconf-edit-cycle
- (autoconf-delete-parameter 2)
- (autoconf-insert (concat "[" version "]"))))
-
-(defun autoconf-set-output (outputlist)
- "Set the files created in AC_OUTPUT to OUTPUTLIST.
-OUTPUTLIST is a list of strings representing relative paths
-to Makefiles, or other files using Autoconf substitution."
- (if (not (autoconf-find-last-macro "AC_OUTPUT"))
- (error "Cannot update version")
- (autoconf-edit-cycle
- (autoconf-delete-parameter 1)
- (autoconf-insert (mapconcat (lambda (a) a) outputlist " ")))))
-
-(provide 'ede/autoconf-edit)
-
-;;; ede/autoconf-edit.el ends here
+++ /dev/null
-;;; ede/base.el --- Baseclasses for EDE -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2010-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Baseclasses for EDE.
-;;
-;; Contains all the base structures needed by EDE.
-
-;;; Code:
-(require 'eieio)
-(require 'cl-generic)
-(require 'eieio-speedbar)
-(require 'ede/auto)
-
-;; Defined in ede.el:
-(defvar ede-projects)
-(defvar ede-object)
-(defvar ede-object-root-project)
-
-(declare-function data-debug-new-buffer "data-debug")
-(declare-function data-debug-insert-object-slots "eieio-datadebug")
-(declare-function ede-parent-project "ede" (&optional obj))
-(declare-function ede-current-project "ede" (&optional dir))
-
-;;; TARGET
-;;
-;; The TARGET is an entity in a project that knows about files
-;; and features of those files.
-
-(defclass ede-target (eieio-speedbar-directory-button eieio-named)
- ((buttonface :initform 'speedbar-file-face) ;override for superclass
- (name :initarg :name
- :type string
- :custom string
- :label "Name"
- :group (default name)
- :documentation "Name of this target.")
- ;; @todo - I think this should be "dir", and not "path".
- (path :initarg :path
- :type string
- ;:custom string
- ;:label "Path to target"
- ;:group (default name)
- :documentation "The path to the sources of this target.
-Relative to the path of the project it belongs to.")
- (source :initarg :source
- :initform nil
- ;; I'd prefer a list of strings.
- :type list
- :custom (repeat (string :tag "File"))
- :label "Source Files"
- :group (default source)
- :documentation "Source files in this target.")
- (versionsource :initarg :versionsource
- :initform nil
- :type list
- :custom (repeat (string :tag "File"))
- :label "Source Files with Version String"
- :group (source)
- :documentation
- "Source files with a version string in them.
-These files are checked for a version string whenever the EDE version
-of the master project is changed. When strings are found, the version
-previously there is updated.")
- ;; Class level slots
- ;;
- (sourcetype :allocation :class
- :type list ;; list of symbols
- :documentation
- "A list of `ede-sourcecode' objects this class will handle.
-This is used to match target objects with the compilers they can use, and
-which files this object is interested in."
- :accessor ede-object-sourcecode)
- (keybindings :allocation :class
- :initform '(("D" . ede-debug-target))
- :documentation
-"Keybindings specialized to this type of target."
- :accessor ede-object-keybindings)
- (menu :allocation :class
- :initform '( [ "Debug target" ede-debug-target
- (ede-buffer-belongs-to-target-p) ]
- [ "Run target" ede-run-target
- (ede-buffer-belongs-to-target-p) ]
- )
- :documentation "Menu specialized to this type of target."
- :accessor ede-object-menu)
- )
- "A target is a structure that describes a file set that produces something.
-Targets, as with `Make', is an entity that will manage a file set
-and knows how to compile or otherwise transform those files into some
-other desired outcome.")
-
-;;; PROJECT/PLACEHOLDER
-;;
-;; Project placeholders are minimum parts of a project used
-;; by the project cache. The project cache can refer to these placeholders,
-;; and swap them out with the real-deal when that project is loaded.
-;;
-(defclass ede-project-placeholder (eieio-speedbar-directory-button)
- ((name :initarg :name
- :initform "Untitled"
- :type string
- :custom string
- :label "Name"
- :group (default name)
- :documentation "The name used when generating distribution files.")
- (version :initarg :version
- :initform "1.0"
- :type string
- :custom string
- :label "Version"
- :group (default name)
- :documentation "The version number used when distributing files.")
- (directory :type string
- :initarg :directory
- :documentation "Directory this project is associated with.")
- (dirinode :documentation "The inode id for :directory.")
- (file :type string
- :initarg :file
- :documentation "The File uniquely tagging this project instance.
-For some project types, this will be the file that stores the project configuration.
-In other projects types, this file is merely a unique identifier to this type of project.")
- (rootproject ; :initarg - no initarg, don't save this slot!
- :initform nil
- :type (or null ede-project-placeholder)
- :documentation "Pointer to our root project.")
- )
- "Placeholder object for projects not loaded into memory.
-Projects placeholders will be stored in a user specific location
-and querying them will cause the actual project to get loaded.")
-
-;;; PROJECT
-;;
-;; An EDE project controls a set of TARGETS, and can also contain
-;; multiple SUBPROJECTS.
-;;
-;; The project defines a set of features that need to be built from
-;; files, in addition as to controlling what to do with the file set,
-;; such as creating distributions, compilation, and web sites.
-;;
-;; Projects can also affect how EDE works, by changing what appears in
-;; the EDE menu, or how some keys are bound.
-;;
-(defclass ede-project (ede-project-placeholder)
- ((subproj :initform nil
- :type list
- :documentation "Sub projects controlled by this project.
-For Automake based projects, each directory is treated as a project.")
- (targets :initarg :targets
- :type (list-of ede-target)
- :custom (repeat (object :objectcreatefcn ede-new-target-custom))
- :label "Local Targets"
- :group (targets)
- :documentation "List of top level targets in this project.")
- (locate-obj :type (or null ede-locate-base)
- :documentation
- "A locate object to use as a backup to `ede-expand-filename'.")
- (tool-cache :initarg :tool-cache
- :type list
- :custom (repeat object)
- :label "Tool: "
- :group tools
- :documentation "List of tool cache configurations in this project.
-This allows any tool to create, manage, and persist project-specific settings.")
- (mailinglist :initarg :mailinglist
- :initform ""
- :type string
- :custom string
- :label "Mailing List Address"
- :group name
- :documentation
- "An email address where users might send email for help.")
- (web-site-url :initarg :web-site-url
- :initform ""
- :type string
- :custom string
- :label "Web Site URL"
- :group name
- :documentation "URL to this projects web site.
-This is a URL to be sent to a web site for documentation.")
- (web-site-directory :initarg :web-site-directory
- :initform ""
- :custom string
- :label "Web Page Directory"
- :group name
- :documentation
- "A directory where web pages can be found by Emacs.
-For remote locations use a path compatible with ange-ftp.
-You can also use TRAMP for use with rcp & scp.")
- (web-site-file :initarg :web-site-file
- :initform ""
- :custom string
- :label "Web Page File"
- :group name
- :documentation
- "A file which contains the website for this project.
-This file can be relative to slot `web-site-directory'.
-This can be a local file, use ange-ftp or TRAMP.")
- (ftp-site :initarg :ftp-site
- :initform ""
- :type string
- :custom string
- :label "FTP site"
- :group name
- :documentation
- "FTP site where this project's distribution can be found.
-This FTP site should be in Emacs form, as needed by `ange-ftp', but can
-also be of a form used by TRAMP for use with scp, or rcp.")
- (ftp-upload-site :initarg :ftp-upload-site
- :initform ""
- :type string
- :custom string
- :label "FTP Upload site"
- :group name
- :documentation
- "FTP Site to upload new distributions to.
-This FTP site should be in Emacs form as needed by `ange-ftp'.
-If this slot is nil, then use `ftp-site' instead.")
- (configurations :initarg :configurations
- :initform '("debug" "release")
- :type list
- :custom (repeat string)
- :label "Configuration Options"
- :group (settings)
- :documentation "List of available configuration types.
-Individual target/project types can form associations between a configuration,
-and target specific elements such as build variables.")
- (configuration-default :initarg :configuration-default
- :initform "debug"
- :custom string
- :label "Current Configuration"
- :group (settings)
- :documentation "The default configuration.")
- (local-variables :initarg :local-variables
- :initform nil
- :custom (repeat (cons (sexp :tag "Variable")
- (sexp :tag "Value")))
- :label "Project Local Variables"
- :group (settings)
- :documentation "Project local variables")
- (keybindings :allocation :class
- :initform '(("D" . ede-debug-target)
- ("R" . ede-run-target))
- :documentation "Keybindings specialized to this type of target."
- :accessor ede-object-keybindings)
- (menu :allocation :class
- :initform
- '(
- [ "Update Version" ede-update-version ede-object ]
- [ "Version Control Status" ede-vc-project-directory ede-object ]
- [ "Edit Project Website" ede-edit-web-page
- (and ede-object (oref (ede-toplevel) web-site-file)) ]
- [ "Browse Project URL" ede-web-browse-home
- (and ede-object
- (not (string= "" (oref (ede-toplevel) web-site-url)))) ]
- "--"
- [ "Rescan Project Files" ede-rescan-toplevel t ]
- [ "Edit Projectfile" ede-edit-file-target
- (ede-buffer-belongs-to-project-p) ]
- )
- :documentation "Menu specialized to this type of target."
- :accessor ede-object-menu)
- )
- "Top level EDE project specification.
-All specific project types must derive from this project."
- :method-invocation-order :depth-first)
-
-;;; Important macros for doing commands.
-;;
-(defmacro ede-with-projectfile (obj &rest forms)
- "For the project in which OBJ resides, execute FORMS."
- (declare (indent 1) (debug t))
- (unless (symbolp obj)
- (message "Beware! ede-with-projectfile's first arg is copied: %S" obj))
- `(let* ((pf (if (obj-of-class-p ,obj 'ede-target)
- (ede-target-parent ,obj)
- ,obj))
- (dbka (get-file-buffer (oref pf file))))
- (with-current-buffer
- (if (not dbka) (find-file-noselect (oref pf file))
- dbka)
- ,@forms
- (if (not dbka) (kill-buffer (current-buffer))))))
-
-;;; The EDE persistent cache.
-;;
-;; The cache is a way to mark where all known projects live without
-;; loading those projects into memory, or scanning for them each time
-;; emacs starts.
-;;
-(defcustom ede-project-placeholder-cache-file
- (locate-user-emacs-file "ede-projects.el" ".projects.ede")
- "File containing the list of projects EDE has viewed.
-If set to nil, then the cache is not saved."
- :group 'ede
- :type '(choice (const :tag "Don't save the cache" nil)
- file))
-
-(defvar ede-project-cache-files nil
- "List of project files EDE has seen before.")
-
-(defvar recentf-exclude)
-
-(defun ede-save-cache ()
- "Save a cache of EDE objects that Emacs has seen before."
- (interactive)
- (when ede-project-placeholder-cache-file
- (let ((p ede-projects)
- (c ede-project-cache-files)
- (recentf-exclude `( ,(lambda (_) t) ))
- )
- (condition-case nil
- (progn
- (set-buffer (find-file-noselect ede-project-placeholder-cache-file t))
- (erase-buffer)
- (insert ";; EDE project cache file.
-;; This contains a list of projects you have visited.\n(")
- (while p
- (when (and (car p) (ede-project-p p))
- (let ((f (oref (car p) file)))
- (when (file-exists-p f)
- (insert "\n \"" f "\""))))
- (setq p (cdr p)))
- (while c
- (insert "\n \"" (car c) "\"")
- (setq c (cdr c)))
- (insert "\n)\n")
- (condition-case nil
- (save-buffer 0)
- (error
- (message "File %s could not be saved."
- ede-project-placeholder-cache-file)))
- (kill-buffer (current-buffer))
- )
- (error
- (message "File %s could not be read."
- ede-project-placeholder-cache-file))
-
- ))))
-
-(defun ede-load-cache ()
- "Load the cache of EDE projects."
- (save-excursion
- (let ((cachebuffer (get-buffer-create "*ede cache*")))
- (condition-case nil
- (with-current-buffer cachebuffer
- (erase-buffer)
- (when (file-exists-p ede-project-placeholder-cache-file)
- (insert-file-contents ede-project-placeholder-cache-file))
- (goto-char (point-min))
- (let ((c (read (current-buffer)))
- (new nil)
- (p ede-projects))
- ;; Remove loaded projects from the cache.
- (while p
- (setq c (delete (oref (car p) file) c))
- (setq p (cdr p)))
- ;; Remove projects that aren't on the filesystem
- ;; anymore.
- (while c
- (when (file-exists-p (car c))
- (setq new (cons (car c) new)))
- (setq c (cdr c)))
- ;; Save it
- (setq ede-project-cache-files (nreverse new))))
- (error nil))
- (when cachebuffer (kill-buffer cachebuffer))
- )))
-
-;;; Get the cache usable.
-
-;; @TODO - Remove this cache setup, or use this for something helpful.
-;;(add-hook 'kill-emacs-hook 'ede-save-cache)
-;;(when (not noninteractive)
-;; ;; No need to load the EDE cache if we aren't interactive.
-;; ;; This occurs during batch byte-compiling of other tools.
-;; (ede-load-cache))
-
-\f
-;;; METHODS
-;;
-;; The methods in ede-base handle project related behavior, and DO NOT
-;; related to EDE mode commands directory, such as keybindings.
-;;
-;; Mode related methods are in ede.el. These methods are related
-;; project specific activities not directly tied to a keybinding.
-(cl-defmethod ede-subproject-relative-path ((proj ede-project) &optional parent-in)
- "Get a path name for PROJ which is relative to the parent project.
-If PARENT is specified, then be relative to the PARENT project.
-Specifying PARENT is useful for sub-sub projects relative to the root project."
- (let* ((parent (or parent-in (ede-parent-project proj)))
- (dir (file-name-directory (oref proj file))))
- (if (and parent (not (eq parent proj)))
- (file-relative-name dir (file-name-directory (oref parent file)))
- "")))
-
-(cl-defmethod ede-subproject-p ((proj ede-project))
- "Return non-nil if PROJ is a sub project."
- ;; @TODO - Use this in more places, and also pay attention to
- ;; metasubproject in ede/proj.el
- (ede-parent-project proj))
-
-\f
-;;; Default descriptive methods for EDE classes
-;;
-;; These are methods which you might want to override, but there is
-;; no need to in most situations because they are either a) simple, or
-;; b) cosmetic.
-
-(cl-defmethod ede-name ((this ede-target))
- "Return the name of THIS target."
- (oref this name))
-
-(cl-defmethod ede-target-name ((this ede-target))
- "Return the name of THIS target, suitable for make or debug style commands."
- (oref this name))
-
-(cl-defmethod ede-name ((this ede-project))
- "Return a short-name for THIS project file.
-Do this by extracting the lowest directory name."
- (oref this name))
-
-(cl-defmethod ede-description ((this ede-project))
- "Return a description suitable for the minibuffer about THIS."
- (format "Project %s: %d subprojects, %d targets."
- (ede-name this) (length (oref this subproj))
- (length (oref this targets))))
-
-(cl-defmethod ede-description ((this ede-target))
- "Return a description suitable for the minibuffer about THIS."
- (format "Target %s: with %d source files."
- (ede-name this) (length (oref this source))))
-
-;;; HEADERS/DOC
-;;
-;; Targets and projects are often associated with other files, such as
-;; header files, documentation files and the like. Have strong
-;; associations can make useful user commands to quickly navigate
-;; between the files based on their associations.
-;;
-(defun ede-header-file ()
- "Return the header file for the current buffer.
-Not all buffers need headers, so return nil if no applicable."
- (if ede-object
- (ede-buffer-header-file ede-object (current-buffer))
- nil))
-
-(cl-defmethod ede-buffer-header-file ((_this ede-project) _buffer)
- "Return nil, projects don't have header files."
- nil)
-
-(cl-defmethod ede-buffer-header-file ((this ede-target) buffer)
- "There are no default header files in EDE.
-Do a quick check to see if there is a Header tag in this buffer."
- (with-current-buffer buffer
- (if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t)
- (buffer-substring-no-properties (match-beginning 1)
- (match-end 1))
- (let ((src (ede-target-sourcecode this))
- (found nil))
- (while (and src (not found))
- (setq found (ede-buffer-header-file (car src) (buffer-file-name))
- src (cdr src)))
- found))))
-
-(defun ede-documentation-files ()
- "Return the documentation files for the current buffer.
-Not all buffers need documentations, so return nil if no applicable.
-Some projects may have multiple documentation files, so return a list."
- (if ede-object
- (ede-buffer-documentation-files ede-object (current-buffer))
- nil))
-
-(cl-defmethod ede-buffer-documentation-files ((this ede-project) _buffer)
- "Return all documentation in project THIS based on BUFFER."
- ;; Find the info node.
- (ede-documentation this))
-
-(cl-defmethod ede-buffer-documentation-files ((_this ede-target) buffer)
- "Check for some documentation files for THIS.
-Also do a quick check to see if there is a Documentation tag in this BUFFER."
- (with-current-buffer buffer
- (if (re-search-forward "::Documentation:: \\([a-zA-Z0-9.]+\\)" nil t)
- (buffer-substring-no-properties (match-beginning 1)
- (match-end 1))
- ;; Check the master project
- (let ((cp (ede-toplevel)))
- (ede-buffer-documentation-files cp (current-buffer))))))
-
-(cl-defmethod ede-documentation ((this ede-project))
- "Return a list of files that provide documentation.
-Documentation is not for object THIS, but is provided by THIS for other
-files in the project."
- (let ((targ (oref this targets))
- (proj (oref this subproj))
- (found nil))
- (while targ
- (setq found (append (ede-documentation (car targ)) found)
- targ (cdr targ)))
- (while proj
- (setq found (append (ede-documentation (car proj)) found)
- proj (cdr proj)))
- found))
-
-(cl-defmethod ede-documentation ((_this ede-target))
- "Return a list of files that provide documentation.
-Documentation is not for object THIS, but is provided by THIS for other
-files in the project."
- nil)
-
-(defun ede-html-documentation-files ()
- "Return a list of HTML documentation files associated with this project."
- (ede-html-documentation (ede-toplevel))
- )
-
-(cl-defmethod ede-html-documentation ((_this ede-project))
- "Return a list of HTML files provided by project THIS."
-
- )
-
-;;; Default "WANT" methods.
-;;
-;; These methods are used to determine if a target "wants", or could
-;; somehow handle a file, or some source type.
-;;
-(cl-defmethod ede-want-file-p ((this ede-target) file)
- "Return non-nil if THIS target wants FILE."
- ;; By default, all targets reference the source object, and let it decide.
- (let ((src (ede-target-sourcecode this)))
- (while (and src (not (ede-want-file-p (car src) file)))
- (setq src (cdr src)))
- src))
-
-(cl-defmethod ede-want-file-source-p ((this ede-target) file)
- "Return non-nil if THIS target wants FILE."
- ;; By default, all targets reference the source object, and let it decide.
- (let ((src (ede-target-sourcecode this)))
- (while (and src (not (ede-want-file-source-p (car src) file)))
- (setq src (cdr src)))
- src))
-
-(cl-defmethod ede-target-sourcecode ((this ede-target))
- "Return the sourcecode objects which THIS permits."
- (let ((sc (oref this sourcetype))
- (rs nil))
- (while (and (listp sc) sc)
- (setq rs (cons (symbol-value (car sc)) rs)
- sc (cdr sc)))
- rs))
-
-\f
-;;; Debugging.
-;;
-(defun ede-adebug-project ()
- "Run adebug against the current EDE project.
-Display the results as a debug list."
- (interactive)
- (require 'data-debug)
- (when (ede-current-project)
- (data-debug-new-buffer "*Analyzer ADEBUG*")
- (data-debug-insert-object-slots (ede-current-project) "")
- ))
-
-(defun ede-adebug-project-parent ()
- "Run adebug against the current EDE parent project.
-Display the results as a debug list."
- (interactive)
- (require 'data-debug)
- (when (ede-parent-project)
- (data-debug-new-buffer "*Analyzer ADEBUG*")
- (data-debug-insert-object-slots (ede-parent-project) "")
- ))
-
-(defun ede-adebug-project-root ()
- "Run adebug against the current EDE parent project.
-Display the results as a debug list."
- (interactive)
- (require 'data-debug)
- (when (ede-toplevel)
- (data-debug-new-buffer "*Analyzer ADEBUG*")
- (data-debug-insert-object-slots (ede-toplevel) "")
- ))
-
-\f
-
-;;; TOPLEVEL PROJECT
-;;
-;; The toplevel project is a way to identify the EDE structure that belongs
-;; to the top of a project.
-
-(defun ede-toplevel (&optional subproj)
- "Return the ede project which is the root of the current project.
-Optional argument SUBPROJ indicates a subproject to start from
-instead of the current project."
- (or (when (not subproj) ede-object-root-project)
- (let* ((cp (or subproj (ede-current-project))))
- (or (and cp (ede-project-root cp))
- (progn
- (while (ede-parent-project cp)
- (setq cp (ede-parent-project cp)))
- cp)))))
-
-\f
-;;; Utility functions
-;;
-
-(defun ede-normalize-file/directory (this project-file-name)
- "Fills :directory or :file slots if they're missing in project THIS.
-The other slot will be used to calculate values.
-PROJECT-FILE-NAME is a name of project file (short name, like `pom.xml', etc."
- (when (and (or (not (slot-boundp this :file))
- (not (oref this file)))
- (slot-boundp this :directory)
- (oref this directory))
- (oset this file (expand-file-name project-file-name (oref this directory))))
- (when (and (or (not (slot-boundp this :directory))
- (not (oref this directory)))
- (slot-boundp this :file)
- (oref this file))
- (oset this directory (file-name-directory (oref this file))))
- )
-
-\f
-(provide 'ede/base)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/base"
-;; End:
-
-;;; ede/base.el ends here
+++ /dev/null
-;;; ede/config.el --- Configuration Handler baseclass -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2014-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Some auto-detecting projects (such as the 'generic' project type)
-;; can be enhanced by also saving a configuration file that is EDE
-;; specific. EDE will be able to load that configuration from the save
-;; file as a way of augmenting what is normally already detected.
-;;
-;; How To Use:
-;;
-;; Subclass `ede-extra-config', and add the features you want to use.
-;; Several mixins are available for adding in C++ or Java support. Bring
-;; in the pieces you need.
-;;
-;; Your project and targets should all have a common baseclass from
-;; `ede-project-with-config' or `ede-target-with-config'. When
-;; subclassing the project, be sure to override the class allocated
-;; slots for the `config-class'. This will tie your new project to
-;; the new configuration type.
-;;
-;; You can also override the file name used to save the configuration
-;; object in.
-;;
-;; If you need to take special action in `project-rescan' be sure to also
-;; call `call-next-method' to also get the configuration rescanned.
-;;
-;; Note on config file safety:
-;;
-;; Normally an EDE project that loads a save file should have it's
-;; autoload slot :safe-p set to nil. Projects who save data via
-;; config.el can mark their project as :safe-p t. The config system will
-;; do the queries needed to protect the user. This allows a generic
-;; project to become active in cases where no save file exists, nor is
-;; needed.
-
-;;; Code:
-(require 'ede)
-(require 'semantic/db)
-
-;;; CONFIG
-;;
-;; This is the base of a configuration class supported by the
-;; `ede-project-with-config' baseclass.
-;;
-(defclass ede-extra-config (eieio-persistent)
- ((extension :initform ".ede")
- (file-header-line :initform ";; EDE Project Configuration")
- (project :type ede-project-with-config
- :documentation
- "The project this config is bound to.")
- (ignored-file :initform nil
- :type (or null symbol)
- :documentation
- "Set to non-nil if this was created and an on-disk file
-was ignored. Use this to warn the user that they might want to load in
-an on-disk version.")
- )
- "Baseclass for auxiliary configuration files for EDE.
-This should be subclassed by projects that auto detect a project
-and also want to save some extra level of configuration.")
-
-;;; PROJECT BASECLASS
-;;
-;; Subclass this baseclass if you want your EDE project to also
-;; support saving an extra configuration file of unique data
-;; needed for this project.
-;;
-(defclass ede-project-with-config (ede-project)
- ((menu :initform nil)
- (config-file-basename
- :initform "Config.ede"
- :allocation :class
- :type string
- :documentation
- "The filename to use for saving the configuration.
-This filename excludes the directory name and is used to
-initialize the :file slot of the persistent baseclass.")
- (config-class
- :initform 'ede-extra-config
- :allocation :class
- :type class
- :documentation
- "The class of the configuration used by this project.")
- (config :initform nil
- :type (or null ede-extra-config)
- :documentation
- "The configuration object for this project.")
- )
- "Baseclass for projects that save a configuration.")
-
-(defclass ede-target-with-config (ede-target)
- ()
- "Baseclass for targets of classes that use a config object.")
-
-;;; Rescanning
-
-(cl-defmethod project-rescan ((this ede-project-with-config))
- "Rescan this generic project from the sources."
- ;; Force the config to be rescanned.
- (oset this config nil)
- ;; Ask if it is safe to load the config from disk.
- (ede-config-get-configuration this t)
- )
-
-;;; Project Methods for configuration
-
-(cl-defmethod ede-config-get-configuration ((proj ede-project-with-config) &optional loadask)
- "Return the configuration for the project PROJ.
-If optional LOADASK is non-nil, then if a project file exists, and if
-the directory isn't on the `safe' list, ask to add it to the safe list."
- (let ((config (oref proj config)))
-
- ;; If the request is coming at a time when we want to ask the user,
- ;; and there already is a configuration, AND the last time we ignored
- ;; the on-file version we did so automatically (without asking) then
- ;; in theory there are NO mods to this config, and we should re-ask,
- ;; and possibly re-load.
- (when (and loadask config (eq (oref config ignored-file) 'auto))
- (setq config nil))
-
- (when (not config)
- (let* ((top (oref proj directory))
- (fname (expand-file-name (oref proj config-file-basename) top))
- (class (oref proj config-class))
- (ignore-type nil))
- (if (and (file-exists-p fname)
- (or (ede-directory-safe-p top)
- ;; Only force the load if someone asked.
- (and loadask (ede-check-project-directory top))))
- ;; Load in the configuration
- (setq config (eieio-persistent-read fname class))
- ;; If someone said not to load stuff from here then
- ;; pop up a warning.
- (when (file-exists-p fname)
- (message "Ignoring EDE config file for now and creating a new one. Use C-c . g to load it.")
- ;; Set how it was ignored.
- (if loadask
- (setq ignore-type 'manual)
- (setq ignore-type 'auto))
- )
- ;; Create a new one.
- (setq config (make-instance class
- "Configuration"
- :file fname))
- (oset config ignored-file ignore-type)
-
- ;; Set initial values based on project.
- (ede-config-setup-configuration proj config))
- ;; Link things together.
- (oset proj config config)
- (oset config project proj)))
- config))
-
-(cl-defmethod ede-config-setup-configuration ((_proj ede-project-with-config) _config)
- "Default configuration setup method."
- nil)
-
-(cl-defmethod ede-commit-project ((proj ede-project-with-config))
- "Commit any change to PROJ to its file."
- (let ((config (ede-config-get-configuration proj)))
- (ede-commit config)))
-
-;;; Customization
-;;
-(cl-defmethod ede-customize ((proj ede-project-with-config))
- "Customize the EDE project PROJ by actually configuring the config object."
- (let ((config (ede-config-get-configuration proj t)))
- (eieio-customize-object config)))
-
-(cl-defmethod ede-customize ((_target ede-target-with-config))
- "Customize the EDE TARGET by actually configuring the config object."
- ;; Nothing unique for the targets, use the project.
- (ede-customize-project))
-
-(cl-defmethod eieio-done-customizing ((config ede-extra-config))
- "Called when EIEIO is done customizing the configuration object.
-We need to go back through the old buffers, and update them with
-the new configuration."
- (ede-commit config)
- ;; Loop over all the open buffers, and re-apply.
- (ede-map-targets
- (oref config project)
- (lambda (target)
- (ede-map-target-buffers
- target
- (lambda (b)
- (with-current-buffer b
- (ede-apply-target-options)))))))
-
-(cl-defmethod ede-commit ((config ede-extra-config))
- "Commit all changes to the configuration to disk."
- ;; So long as the user is trying to safe this config, make sure they can
- ;; get at it again later.
- (let ((dir (file-name-directory (oref config file))))
- (ede-check-project-directory dir))
-
- (eieio-persistent-save config))
-
-;;; PROJECT MIXINS
-;;
-;; These are project part mixins. Use multiple inheritance for each
-;; piece of these configuration options you would like to have as part
-;; of your project.
-
-;;; PROGRAM
-;; If there is a program that can be run or debugged that is unknown
-;; and needs to be configured.
-(defclass ede-extra-config-program ()
- ((debug-command :initarg :debug-command
- :initform "gdb "
- :type string
- :group commands
- :custom string
- :group (default build)
- :documentation
- "Command used for debugging this project.")
- (run-command :initarg :run-command
- :initform ""
- :type string
- :group commands
- :custom string
- :group (default build)
- :documentation
- "Command used to run something related to this project."))
- "Class to mix into a configuration for debug/run of programs.")
-
-(defclass ede-project-with-config-program ()
- ()
- "Class to mix into a project with configuration for programs.")
-
-(defclass ede-target-with-config-program ()
- ()
- "Class to mix into a project with configuration for programs.
-This class brings in method overloads for running and debugging
-programs from a project.")
-
-(cl-defmethod project-debug-target ((target ede-target-with-config-program))
- "Run the current project derived from TARGET in a debugger."
- (let* ((proj (ede-target-parent target))
- (config (ede-config-get-configuration proj t))
- (debug (oref config debug-command))
- (cmd (read-from-minibuffer
- "Debug Command: "
- debug))
- (cmdsplit (split-string cmd " " t))
- ;; @TODO - this depends on the user always typing in something good
- ;; like "gdb" or "dbx" which also exists as a useful Emacs command.
- ;; Is there a better way?
- (cmdsym (intern-soft (car cmdsplit))))
- (call-interactively cmdsym t)))
-
-(declare-function ede-shell-run-something "ede/shell")
-
-(cl-defmethod project-run-target ((target ede-target-with-config-program))
- "Run the current project derived from TARGET."
- (let* ((proj (ede-target-parent target))
- (config (ede-config-get-configuration proj t))
- (run (concat "./" (oref config run-command)))
- (cmd (read-from-minibuffer "Run (like this): " run)))
- (ede-shell-run-something target cmd)))
-
-;;; BUILD
-;; If the build style is unknown and needs to be configured.
-(defclass ede-extra-config-build ()
- ((build-command :initarg :build-command
- :initform "make -k"
- :type string
- :group commands
- :custom string
- :group (default build)
- :documentation
- "Command used for building this project."))
- "Class to mix into a configuration for compilation.")
-
-(defclass ede-project-with-config-build ()
- ()
- "Class to mix into a project with configuration for builds.
-This class brings in method overloads for building.")
-
-(defclass ede-target-with-config-build ()
- ()
- "Class to mix into a project with configuration for builds.
-This class brings in method overloads for building.")
-
-(cl-defmethod project-compile-project ((proj ede-project-with-config-build) &optional _command)
- "Compile the entire current project PROJ.
-Argument COMMAND is the command to use when compiling."
- (let* ((config (ede-config-get-configuration proj t))
- (comp (oref config build-command)))
- (compile comp)))
-
-(cl-defmethod project-compile-target ((_obj ede-target-with-config-build) &optional command)
- "Compile the current target OBJ.
-Argument COMMAND is the command to use for compiling the target."
- (project-compile-project (ede-current-project) command))
-
-;;; C / C++
-;; Configure includes and preprocessor symbols for C/C++ needed by
-;; Semantic.
-(defclass ede-extra-config-c ()
- ((c-include-path :initarg :c-include-path
- :initform nil
- :type list
- :custom (repeat (string :tag "Path"))
- :group c
- :documentation
- "The include path used by C/C++ projects.
-The include path is used when searching for symbols.")
- (c-preprocessor-table :initarg :c-preprocessor-table
- :initform nil
- :type list
- :custom (repeat (cons (string :tag "Macro")
- (string :tag "Value")))
- :group c
- :documentation
- "Preprocessor Symbols for this project.
-When files within this project are parsed by CEDET, these symbols will be
-used to resolve macro occurrences in source files.
-If you modify this slot, you will need to force your source files to be
-parsed again.")
- (c-preprocessor-files :initarg :c-preprocessor-files
- :initform nil
- :type list
- :group c
- :custom (repeat (string :tag "Include File"))
- :documentation
- "Files parsed and used to populate preprocessor tables.
-When files within this project are parsed by CEDET, these symbols will be used to
-resolve macro occurrences in source files.
-If you modify this slot, you will need to force your source files to be
-parsed again."))
- "Class to mix into a configuration for compilation.")
-
-(defclass ede-project-with-config-c ()
- ()
- "Class to mix into a project for C/C++ support.")
-
-(defclass ede-target-with-config-c ()
- ()
- "Class to mix into a project for C/C++ support.
-This target brings in methods used by Semantic to query
-the preprocessor map, and include paths.")
-
-(cl-defmethod ede-preprocessor-map ((this ede-target-with-config-c))
- "Get the pre-processor map for some generic C code."
- (require 'semantic/sb)
- (let* ((proj (ede-target-parent this))
- (root (ede-project-root proj))
- (config (ede-config-get-configuration proj))
- filemap
- )
- ;; Preprocessor files
- (dolist (G (oref config c-preprocessor-files))
- (let ((table (semanticdb-file-table-object
- (ede-expand-filename root G))))
- (when table
- (when (semanticdb-needs-refresh-p table)
- (semanticdb-refresh-table table))
- (setq filemap (append filemap (oref table lexical-table)))
- )))
- ;; The core table
- (setq filemap (append filemap (oref config c-preprocessor-table)))
-
- filemap
- ))
-
-(cl-defmethod ede-system-include-path ((this ede-target-with-config-c))
- "Get the system include path used by project THIS."
- (let* ((proj (ede-target-parent this))
- (config (ede-config-get-configuration proj)))
- (oref config c-include-path)))
-
-;;; Java
-;; Configuration needed for programming with Java.
-(defclass ede-extra-config-java ()
- ()
- "Class to mix into a configuration for compilation.")
-
-(defclass ede-project-with-config-java ()
- ()
- "Class to mix into a project to support java.
-This brings in methods to support Semantic querying the
-java class path.")
-
-(defclass ede-target-with-config-java ()
- ()
- "Class to mix into a project to support java.")
-
-(eieio-declare-slots classpath)
-
-(cl-defmethod ede-java-classpath ((proj ede-project-with-config-java))
- "Return the classpath for this project."
- ;; The `classpath' slot only exists in the Java parts of cedet, and
- ;; those have not been merged into Emacs. Suppress the warning
- ;; about the unknown slot by using `intern'.
- (oref (ede-config-get-configuration proj) classpath))
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/config"
-;; End:
-
-(provide 'ede/config)
-
-;;; ede/config.el ends here
+++ /dev/null
-;;; ede/cpp-root.el --- A simple way to wrap a C++ project with a single root -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; NOTE: ede/cpp-root.el has been commented so as to also make it
-;; useful for learning how to make similar project types.
-;;
-;; Not everyone can use automake, or an EDE project type. For
-;; pre-existing code, it is often helpful jut to be able to wrap the
-;; whole thing up in as simple a way as possible.
-;;
-;; The cpp-root project type will allow you to create a single object
-;; with no save-file in your .emacs file that will be recognized, and
-;; provide a way to easily allow EDE to provide Semantic with the
-;; ability to find header files, and other various source files
-;; quickly.
-;;
-;; The cpp-root class knows a few things about C++ projects, such as
-;; the prevalence of "include" directories, and typical file-layout
-;; stuff. If this isn't sufficient, you can subclass
-;; `ede-cpp-root-project' and add your own tweaks in just a few lines.
-;; See the end of this file for an example.
-;;
-;;; EXAMPLE
-;;
-;; Add this to your .emacs file, modifying appropriate bits as needed.
-;;
-;; (ede-cpp-root-project "SOMENAME" :file "/dir/to/some/file")
-;;
-;; Replace SOMENAME with whatever name you want, and the filename to
-;; an actual file at the root of your project. It might be a
-;; Makefile, a README file. Whatever. It doesn't matter. It's just
-;; a key to hang the rest of EDE off of.
-;;
-;; The most likely reason to create this project, is to help make
-;; finding files within the project faster. In conjunction with
-;; Semantic completion, having a short include path is key. You can
-;; override the include path like this:
-;;
-;; (ede-cpp-root-project "NAME" :file "FILENAME"
-;; :include-path '( "/include" "../include" "/c/include" )
-;; :system-include-path '( "/usr/include/c++/3.2.2/" )
-;; :spp-table '( ("MOOSE" . "")
-;; ("CONST" . "const") )
-;; :spp-files '( "include/config.h" )
-;; )
-;;
-;; In this case each item in the include path list is searched. If
-;; the directory starts with "/", then that expands to the project
-;; root directory. If a directory does not start with "/", then it
-;; is relative to the default-directory of the current buffer when
-;; the file name is expanded.
-;;
-;; The include path only affects C/C++ header files. Use the slot
-;; :header-match-regexp to change it.
-;;
-;; The :system-include-path allows you to specify full directory
-;; names to include directories where system header files can be
-;; found. These will be applied to files in this project only.
-;;
-;; The :spp-table provides a list of project specific #define style
-;; macros that are unique to this project, passed in to the compiler
-;; on the command line, or are in special headers.
-;;
-;; The :spp-files option is like :spp-table, except you can provide a
-;; file name for a header in your project where most of your CPP
-;; macros reside. Doing this can be easier than listing everything in
-;; the :spp-table option. The files listed in :spp-files should not
-;; start with a /, and are relative to something in :include-path.
-;;
-;; If you want to override the file-finding tool with your own
-;; function you can do this:
-;;
-;; (ede-cpp-root-project "NAME" :file "FILENAME" :locate-fcn 'MYFCN)
-;;
-;; Where FILENAME is a file in the root directory of the project.
-;; Where MYFCN is a symbol for a function. See:
-;;
-;; M-x describe-function RET ede-cpp-root-project RET
-;;
-;; for documentation about the locate-fcn extension.
-;;
-;;; ADVANCED EXAMPLE
-;;
-;; If the cpp-root project style is right for you, but you want a
-;; dynamic loader, instead of hard-coding values in your .emacs, you
-;; can do that too, but you will need to write some Lisp code.
-;;
-;; To do that, you need to add an entry to the
-;; `ede-project-class-files' list, and also provide two functions to
-;; teach EDE how to load your project pattern
-;;
-;; It would look like this:
-;;
-;; (defun MY-FILE-FOR-DIR (&optional dir)
-;; "Return a full file name to the project file stored in DIR."
-;; <write your code here, or return nil>
-;; )
-;;
-;; (defun MY-LOAD (dir)
-;; "Load a project of type `cpp-root' for the directory DIR.
-;; Return nil if there isn't one."
-;; (ede-cpp-root-project "NAME" :file (expand-file-name "FILE" dir)
-;; :locate-fcn 'MYFCN)
-;; )
-;;
-;; (ede-add-project-autoload
-;; (ede-project-autoload "cpp-root"
-;; :name "CPP ROOT"
-;; :file 'ede/cpp-root
-;; :proj-file 'MY-FILE-FOR-DIR
-;; :load-type 'MY-LOAD
-;; :class-sym 'ede-cpp-root-project
-;; :safe-p t))
-;;
-;;; TODO
-;;
-;; Need a way to reconfigure a project, and have it affect all open buffers.
-;; From Tobias Gerdin:
-;;
-;; >>3) Is there any way to refresh an ede-cpp-root-project dynamically? I have
-;; >>some file open part of the project, fiddle with the include paths and would
-;; >>like the open buffer to notice this when I re-evaluate the
-;; >>ede-cpp-root-project constructor.
-;; >
-;; > Another good idea. The easy way is to "revert-buffer" as needed. The
-;; > ede "project local variables" does this already, so it should be easy
-;; > to adapt something.
-;;
-;; I actually tried reverting the buffer but Semantic did not seem to pick
-;; up the differences (the "include summary" reported the same include paths).
-
-(require 'ede)
-(require 'semantic/db)
-
-(defvar semantic-lex-spp-project-macro-symbol-obarray)
-(declare-function semantic-lex-make-spp-table "semantic/lex-spp")
-
-;;; Code:
-
-;;; PROJECT CACHE:
-;;
-;; cpp-root projects are created in a .emacs or other config file. We
-;; need to cache them so if the user re-loads a lisp file with the
-;; config in it, we can flush out the old one and replace it.
-;;
-(defvar ede-cpp-root-project-list nil
- "List of projects created by option `ede-cpp-root-project'.")
-
-
-;;; CLASSES
-;;
-;; EDE sets up projects with two kinds of objects.
-;;
-;; The PROJECT is a class that represents everything under a directory
-;; hierarchy. A TARGET represents a subset of files within a project.
-;; A project can have multiple targets, and multiple sub-projects.
-;; Sub projects should map to sub-directories.
-;;
-;; The CPP-ROOT project maps any file in C or C++ mode to a target for
-;; C files.
-;;
-;; When creating a custom project the project developer an opportunity
-;; to run code to setup various tools whenever an associated buffer is
-;; loaded. The CPP-ROOT project spends most of its time setting up C
-;; level include paths, and PreProcessor macro tables.
-
-(defclass ede-cpp-root-target (ede-target)
- ((project :initform nil
- :initarg :project))
- "EDE cpp-root project target.
-All directories need at least one target.")
-
-;;;###autoload
-(defclass ede-cpp-root-project (ede-project eieio-instance-tracker)
- ((tracking-symbol :initform 'ede-cpp-root-project-list)
- (include-path :initarg :include-path
- :initform '( "/include" "../include/" )
- :type list
- :documentation
- "The default locate function expands filenames within a project.
-If a header file (.h, .hh, etc) name is expanded, and
-the :locate-fcn slot is nil, then the include path is checked
-first, and other directories are ignored. For very large
-projects, this optimization can save a lot of time.
-
-Directory names in the path can be relative to the current
-buffer's `default-directory' (not starting with a /). Directories
-that are relative to the project's root should start with a /, such
-as \"/include\", meaning the directory `include' off the project root
-directory.")
- (system-include-path :initarg :system-include-path
- :initform nil
- :type list
- :documentation
- "The system include path for files in this project.
-C files initialized in an ede-cpp-root-project have their semantic
-system include path set to this value. If this is nil, then the
-semantic path is not modified.")
- (spp-table :initarg :spp-table
- :initform nil
- :type list
- :documentation
- "C Preprocessor macros for your files.
-Preprocessor symbols will be used while parsing your files.
-These macros might be passed in through the command line compiler, or
-are critical symbols derived from header files. Providing header files
-macro values through this slot improves accuracy and performance.
-Use `:spp-files' to use these files directly.")
- (spp-files :initarg :spp-files
- :initform nil
- :type list
- :documentation
- "C header file with Preprocessor macros for your files.
-The PreProcessor symbols appearing in these files will be used while
-parsing files in this project.
-See `semantic-lex-c-preprocessor-symbol-map' for more on how this works.")
- (header-match-regexp :initarg :header-match-regexp
- :initform
- "\\.\\(h\\(h\\|xx\\|pp\\|\\+\\+\\)?\\|H\\)$\\|\\<\\w+$"
- :type string
- :documentation
- "Regexp used to identify C/C++ header files.")
- (locate-fcn :initarg :locate-fcn
- :initform nil
- :type (or null function)
- :documentation
- "The locate function can be used in place of
-`ede-expand-filename' so you can quickly customize your custom target
-to use specialized local routines instead of the EDE routines.
-The function symbol must take two arguments:
- NAME - The name of the file to find.
- DIR - The directory root for this cpp-root project.
-
-It should return the fully qualified file name passed in from NAME. If that file does not
-exist, it should return nil."
- )
- (compile-command :initarg :compile-command
- :initform nil
- :type (or null string function)
- :documentation
- "Compilation command that will be used for this project.
-It could be string or function that will accept proj argument and should return string.
-The string will be passed to `compile' function that will be issued in root
-directory of project."
- )
- )
- "EDE cpp-root project class.
-Each directory needs a project file to control it.")
-
-;;; INIT
-;;
-;; Most projects use `initialize-instance' to do special setup
-;; on the object when it is created. In this case, EDE-CPP-ROOT can
-;; find previous copies of this project, and make sure that one of the
-;; objects is deleted.
-
-(cl-defmethod initialize-instance ((this ede-cpp-root-project)
- &rest _fields)
- "Make sure the :file is fully expanded."
- ;; Add ourselves to the master list
- (cl-call-next-method)
- (let ((f (expand-file-name (oref this file))))
- ;; Remove any previous entries from the main list.
- (let ((old (eieio-instance-tracker-find (file-name-directory f)
- :directory 'ede-cpp-root-project-list)))
- ;; This is safe, because :directory isn't filled in till later.
- (when (and old (not (eq old this)))
- (ede-delete-project-from-global-list old)
- (delete-instance old)))
- ;; Basic initialization.
- (when (or (not (file-exists-p f))
- (file-directory-p f))
- (delete-instance this)
- (error ":file for ede-cpp-root-project must be a file"))
- (oset this file f)
- (oset this directory (file-name-directory f))
- (ede-project-directory-remove-hash (file-name-directory f))
- ;; NOTE: We must add to global list here because these classes are not
- ;; created via the typical loader, but instead via calls from a .emacs
- ;; file.
- (ede-add-project-to-global-list this)
-
- (unless (slot-boundp this 'targets)
- (oset this targets nil))
- ))
-
-;;; SUBPROJ Management.
-;;
-;; This is a way to allow a subdirectory to point back to the root
-;; project, simplifying authoring new single-point projects.
-
-(cl-defmethod ede-find-subproject-for-directory ((proj ede-cpp-root-project)
- _dir)
- "Return PROJ, for handling all subdirs below DIR."
- proj)
-
-;;; TARGET MANAGEMENT
-;;
-;; Creating new targets on a per directory basis is a good way to keep
-;; files organized. See ede-emacs for an example with multiple file
-;; types.
-(cl-defmethod ede-find-target ((proj ede-cpp-root-project) _buffer)
- "Find an EDE target in PROJ for BUFFER.
-If one doesn't exist, create a new one for this directory."
- (let* ((targets (oref proj targets))
- (dir default-directory)
- (ans (object-assoc dir :path targets))
- )
- (when (not ans)
- (setq ans (ede-cpp-root-target dir
- :name (file-name-nondirectory
- (directory-file-name dir))
- :path dir
- :source nil
- :project proj))
- (object-add-to-list proj :targets ans)
- )
- ans))
-
-;;; FILE NAMES
-;;
-;; One of the more important jobs of EDE is to find files in a
-;; directory structure. cpp-root has tricks it knows about how most C
-;; projects are set up with include paths.
-;;
-;; This tools also uses the ede-locate setup for augmented file name
-;; lookup using external tools.
-(cl-defmethod ede-expand-filename-impl ((proj ede-cpp-root-project) name)
- "Within this project PROJ, find the file NAME.
-This knows details about or source tree."
- ;; The slow part of the original is looping over subprojects.
- ;; This version has no subprojects, so this will handle some
- ;; basic cases.
- (let ((ans (cl-call-next-method)))
- (unless ans
- (let* ((lf (oref proj locate-fcn))
- (dir (file-name-directory (oref proj file))))
- (if lf
- (setq ans (funcall lf name dir))
- (if (ede-cpp-root-header-file-p proj name)
- ;; Else, use our little hack.
- (let ((ip (oref proj include-path))
- (tmp nil))
- (while ip
- ;; Translate
- (setq tmp (ede-cpp-root-translate-file proj (car ip)))
- ;; Test this name.
- (setq tmp (expand-file-name name tmp))
- (if (file-exists-p tmp)
- (setq ans tmp))
- (setq ip (cdr ip)) ))
- ;; Else, do the usual.
- (setq ans (cl-call-next-method)))
- )))
- ;; TODO - does this call-next-method happen twice. Is that bad?? Why is it here?
- (or ans (cl-call-next-method))))
-
-(cl-defmethod ede-project-root ((this ede-cpp-root-project))
- "Return my root."
- this)
-
-(cl-defmethod ede-project-root-directory ((this ede-cpp-root-project))
- "Return my root."
- (oref this directory))
-
-;;; C/CPP SPECIFIC CODE
-;;
-;; The following code is specific to setting up header files,
-;; include lists, and Preprocessor symbol tables.
-
-(cl-defmethod ede-cpp-root-header-file-p ((proj ede-cpp-root-project) name)
- "Non-nil if in PROJ the filename NAME is a header."
- (save-match-data
- (string-match (oref proj header-match-regexp) name)))
-
-(cl-defmethod ede-cpp-root-translate-file ((proj ede-cpp-root-project) filename)
- "For PROJ, translate a user specified FILENAME.
-This is for project include paths and spp source files."
- ;; Step one: Root of this project.
- (let ((dir (file-name-directory (oref proj file))))
-
- ;; Step two: Analyze first char, and rehost
- (if (and (not (string= filename "")) (= (aref filename 0) ?/))
- ;; Check relative to root of project
- (setq filename (expand-file-name (substring filename 1)
- dir))
- ;; Relative to current directory.
- (setq filename (expand-file-name filename)))
-
- filename))
-
-(cl-defmethod ede-system-include-path ((this ede-cpp-root-project))
- "Get the system include path used by project THIS."
- (oref this system-include-path))
-
-(cl-defmethod ede-preprocessor-map ((this ede-cpp-root-project))
- "Get the pre-processor map for project THIS."
- (require 'semantic/db)
- (let ((spp (oref this spp-table))
- (root (ede-project-root this))
- )
- (mapc
- (lambda (F)
- (let* ((expfile (ede-expand-filename root F))
- (table (when expfile
- ;; Disable EDE init on preprocessor file load
- ;; otherwise we recurse, cause errs, etc.
- (let ((ede-constructing t))
- (semanticdb-file-table-object expfile))))
- )
- (cond
- ((not (file-exists-p expfile))
- (message "Cannot find file %s in project." F))
- ((string= expfile (buffer-file-name))
- ;; Don't include this file in it's own spp table.
- )
- ((not table)
- (message "No db table available for %s." expfile))
- (t
- (when (semanticdb-needs-refresh-p table)
- (semanticdb-refresh-table table))
- (setq spp (append spp (oref table lexical-table)))))))
- (oref this spp-files))
- spp))
-
-(cl-defmethod ede-system-include-path ((this ede-cpp-root-target))
- "Get the system include path used by target THIS."
- (ede-system-include-path (ede-target-parent this)))
-
-(cl-defmethod ede-preprocessor-map ((this ede-cpp-root-target))
- "Get the pre-processor map for project THIS."
- (ede-preprocessor-map (ede-target-parent this)))
-
-(cl-defmethod project-compile-project ((proj ede-cpp-root-project) &optional _command)
- "Compile the entire current project PROJ.
-Argument COMMAND is the command to use when compiling."
- ;; we need to be in the proj root dir for this to work
- (let* ((cmd (oref proj compile-command))
- (ov (oref proj local-variables))
- (lcmd (when ov (cdr (assoc 'compile-command ov))))
- (cmd-str (cond
- ((stringp cmd) cmd)
- ((functionp cmd) (funcall cmd proj))
- ((stringp lcmd) lcmd)
- ((functionp lcmd) (funcall lcmd proj)))))
- (when cmd-str
- (let ((default-directory (ede-project-root-directory proj)))
- (compile cmd-str)))))
-
-(cl-defmethod project-compile-target ((obj ede-cpp-root-target) &optional command)
- "Compile the current target OBJ.
-Argument COMMAND is the command to use for compiling the target."
- (when (oref obj project)
- (project-compile-project (oref obj project) command)))
-
-
-(cl-defmethod project-rescan ((_this ede-cpp-root-project))
- "Don't rescan this project from the sources."
- (message "cpp-root has nothing to rescan."))
-
-(provide 'ede/cpp-root)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/cpp-root"
-;; End:
-
-;;; ede/cpp-root.el ends here
+++ /dev/null
-;;; ede/custom.el --- customization of EDE projects. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2010-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Customization commands/hooks for EDE.
-;;
-;; EIEIO supports customizing objects, and EDE uses this to allow
-;; users to change basic settings in their projects.
-;;
-
-;;; Code:
-;;; Customization
-;;
-;; Routines for customizing projects and targets.
-
-(require 'ede)
-(eval-when-compile (require 'eieio-custom))
-
-(define-obsolete-variable-alias 'ede-eieio-old-variables
- 'eieio-ede-old-variables "29.1")
-(defvar ede-eieio-old-variables nil
- "The old variables for a project.")
-
-;;; Customization Commands
-;;
-;; These commands initialize customization of EDE control objects.
-
-;;;###autoload
-(defun ede-customize-project ()
- "Edit fields of the current project through EIEIO & Custom."
- (interactive)
- (require 'eieio-custom)
- (let* ((ov (oref (ede-current-project) local-variables))
- (cp (ede-current-project)))
- (ede-customize cp)
- (setq-local ede-eieio-old-variables ov)))
-
-;;;###autoload
-(defalias 'customize-project #'ede-customize-project)
-
-;;;###autoload
-(defun ede-customize-current-target()
- "Edit fields of the current target through EIEIO & Custom."
- (interactive)
- (require 'eieio-custom)
- (if (not (obj-of-class-p ede-object 'ede-target))
- (error "Current file is not part of a target"))
- (ede-customize-target ede-object))
-
-;;;###autoload
-(defalias 'customize-target #'ede-customize-current-target)
-
-(defun ede-customize-target (obj)
- "Edit fields of the current target through EIEIO & Custom.
-OBJ is the target object to customize."
- (require 'eieio-custom)
- (if (and obj (not (obj-of-class-p obj 'ede-target)))
- (error "No logical target to customize"))
- (ede-customize obj))
-
-(cl-defmethod ede-customize ((proj ede-project))
- "Customize the EDE project PROJ."
- (eieio-customize-object proj 'default))
-
-(cl-defmethod ede-customize ((target ede-target))
- "Customize the EDE TARGET."
- (eieio-customize-object target 'default))
-
-;;; Target Sorting
-;;
-;; Target order can be important, but custom doesn't support a way
-;; to resort items in a list. This function by David Engster allows
-;; targets to be re-arranged.
-
-(defvar ede-project-sort-targets-order nil
- "Variable for tracking target order in `ede-project-sort-targets'.")
-
-;;;###autoload
-(defun ede-project-sort-targets ()
- "Create a custom-like buffer for sorting targets of current project."
- (interactive)
- (let ((proj (ede-current-project))
- ;; (count 1)
- ) ;; current order
- (switch-to-buffer (get-buffer-create "*EDE sort targets*"))
- (erase-buffer)
- (setq ede-object-project proj)
- (widget-create 'push-button
- :notify (lambda (&rest _ignore)
- (let ((targets (oref ede-object-project targets))
- cur newtargets)
- (while (setq cur (pop ede-project-sort-targets-order))
- (setq newtargets (append newtargets
- (list (nth cur targets)))))
- (oset ede-object-project targets newtargets))
- (ede-commit-project ede-object-project)
- (kill-buffer))
- " Accept ")
- (widget-insert " ")
- (widget-create 'push-button
- :notify (lambda (&rest _ignore)
- (kill-buffer))
- " Cancel ")
- (widget-insert "\n\n")
- (setq ede-project-sort-targets-order nil)
- (mapc (lambda (x)
- (add-to-ordered-list
- 'ede-project-sort-targets-order
- x x))
- (number-sequence 0 (1- (length (oref proj targets)))))
- (ede-project-sort-targets-list)
- (use-local-map widget-keymap)
- (widget-setup)
- (goto-char (point-min))))
-
-(defun ede-project-sort-targets-list ()
- "Sort the target list while using `ede-project-sort-targets'."
- (save-excursion
- (let ((targets (oref ede-object-project targets))
- (inhibit-read-only t)
- (inhibit-modification-hooks t))
- (goto-char (point-min))
- (forward-line 2)
- (delete-region (point) (point-max))
- (dotimes (count (length targets))
- (if (> count 0)
- (widget-create 'push-button
- :notify (lambda (&rest _ignore)
- (let ((cur ede-project-sort-targets-order))
- (add-to-ordered-list
- 'ede-project-sort-targets-order
- (nth count cur)
- (1- count))
- (add-to-ordered-list
- 'ede-project-sort-targets-order
- (nth (1- count) cur) count))
- (ede-project-sort-targets-list))
- " Up ")
- (widget-insert " "))
- (if (< count (1- (length targets)))
- (widget-create 'push-button
- :notify (lambda (&rest _ignore)
- (let ((cur ede-project-sort-targets-order))
- (add-to-ordered-list
- 'ede-project-sort-targets-order
- (nth count cur) (1+ count))
- (add-to-ordered-list
- 'ede-project-sort-targets-order
- (nth (1+ count) cur) count))
- (ede-project-sort-targets-list))
- " Down ")
- (widget-insert " "))
- (widget-insert (concat " " (number-to-string (1+ count)) ".: "
- (oref (nth (nth count ede-project-sort-targets-order)
- targets)
- name)
- "\n"))))))
-
-;;; Customization hooks
-;;
-;; These hooks are used when finishing up a customization.
-(cl-defmethod eieio-done-customizing ((proj ede-project))
- "Call this when a user finishes customizing PROJ."
- (let ((ov ede-eieio-old-variables)
- (nv (oref proj local-variables)))
- (setq ede-eieio-old-variables nil)
- (while ov
- (if (not (assoc (car (car ov)) nv))
- (save-excursion
- (mapc (lambda (b)
- (set-buffer b)
- (kill-local-variable (car (car ov))))
- (ede-project-buffers proj))))
- (setq ov (cdr ov)))
- (mapc (lambda (b) (ede-set-project-variables proj b))
- (ede-project-buffers proj))))
-
-;; These two methods should be implemented by subclasses of
-;; project and targets in order to account for user specified
-;; changes.
-(cl-defmethod eieio-done-customizing ((_target ede-target))
- "Call this when a user finishes customizing TARGET."
- nil)
-
-(cl-defmethod ede-commit-project ((_proj ede-project))
- "Commit any change to PROJ to its file."
- nil
- )
-
-(provide 'ede/custom)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/custom"
-;; End:
-
-;;; ede/custom.el ends here
+++ /dev/null
-;;; ede/detect.el --- EDE project detection and file associations -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2014-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Project detection for EDE;
-;;
-;; Detection comes in multiple forms:
-;;
-;; `ede--detect-scan-directory-for-project' -
-;; Scan for a project via the file system.
-;; `ede-detect-directory-for-project' -
-;; Check our file cache for a project. If that fails, use
-;; the scan fcn above.
-
-;;; Code:
-
-(require 'ede/auto) ;; Autoload settings.
-
-;;; BASIC PROJECT SCAN
-;;
-(defun ede--detect-stop-scan-p (dir)
- "Return non-nil if we need to stop scanning upward in DIR."
- ;;(let ((stop
- (file-exists-p (expand-file-name ".ede_stop_scan" dir)))
-;;)
-;;(when stop
-;;(message "Stop Scan at %s" dir))
-;;stop))
-
-(defvar ede--detect-found-project nil
- "When searching for a project, temporarily save that file.")
-
-(defun ede--detect-ldf-predicate (dir)
- "Non-nil if DIR contain any known EDE project types."
- (if (ede--detect-stop-scan-p dir)
- (throw 'stopscan nil)
- (let ((types ede-project-class-files))
- ;; Loop over all types, loading in the first type that we find.
- (while (and types (not ede--detect-found-project))
- (if (ede-auto-detect-in-dir (car types) dir)
- (progn
- ;; We found one!
- (setq ede--detect-found-project (car types)))
- (setq types (cdr types)))
- )
- ede--detect-found-project)))
-
-(defun ede--detect-scan-directory-for-project (directory)
- "Detect an EDE project for the current DIRECTORY by scanning.
-This function ALWAYS scans files and directories and DOES NOT
-use any file caches.
-Return a cons cell:
- ( ROOTDIR . PROJECT-AUTOLOAD)"
- (let* ((ede--detect-found-project nil)
- (root
- (catch 'stopscan
- (locate-dominating-file directory
- 'ede--detect-ldf-predicate))))
- (when root
- (cons root ede--detect-found-project))))
-
-;;; Root Only project detect
-;;
-;; For projects that only have a detectable ROOT file, but may in fact
-;; contain a generic file such as a Makefile, we need to do a second scan
-;; to make sure we don't miss-match.
-(defun ede--detect-ldf-rootonly-predicate (dir)
- "Non-nil if DIR contain any known EDE project types."
- (if (ede--detect-stop-scan-p dir)
- (throw 'stopscan nil)
- (let ((types ede-project-class-files))
- ;; Loop over all types, loading in the first type that we find.
- (while (and types (not ede--detect-found-project))
- (if (and
- (oref (car types) root-only)
- (ede-auto-detect-in-dir (car types) dir))
- (progn
- ;; We found one!
- (setq ede--detect-found-project (car types)))
- (setq types (cdr types)))
- )
- ede--detect-found-project)))
-
-(defun ede--detect-scan-directory-for-rootonly-project (directory)
- "Detect an EDE project for the current DIRECTORY by scanning.
-This function ALWAYS scans files and directories and DOES NOT
-use any file caches.
-Return a cons cell:
- ( ROOTDIR . PROJECT-AUTOLOAD)"
- (let* ((ede--detect-found-project nil)
- (root
- (catch 'stopscan
- (locate-dominating-file directory
- 'ede--detect-ldf-rootonly-predicate))))
- (when root
- (cons root ede--detect-found-project))))
-
-
-;;; NESTED PROJECT SCAN
-;;
-;; For projects that can have their dominating file exist in all their
-;; sub-directories as well.
-
-(defvar ede--detect-nomatch-auto nil
- "An ede autoload that needs to be un-matched.")
-
-(defun ede--detect-ldf-root-predicate (dir)
- "Non-nil if DIR no longer match `ede--detect-nomatch-auto'."
- ;; `dir' may be "~/".
- (setq dir (expand-file-name dir))
- (or (ede--detect-stop-scan-p dir)
- ;; To know if DIR is at the top, we need to look just above
- ;; to see if there is a match.
- (let ((updir (file-name-directory (directory-file-name dir))))
- (if (equal updir dir)
- ;; If it didn't change, then obviously this must be the top.
- t
- ;; If it is different, check updir for the file.
- (not (ede-auto-detect-in-dir ede--detect-nomatch-auto updir))))))
-
-(defun ede--detect-scan-directory-for-project-root (directory auto)
- "If DIRECTORY has already been detected with AUTO, find the root.
-Some projects have their dominating file in all their directories, such
-as Project.ede. In that case we will detect quickly, but then need
-to scan upward to find the topmost occurrence of that file."
- (let* ((ede--detect-nomatch-auto auto)
- (root (locate-dominating-file directory
- 'ede--detect-ldf-root-predicate)))
- root))
-
-;;; TOP LEVEL SCAN
-;;
-;; This function for combining the above scans.
-(defun ede-detect-directory-for-project (directory)
- "Detect an EDE project for the current DIRECTORY.
-Scan the filesystem for a project.
-Return a cons cell:
- ( ROOTDIR . PROJECT-AUTOLOAD)"
- (let* ((scan (ede--detect-scan-directory-for-project directory))
- (root (car scan))
- (auto (cdr scan)))
- (when scan
- ;; If what we found is already a root-only project, return it.
- (if (oref auto root-only)
- scan
-
- ;; If what we found is a generic project, check to make sure we aren't
- ;; in some other kind of root project.
- (if (oref auto generic-p)
- (let ((moreroot (ede--detect-scan-directory-for-rootonly-project root)))
- ;; If we found a rootier project, return that.
- (if moreroot
- moreroot
-
- ;; If we didn't find a root from the generic project, then
- ;; we need to rescan upward.
- (cons (ede--detect-scan-directory-for-project-root root auto) auto)))
-
- ;; Non-generic non-root projects also need to rescan upward.
- (cons (ede--detect-scan-directory-for-project-root root auto) auto)))
-
- )))
-
-;;; TEST
-;;
-;; A quick interactive testing fcn.
-(defun ede-detect-qtest ()
- "Run a quick test for autodetecting on BUFFER."
- (interactive)
- (let ((start (current-time))
- (ans (ede-detect-directory-for-project default-directory)))
- (if ans
- (message "Project found in %d sec @ %s of type %s"
- (time-convert (time-since start) 'integer)
- (car ans)
- (eieio-object-name-string (cdr ans)))
- (message "No Project found.") )))
-
-
-(provide 'ede/detect)
-
-;;; ede/detect.el ends here
+++ /dev/null
-;;; ede/dired.el --- EDE extensions to dired. -*- lexical-binding: t -*-
-
-;; Copyright (C) 1998-2000, 2003, 2009-2024 Free Software Foundation,
-;; Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Old-Version: 0.4
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This provides a dired interface to EDE, allowing users to modify
-;; their project file by adding files (or whatever) directly from a
-;; dired buffer.
-
-;;; Code:
-
-(require 'dired)
-(require 'ede)
-
-(defvar ede-dired-keymap
- (let ((map (make-sparse-keymap)))
- (define-key map ".a" #'ede-dired-add-to-target)
- (define-key map ".t" #'ede-new-target)
- (define-key map ".s" #'ede-speedbar)
- (define-key map ".C" #'ede-compile-project)
- (define-key map ".d" #'ede-make-dist)
-
- (easy-menu-define
- ede-dired-menu map "EDE Dired Minor Mode Menu"
- '("Project"
- [ "Add files to target" ede-dired-add-to-target (ede-current-project) ]
- ( "Build" :filter ede-build-forms-menu)
- "-"
- [ "Create Project" ede-new (not (ede-current-project)) ]
- [ "Create Target" ede-new-target (ede-current-project) ]
- "-"
- ( "Customize Project" :filter ede-customize-forms-menu )
- [ "View Project Tree" ede-speedbar (ede-current-project) ]
- ))
- map)
- "Keymap used for ede dired minor mode.")
-
-;;;###autoload
-(define-minor-mode ede-dired-minor-mode
- "A minor mode that should only be activated in DIRED buffers."
- :lighter " EDE" :keymap ede-dired-keymap
- (unless (derived-mode-p 'dired-mode)
- (setq ede-dired-minor-mode nil)
- (error "Not in DIRED mode"))
- (unless (or (ede-directory-project-p default-directory)
- (called-interactively-p 'any))
- (setq ede-dired-minor-mode nil)))
-
-(defun ede-dired-add-to-target (target)
- "Add a file, or all marked files into a TARGET."
- (interactive (list
- (let ((ede-object (ede-current-project)))
- (ede-invoke-method 'project-interactive-select-target
- "Add files to Target: "))))
- (dolist (file (dired-get-marked-files t))
- (project-add-file target file)
- ;; Find the buffer for this files, and set its ede-object
- (if (get-file-buffer file)
- (with-current-buffer (get-file-buffer file)
- (setq ede-object nil)
- (setq ede-object (ede-buffer-object (current-buffer)))))))
-
-(provide 'ede/dired)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/dired"
-;; End:
-
-;;; ede/dired.el ends here
+++ /dev/null
-;;; ede/emacs.el --- Special project for Emacs -*- lexical-binding: t -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Provide a special project type just for Emacs, cause Emacs is special.
-;;
-;; Identifies an Emacs project automatically.
-;; Speedy ede-expand-filename based on extension.
-;; Pre-populates the preprocessor map from lisp.h
-;;
-;; ToDo :
-;; * Add "build" options.
-;; * Add texinfo lookup options.
-;; * Add website
-
-(require 'ede)
-(require 'semantic/db)
-
-;;; Code:
-
-;; @TODO - get rid of this. Stuck in loaddefs right now.
-
-(defun ede-emacs-project-root (&optional _dir)
- "Get the root directory for DIR."
- nil)
-
-(defun ede-emacs-version (dir)
- "Find the Emacs version for the Emacs src in DIR.
-Return a tuple of ( EMACSNAME . VERSION )."
- (let ((buff (get-buffer-create " *emacs-query*"))
- (configure_ac "configure.ac")
- (emacs "Emacs")
- (ver ""))
- (with-current-buffer buff
- (erase-buffer)
- (setq default-directory (file-name-as-directory dir))
- (cond
- ;; Vaguely recent version of GNU Emacs?
- ((or (file-exists-p configure_ac)
- (file-exists-p (setq configure_ac "configure.in")))
- (insert-file-contents configure_ac)
- (goto-char (point-min))
- (re-search-forward "AC_INIT(\\[?\\(?:GNU \\)?[eE]macs]?,\\s-*\\[?\\([0-9.]+\\)]?\\s-*[,)]")
- (setq ver (match-string 1))
- )
- )
- ;; Return a tuple
- (cons emacs ver))))
-
-(defclass ede-emacs-project (ede-project)
- (
- )
- "Project Type for the Emacs source code."
- :method-invocation-order :depth-first)
-
-(defun ede-emacs-load (dir &optional _rootproj)
- "Return an Emacs Project object if there is a match.
-Return nil if there isn't one.
-Argument DIR is the directory it is created for.
-ROOTPROJ is nil, since there is only one project."
- ;; Doesn't already exist, so let's make one.
- (let* ((vertuple (ede-emacs-version dir)))
- (ede-emacs-project
- :name (car vertuple)
- :version (cdr vertuple)
- :directory (file-name-as-directory dir)
- :file (expand-file-name "src/emacs.c"
- dir))))
-
-;;;###autoload
-(ede-add-project-autoload
- (make-instance 'ede-project-autoload
- :name "EMACS ROOT"
- :file 'ede/emacs
- :proj-file "src/emacs.c"
- :load-type 'ede-emacs-load
- :class-sym 'ede-emacs-project
- :new-p nil
- :safe-p t)
- 'unique)
-
-(defclass ede-emacs-target-c (ede-target)
- ()
- "EDE Emacs Project target for C code.
-All directories need at least one target.")
-
-(defclass ede-emacs-target-el (ede-target)
- ()
- "EDE Emacs Project target for Emacs Lisp code.
-All directories need at least one target.")
-
-(defclass ede-emacs-target-misc (ede-target)
- ()
- "EDE Emacs Project target for Misc files.
-All directories need at least one target.")
-
-(cl-defmethod initialize-instance ((this ede-emacs-project)
- &rest _fields)
- "Make sure the targets slot is bound."
- (cl-call-next-method)
- (unless (slot-boundp this 'targets)
- (oset this :targets nil)))
-
-;;; File Stuff
-;;
-(cl-defmethod ede-project-root-directory ((this ede-emacs-project)
- &optional _file)
- "Return the root for THIS Emacs project with file."
- (ede-up-directory (file-name-directory (oref this file))))
-
-(cl-defmethod ede-project-root ((this ede-emacs-project))
- "Return my root."
- this)
-
-(cl-defmethod ede-find-subproject-for-directory ((proj ede-emacs-project)
- _dir)
- "Return PROJ, for handling all subdirs below DIR."
- proj)
-
-;;; TARGET MANAGEMENT
-;;
-(defun ede-emacs-find-matching-target (class dir targets)
- "Find a target that is a CLASS and is in DIR in the list of TARGETS."
- (let ((match nil))
- (dolist (T targets)
- (when (and (object-of-class-p T class)
- (string= (oref T path) dir))
- (setq match T)
- ))
- match))
-
-(cl-defmethod ede-find-target ((proj ede-emacs-project) buffer)
- "Find an EDE target in PROJ for BUFFER.
-If one doesn't exist, create a new one for this directory."
- (let* ((ext (file-name-extension (buffer-file-name buffer)))
- (cls (cond ((not ext)
- 'ede-emacs-target-misc)
- ((string-match "c\\|h" ext)
- 'ede-emacs-target-c)
- ((string-match "elc?" ext)
- 'ede-emacs-target-el)
- (t 'ede-emacs-target-misc)))
- (targets (oref proj targets))
- (dir default-directory)
- (ans (ede-emacs-find-matching-target cls dir targets))
- )
- (when (not ans)
- (setq ans (make-instance
- cls
- :name (file-name-nondirectory
- (directory-file-name dir))
- :path dir
- :source nil))
- (object-add-to-list proj :targets ans)
- )
- ans))
-
-;;; UTILITIES SUPPORT.
-;;
-(cl-defmethod ede-preprocessor-map ((this ede-emacs-target-c))
- "Get the pre-processor map for Emacs C code.
-All files need the macros from lisp.h!"
- (require 'semantic/db)
- (let* ((proj (ede-target-parent this))
- (root (ede-project-root proj))
- (table (semanticdb-file-table-object
- (ede-expand-filename root "lisp.h")))
- (config (semanticdb-file-table-object
- (ede-expand-filename root "config.h")))
- filemap
- )
- (when table
- (when (semanticdb-needs-refresh-p table)
- (semanticdb-refresh-table table))
- (setq filemap (append filemap (oref table lexical-table)))
- )
- (when config
- (when (semanticdb-needs-refresh-p config)
- (semanticdb-refresh-table config))
- (setq filemap (append filemap (oref config lexical-table)))
- )
- filemap
- ))
-
-(defun ede-emacs-find-in-directories (name base dirs)
- "Find NAME is BASE directory sublist of DIRS."
- (let ((ans nil))
- (while (and dirs (not ans))
- (let* ((D (car dirs))
- (ed (expand-file-name D base))
- (ef (expand-file-name name ed)))
- (when (file-exists-p ed)
- (if (file-exists-p ef)
- (setq ans ef)
- ;; Not in this dir? How about subdirs?
- (let ((dirfile (directory-files ed t))
- (moredirs nil))
- ;; Get all the subdirs.
- (dolist (DF dirfile)
- (when (and (file-directory-p DF)
- (not (string-match "\\.$" DF)))
- (push DF moredirs)))
- ;; Try again.
- (setq ans (ede-emacs-find-in-directories name ed moredirs)))))
- (setq dirs (cdr dirs))))
- ans))
-
-(cl-defmethod ede-expand-filename-impl ((proj ede-emacs-project) name)
- "Within this project PROJ, find the file NAME.
-Knows about how the Emacs source tree is organized."
- (let* ((ext (file-name-extension name))
- (root (ede-project-root proj))
- (dir (ede-project-root-directory root))
- (dirs (cond
- ((not ext) nil)
- ((string-match "h\\|c" ext)
- '("src" "lib-src" "lwlib"))
- ((string-match "elc?" ext)
- '("lisp"))
- ((string-match "texi" ext)
- '("doc"))
- (t nil)))
- )
- (if (not dirs) (cl-call-next-method)
- (ede-emacs-find-in-directories name dir dirs))
- ))
-
-;;; Command Support
-;;
-(cl-defmethod project-rescan ((this ede-emacs-project))
- "Rescan this Emacs project from the sources."
- (let ((ver (ede-emacs-version (ede-project-root-directory this))))
- (oset this name (car ver))
- (oset this version (cdr ver))
- ))
-
-(provide 'ede/emacs)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/emacs"
-;; End:
-
-;;; ede/emacs.el ends here
+++ /dev/null
-;;; ede/files.el --- Associate projects with files and directories. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Directory and File scanning and matching functions.
-;;
-;; Basic Model:
-;;
-;; A directory belongs to a project if an ede-project-autoload structure
-;; matches your directory.
-;;
-;; A toplevel project is one where there is no active project above
-;; it. Finding the toplevel project involves going up a directory
-;; till no ede-project-autoload structure matches.
-;;
-
-(require 'eieio)
-(require 'ede)
-
-(declare-function ede-locate-file-in-hash "ede/locate")
-(declare-function ede-locate-add-file-to-hash "ede/locate")
-(declare-function ede-locate-file-in-project "ede/locate")
-(declare-function ede-locate-flush-hash "ede/locate")
-
-(defvar ede--disable-inode nil
- "Set to t to simulate systems w/out inode support.")
-
-;;; Code:
-;;;###autoload
-(defun ede-find-file (file)
- "Find FILE in project. FILE can be specified without a directory.
-There is no completion at the prompt. FILE is searched for within
-the current EDE project."
- (interactive "sFile: ")
- (let* ((proj (ede-current-project))
- (fname (ede-expand-filename proj file))
- )
- (unless fname
- (error "Could not find %s in %s"
- file
- (ede-project-root-directory proj)))
- (find-file fname)))
-
-(defun ede-flush-project-hash ()
- "Flush the file locate hash for the current project."
- (interactive)
- (require 'ede/locate)
- (let* ((loc (ede-get-locator-object (ede-current-project))))
- (when loc
- (ede-locate-flush-hash loc))))
-
-;;; Placeholders for ROOT directory scanning on base objects
-;;
-(cl-defmethod ede-project-root ((this ede-project-placeholder))
- "If a project knows its root, return it here.
-Allows for one-project-object-for-a-tree type systems."
- (oref this rootproject))
-
-(cl-defmethod ede-project-root-directory ((this ede-project-placeholder)
- &optional _file)
- "If a project knows its root, return it here.
-Allows for one-project-object-for-a-tree type systems.
-Optional FILE is the file to test. It is ignored in preference
-of the anchor file for the project."
- ;; (let ((root (or (ede-project-root this) this)))
- (file-name-directory (expand-file-name (oref this file)))) ;; )
-
-
-;; Why INODEs?
-;; An inode represents a unique ID that transcends symlinks, hardlinks, etc.
-;; so when we cache an inode in a project, and hash directories to inodes, we
-;; can avoid costly filesystem queries and regex matches.
-
-(defvar ede-inode-directory-hash (make-hash-table
- ;; Note on test. Can we compare inodes or something?
- :test 'equal)
- "A hash of directory names and inodes.")
-
-(defun ede--put-inode-dir-hash (dir inode)
- "Add to the EDE project hash DIR associated with INODE."
- (puthash dir inode ede-inode-directory-hash)
- inode)
-
-(defun ede--get-inode-dir-hash (dir)
- "Get the EDE project hash DIR associated with INODE."
- (gethash dir ede-inode-directory-hash))
-
-(defun ede--inode-for-dir (dir)
- "Return the inode for the directory DIR."
- (let ((hashnode (ede--get-inode-dir-hash (expand-file-name dir))))
- (or hashnode
- (if ede--disable-inode
- (ede--put-inode-dir-hash dir 0)
- (let ((fattr (file-attributes dir)))
- (ede--put-inode-dir-hash dir (file-attribute-inode-number fattr))
- )))))
-
-(cl-defmethod ede--project-inode ((proj ede-project-placeholder))
- "Get the inode of the directory project PROJ is in."
- (if (slot-boundp proj 'dirinode)
- (oref proj dirinode)
- (oset proj dirinode (ede--inode-for-dir (oref proj directory)))))
-
-(defun ede--inode-get-toplevel-open-project (inode)
- "Return an already open toplevel project that is managing INODE.
-Does not check subprojects."
- (when (or (and (numberp inode) (/= inode 0))
- (consp inode))
- (let ((all ede-projects)
- (found nil)
- )
- (while (and all (not found))
- (when (equal inode (ede--project-inode (car all)))
- (setq found (car all)))
- (setq all (cdr all)))
- found)))
-
-;;; DIRECTORY IN OPEN PROJECT
-;;
-;; These routines match some directory name to one of the many pre-existing
-;; open projects. This should avoid hitting the disk, or asking lots of questions
-;; if used throughout the other routines.
-
-(defun ede-directory-get-open-project (dir &optional rootreturn)
- "Return an already open project that is managing DIR.
-Optional ROOTRETURN specifies a `gv-ref' to set to the root project.
-If DIR is the root project, then it is the same."
- (let* ((inode (ede--inode-for-dir dir))
- (ft (file-name-as-directory (expand-file-name dir)))
- (proj (ede--inode-get-toplevel-open-project inode))
- (ans nil))
- ;; Try file based search.
- (when (or ede--disable-inode (not proj))
- (setq proj (ede-directory-get-toplevel-open-project ft)))
- ;; Default answer is this project
- (setq ans proj)
- ;; Save.
- (when rootreturn (if (symbolp rootreturn) (set rootreturn proj)
- (setf (gv-deref rootreturn) proj)))
- ;; Find subprojects.
- (when (and proj (if ede--disable-inode
- (not (string= ft (expand-file-name
- (oref proj directory))))
- (not (equal inode (ede--project-inode proj)))))
- (setq ans (ede-find-subproject-for-directory proj ft)))
- ans))
-
-;; Force all users to switch to `ede-directory-get-open-project'
-;; for performance reasons.
-(defun ede-directory-get-toplevel-open-project (dir &optional exact)
- "Return an already open toplevel project that is managing DIR.
-If optional EXACT is non-nil, only return exact matches for DIR."
- (let ((ft (file-name-as-directory (expand-file-name dir)))
- (all ede-projects)
- (ans nil)
- (shortans nil))
- (while (and all (not ans))
- ;; Do the check.
- (let ((pd (expand-file-name (oref (car all) directory))))
- (cond
- ;; Exact text match.
- ((string= pd ft)
- (setq ans (car all)))
- ;; Some sub-directory
- ((and (not exact) (string-match (concat "^" (regexp-quote pd)) ft))
- (if (not shortans)
- (setq shortans (car all))
- ;; We already have a short answer, so see if pd (the match we found)
- ;; is longer. If it is longer, then it is more precise.
- (when (< (length (oref shortans directory))
- (length pd))
- (setq shortans (car all))))
- )
- ;; Exact inode match. Useful with symlinks or complex automounters.
- ((and (not ede--disable-inode)
- (let ((pin (ede--project-inode (car all)))
- (inode (ede--inode-for-dir dir)))
- (and (not (eql pin 0)) (equal pin inode))))
- (setq ans (car all)))
- ;; Subdir via truename - slower by far, but faster than a traditional lookup.
- ;; Note that we must resort to truename in order to resolve issues such as
- ;; cross-symlink projects.
- ((and (not exact)
- (let ((ftn (file-truename ft))
- (ptd (file-truename pd)))
- (string-match (concat "^" (regexp-quote ptd)) ftn)))
- (if (not shortans)
- (setq shortans (car all))
- ;; We already have a short answer, so see if pd (the match we found)
- ;; is longer. If it is longer, then it is more precise.
- (when (< (length (expand-file-name (oref shortans directory)))
- (length pd))
- (setq shortans (car all))))
- )))
- (setq all (cdr all)))
- ;; If we have an exact answer, use that, otherwise use
- ;; the short answer we found -> ie - we are in a subproject.
- (or ans shortans)))
-
-(cl-defmethod ede-find-subproject-for-directory ((proj ede-project-placeholder)
- dir)
- "Find a subproject of PROJ that corresponds to DIR."
- (if ede--disable-inode
- (let ((ans nil)
- (fulldir (file-truename dir)))
- ;; Try to find the right project w/out inodes.
- (ede-map-subprojects
- proj
- (lambda (SP)
- (when (not ans)
- (if (string= fulldir (file-truename (oref SP directory)))
- (setq ans SP)
- (ede-find-subproject-for-directory SP dir)))))
- ans)
- ;; We can use inodes, so let's try it.
- (let ((ans nil)
- (inode (ede--inode-for-dir dir)))
- (ede-map-subprojects
- proj
- (lambda (SP)
- (when (not ans)
- (if (equal (ede--project-inode SP) inode)
- (setq ans SP)
- (setq ans (ede-find-subproject-for-directory SP dir))))))
- ans)))
-
-;;; DIRECTORY HASH
-;;
-;; The directory hash matches expanded directory names to already detected
-;; projects. By hashing projects to directories, we can detect projects in
-;; places we have been before much more quickly.
-
-(defvar ede-project-directory-hash (make-hash-table
- ;; Note on test. Can we compare inodes or something?
- :test 'equal)
- "A hash of directory names and associated EDE objects.")
-
-(defun ede-flush-directory-hash ()
- "Flush the project directory hash.
-Do this only when developing new projects that are incorrectly putting
-`nomatch' tokens into the hash."
- (interactive)
- (setq ede-project-directory-hash (make-hash-table :test 'equal))
- ;; Also slush the current project's locator hash.
- (let ((loc (ede-get-locator-object ede-object)))
- (when loc
- (ede-locate-flush-hash loc)))
- )
-
-(defun ede-project-directory-remove-hash (dir)
- "Reset the directory hash for DIR.
-Do this whenever a new project is created, as opposed to loaded."
- ;; TODO - Use maphash, and delete by regexp, not by dir searching!
- (setq dir (expand-file-name dir))
- (remhash (file-name-as-directory dir) ede-project-directory-hash)
- ;; Look for all subdirs of D, and remove them.
- (let ((match (concat "^" (regexp-quote dir))))
- (maphash (lambda (K _O)
- (when (string-match match K)
- (remhash K ede-project-directory-hash)))
- ede-project-directory-hash)))
-
-(defun ede--directory-project-from-hash (dir)
- "If there is an already loaded project for DIR, return it from the hash."
- (setq dir (expand-file-name dir))
- (gethash dir ede-project-directory-hash nil))
-
-(defun ede--directory-project-add-description-to-hash (dir desc)
- "Add to the EDE project hash DIR associated with DESC."
- (setq dir (expand-file-name dir))
- (puthash dir desc ede-project-directory-hash)
- desc)
-
-;;; DIRECTORY-PROJECT-P, -CONS
-;;
-;; These routines are useful for detecting if a project exists
-;; in a provided directory.
-;;
-;; Note that -P provides less information than -CONS, so use -CONS
-;; instead so that -P can be obsoleted.
-(defun ede-directory-project-p (dir &optional force)
- "Return a project description object if DIR is in a project.
-Optional argument FORCE means to ignore a hash-hit of `nomatch'.
-This depends on an up to date `ede-project-class-files' variable.
-Any directory that contains the file .ede-ignore will always
-return nil.
-
-Consider using `ede-directory-project-cons' instead if the next
-question you want to ask is where the root of found project is."
- ;; @TODO - We used to have a full impl here, but moved it all
- ;; to ede-directory-project-cons, and now hash contains only
- ;; the results of detection which includes the root dir.
- ;; Perhaps we can eventually remove this fcn?
- (let ((detect (ede-directory-project-cons dir force)))
- (cdr detect)))
-
-(defun ede-directory-project-cons (dir &optional force)
- "Return a project CONS (ROOTDIR . AUTOLOAD) for DIR.
-If there is no project in DIR, return nil.
-Optional FORCE means to ignore the hash of known directories."
- (when (not (file-exists-p (expand-file-name ".ede-ignore" dir)))
- (let* ((dirtest (expand-file-name dir))
- (match (ede--directory-project-from-hash dirtest)))
- (cond
- ((and (eq match 'nomatch) (not force))
- nil)
- ((and match (not (eq match 'nomatch)))
- match)
- (t
- ;; First time here? Use the detection code to identify if we have
- ;; a project here.
- (let* ((detect (ede-detect-directory-for-project dirtest))
- (autoloader (cdr detect))) ;; autoloader
- (when autoloader (require (oref autoloader file)))
- (ede--directory-project-add-description-to-hash dirtest (or detect 'nomatch))
- detect)
- )))))
-
-
-;;; TOPLEVEL
-;;
-;; These utilities will identify the "toplevel" of a project.
-;;
-;; NOTE: This -toplevel- function returns a directory even though
-;; the function name implies a project.
-
-(defun ede-toplevel-project (dir)
- "Starting with DIR, find the toplevel project directory.
-If DIR is not part of a project, return nil."
- (let ((ans nil))
-
- (cond
- ;; Check if it is cached in the current buffer.
- ((and (string= dir default-directory)
- ede-object-root-project)
- ;; Try the local buffer cache first.
- (oref ede-object-root-project directory))
-
- ;; See if there is an existing project in DIR.
- ((setq ans (ede-directory-get-toplevel-open-project dir))
- (oref ans directory))
-
- ;; Detect using our file system detector.
- ((setq ans (ede-detect-directory-for-project dir))
- (car ans))
-
- (t nil))))
-
-;;; DIRECTORY CONVERSION STUFF
-;;
-(cl-defmethod ede-convert-path ((this ede-project) path)
- "Convert path in a standard way for a given project.
-Default to making it project relative.
-Argument THIS is the project to convert PATH to."
- (let ((pp (ede-project-root-directory this))
- (fp (expand-file-name path)))
- (if (string-match (regexp-quote pp) fp)
- (substring fp (match-end 0))
- (let ((pptf (file-truename pp))
- (fptf (file-truename fp)))
- (if (string-match (regexp-quote pptf) fptf)
- (substring fptf (match-end 0))
- (error "Cannot convert relativize path %s" fp))))))
-
-(cl-defmethod ede-convert-path ((this ede-target) path &optional project)
- "Convert path in a standard way for a given project.
-Default to making it project relative.
-Argument THIS is the project to convert PATH to.
-Optional PROJECT is the project that THIS belongs to. Associating
-a target to a project is expensive, so using this can speed things up."
- (let ((proj (or project (ede-target-parent this))))
- (if proj
- (let ((p (ede-convert-path proj path))
- (lp (or (oref this path) "")))
- ;; Our target THIS may have path information.
- ;; strip this out of the conversion.
- (if (string-match (concat "^" (regexp-quote lp)) p)
- (substring p (length lp))
- p))
- (error "Parentless target %s" this))))
-
-;;; FILENAME EXPANSION
-;;
-(defun ede-get-locator-object (proj)
- "Get the locator object for project PROJ.
-Get it from the toplevel project. If it doesn't have one, make one."
- ;; Make sure we have a location object available for
- ;; caching values, and for locating things more robustly.
- (let ((top (ede-toplevel proj)))
- (when top
- (when (not (slot-boundp top 'locate-obj))
- (ede-enable-locate-on-project top))
- (oref top locate-obj)
- )))
-
-(cl-defmethod ede-expand-filename ((this ede-project) filename &optional force)
- "Return a fully qualified file name based on project THIS.
-FILENAME should be just a filename which occurs in a directory controlled
-by this project.
-Optional argument FORCE forces the default filename to be provided even if it
-doesn't exist.
-If FORCE equals `newfile', then the cache is ignored and a new file in THIS
-is returned."
- (require 'ede/locate)
- (let* ((loc (ede-get-locator-object this))
- (ha (ede-locate-file-in-hash loc filename))
- (ans nil)
- )
- ;; NOTE: This function uses a locator object, which keeps a hash
- ;; table of files it has found in the past. The hash table is
- ;; used to make commonly found file very fast to location. Some
- ;; complex routines, such as smart completion asks this question
- ;; many times, so doing this speeds things up, especially on NFS
- ;; or other remote file systems.
-
- ;; As such, special care is needed to use the hash, and also obey
- ;; the FORCE option, which is needed when trying to identify some
- ;; new file that needs to be created, such as a Makefile.
- (cond
- ;; We have a hash-table match, AND that match wasn't the 'nomatch
- ;; flag, we can return it.
- ((and ha (not (eq ha 'nomatch)))
- (setq ans ha))
- ;; If we had a match, and it WAS no match, then we need to look
- ;; at the force-option to see what to do. Since ans is already
- ;; nil, then we do nothing.
- ((and (eq ha 'nomatch) (not (eq force 'newfile)))
- nil)
- ;; We had no hash table match, so we have to look up this file
- ;; using the usual EDE file expansion rules.
- (t
- (let ((calc (ede-expand-filename-impl this filename)))
- (if calc
- (progn
- (ede-locate-add-file-to-hash loc filename calc)
- (setq ans calc))
- ;; If we failed to calculate something, we
- ;; should add it to the hash, but ONLY if we are not
- ;; going to FORCE the file into existence.
- (when (not force)
- (ede-locate-add-file-to-hash loc filename 'nomatch))))
- ))
- ;; Now that all options have been queried, if the FORCE option is
- ;; true, but ANS is still nil, then we can make up a file name.
-
- ;; Is it forced?
- (when (and force (not ans))
- (let ((dir (ede-project-root-directory this)))
- (setq ans (expand-file-name filename dir))))
-
- ans))
-
-(cl-defmethod ede-expand-filename-impl ((this ede-project) filename &optional _force)
- "Return a fully qualified file name based on project THIS.
-FILENAME should be just a filename which occurs in a directory controlled
-by this project.
-Optional argument FORCE forces the default filename to be provided even if it
-doesn't exist."
- (let ((loc (ede-get-locator-object this))
- ;; (path (ede-project-root-directory this))
- ;; (proj (oref this subproj))
- (found nil))
- ;; find it Locally.
- (setq found (or (ede-expand-filename-local this filename)
- (ede-expand-filename-impl-via-subproj this filename)))
- ;; Use an external locate tool.
- (when (not found)
- (require 'ede/locate)
- (setq found (car (ede-locate-file-in-project loc filename))))
- ;; Return it
- found))
-
-(cl-defmethod ede-expand-filename-local ((this ede-project) filename)
- "Expand filename locally to project THIS with filesystem tests."
- (let ((path (ede-project-root-directory this)))
- (cond ((file-exists-p (expand-file-name filename path))
- (expand-file-name filename path))
- ((file-exists-p (expand-file-name (concat "include/" filename) path))
- (expand-file-name (concat "include/" filename) path)))))
-
-(cl-defmethod ede-expand-filename-impl-via-subproj ((this ede-project) filename)
- "Return a fully qualified file name based on project THIS.
-FILENAME should be just a filename which occurs in a directory controlled
-by this project."
- (let ((proj (list (ede-toplevel this)))
- (found nil))
- ;; find it Locally.
- (while (and (not found) proj)
- (let ((thisproj (car proj)))
- (setq proj (append (cdr proj) (oref thisproj subproj)))
- (setq found (when thisproj
- (ede-expand-filename-local thisproj filename)))
- ))
- ;; Return it
- found))
-
-(cl-defmethod ede-expand-filename ((this ede-target) filename &optional force)
- "Return a fully qualified file name based on target THIS.
-FILENAME should be a filename which occurs in a directory in which THIS works.
-Optional argument FORCE forces the default filename to be provided even if it
-doesn't exist."
- (ede-expand-filename (ede-target-parent this) filename force))
-
-;;; UTILITIES
-;;
-
-(defun ede-up-directory (dir)
- "Return a dir that is up one directory.
-Argument DIR is the directory to trim upwards."
- (let* ((fad (directory-file-name dir))
- (fnd (file-name-directory fad)))
- (if (string= dir fnd) ; This will catch the old string-match against
- ; c:/ for DOS like systems.
- nil
- fnd)))
-
-(define-obsolete-function-alias 'ede-toplevel-project-or-nil #'ede-toplevel-project "29.1")
-
-(provide 'ede/files)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/files"
-;; End:
-
-;;; ede/files.el ends here
+++ /dev/null
-;;; ede/generic.el --- Base Support for generic build systems -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2010-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; There are a lot of build systems out there, and EDE can't support
-;; them all fully. The ede/generic.el system is the base for
-;; supporting alternate build systems in a simple way, automatically.
-;;
-;; The structure is for the ede-generic baseclass, which is augmented
-;; by simple sub-classes that can be created by users on an as needed
-;; basis. The generic system will have targets for many language
-;; types, and create the targets on an as needed basis. All
-;; sub-project types will recycle the same generic target types.
-;;
-;; The generic target types will only be implemented for languages
-;; where having EDE support actually matters, with a single MISC to
-;; represent anything else.
-;;
-;; TOO MANY PROJECTS DETECTED:
-;;
-;; If enabling ede-generic support starts identifying too many
-;; projects, drop a file called `.ede-ignore' into any directory where
-;; you do not want a project to be.
-;;
-;; Customization:
-;;
-;; Since these projects are all so incredibly generic, a user will
-;; need to configure some aspects of the project by hand. In order to
-;; enable this without configuring the project objects directly (which
-;; are auto-generated) a special ede-generic-config object is defined to
-;; hold the basics. Generic projects will identify and use these
-;; config files.
-;;
-;; Adding support for new projects:
-;;
-;; To add support to EDE Generic for new project types is very quick.
-;; See the end of this file for examples such as CMake and SCons.
-;;
-;; Support consists of one class for your project, specifying the file
-;; name used by the project system you want to support. It also
-;; should implement th method `ede-generic-setup-configuration' to
-;; prepopulate the configurable portion of the generic project with
-;; build details.
-;;
-;; Lastly, call `ede-generic-new-autoloader' to setup your project so
-;; EDE can use it.
-;;
-;; Adding support for new types of source code:
-;;
-;; Sources of different types are supported with a simple class which
-;; subclasses `ede-generic-target'. The slots `shortname' and
-;; `extension' should be given new initial values.
-;;
-;; Optionally, any target method used by EDE can then be overridden.
-;; The ede-generic-target-c-cpp has some example methods setting up
-;; the pre-processor map and system include path.
-;;
-;; NOTE: It is not necessary to modify ede/generic.el to add any of
-;; the above described support features.
-
-(require 'eieio-opt)
-(require 'ede/config)
-(require 'ede/shell)
-(require 'semantic/db)
-
-;;; Code:
-;;
-;; Start with the configuration system
-(defclass ede-generic-config (ede-extra-config
- ede-extra-config-build
- ede-extra-config-program
- ede-extra-config-c)
- ((file-header-line :initform ";; EDE Generic Project Configuration")
- )
- "User Configuration object for a generic project.")
-
-(defun ede-generic-load (dir &optional _rootproj)
- "Return a Generic Project object if there is a match.
-Return nil if there isn't one.
-Argument DIR is the directory it is created for.
-ROOTPROJ is nil, since there is only one project."
- ;; Doesn't already exist, so let's make one.
- (let* ((alobj ede-constructing))
- (when (not alobj) (error "Cannot load generic project without the autoload instance"))
- ;;;
- ;; TODO - find the root dir.
- (let ((rootdir dir))
- (funcall (oref alobj class-sym)
- (symbol-name (oref alobj class-sym))
- :name (file-name-nondirectory (directory-file-name dir))
- :version "1.0"
- :directory (file-name-as-directory rootdir)
- :file (expand-file-name (oref alobj proj-file)
- rootdir)))
- ))
-
-;;; Base Classes for the system
-(defclass ede-generic-target (ede-target-with-config
- ede-target-with-config-build
- ede-target-with-config-program)
- ((shortname :initform ""
- :type string
- :allocation :class
- :documentation
- "Something prepended to the target name.")
- (extension :initform ""
- :type string
- :allocation :class
- :documentation
- "Regular expression representing the extension used for this target.
-subclasses of this base target will override the default value.")
- )
- "Baseclass for all targets belonging to the generic ede system."
- :abstract t)
-
-(defclass ede-generic-project (ede-project-with-config
- ede-project-with-config-build
- ede-project-with-config-program
- ede-project-with-config-c
- ede-project-with-config-java)
- ((config-class :initform 'ede-generic-config)
- (config-file-basename :initform "EDEConfig.el")
- (buildfile :initform ""
- :type string
- :allocation :class
- :documentation "The file name that identifies a project of this type.
-The class allocated value is replace by different sub classes.")
- )
- "The baseclass for all generic EDE project types."
- :abstract t)
-
-(cl-defmethod initialize-instance ((this ede-generic-project)
- &rest _fields)
- "Make sure the targets slot is bound."
- (cl-call-next-method)
- (unless (slot-boundp this 'targets)
- (oset this :targets nil))
- )
-
-(cl-defmethod ede-project-root ((this ede-generic-project))
- "Return my root."
- this)
-
-(cl-defmethod ede-find-subproject-for-directory ((proj ede-generic-project)
- _dir)
- "Return PROJ, for handling all subdirs below DIR."
- proj)
-
-;;; A list of different targets
-(defclass ede-generic-target-c-cpp (ede-generic-target
- ede-target-with-config-c)
- ((shortname :initform "C/C++")
- (extension :initform "\\([ch]\\(pp\\|xx\\|\\+\\+\\)?\\|cc\\|hh\\|CC?\\)"))
- "EDE Generic Project target for C and C++ code.
-All directories need at least one target.")
-
-(defclass ede-generic-target-el (ede-generic-target)
- ((shortname :initform "ELisp")
- (extension :initform "el"))
- "EDE Generic Project target for Emacs Lisp code.
-All directories need at least one target.")
-
-(defclass ede-generic-target-fortran (ede-generic-target)
- ((shortname :initform "Fortran")
- (extension :initform "[fF]9[05]\\|[fF]\\|for"))
- "EDE Generic Project target for Fortran code.
-All directories need at least one target.")
-
-(defclass ede-generic-target-texi (ede-generic-target)
- ((shortname :initform "Texinfo")
- (extension :initform "texi"))
- "EDE Generic Project target for texinfo code.
-All directories need at least one target.")
-
-(defclass ede-generic-target-java (ede-generic-target
- ede-target-with-config-java)
- ((shortname :initform "Java")
- (extension :initform "java"))
- "EDE Generic Project target for texinfo code.
-All directories need at least one target.")
-
-;; MISC must always be last since it will always match the file.
-(defclass ede-generic-target-misc (ede-generic-target)
- ((shortname :initform "Misc")
- (extension :initform ""))
- "EDE Generic Project target for Misc files.
-All directories need at least one target.")
-
-;;; Automatic target acquisition.
-(defun ede-generic-find-matching-target (class dir targets)
- "Find a target that is a CLASS and is in DIR in the list of TARGETS."
- (let ((match nil))
- (dolist (T targets)
- (when (and (object-of-class-p T class)
- (string= (oref T path) dir))
- (setq match T)
- ))
- match))
-
-(cl-defmethod ede-find-target ((proj ede-generic-project) buffer)
- "Find an EDE target in PROJ for BUFFER.
-If one doesn't exist, create a new one for this directory."
- (let* ((ext (file-name-extension (buffer-file-name buffer)))
- (classes (eieio-build-class-alist 'ede-generic-target t))
- (cls nil)
- (targets (oref proj targets))
- (dir default-directory)
- (ans nil)
- )
- ;; Pick a matching class type.
- (when ext
- (dolist (C classes)
- (let* ((classsym (intern (car C)))
- (extreg (oref-default classsym extension)))
- (when (and (not (string= extreg ""))
- (string-match (concat "\\`\\(?:" extreg "\\)\\'") ext))
- (setq cls classsym)))))
- (when (not cls) (setq cls 'ede-generic-target-misc))
- ;; find a pre-existing matching target
- (setq ans (ede-generic-find-matching-target cls dir targets))
- ;; Create a new instance if there wasn't one
- (when (not ans)
- (setq ans (make-instance
- cls
- :name (oref-default cls shortname)
- :path dir
- :source nil))
- (object-add-to-list proj :targets ans)
- )
- ans))
-
-;;; Creating Derived Projects:
-;;
-;; Derived projects need an autoloader so that EDE can find the
-;; different projects on disk.
-(defun ede-generic-new-autoloader (_internal-name external-name
- projectfile class)
- "Add a new EDE Autoload instance for identifying a generic project.
-INTERNAL-NAME is obsolete and ignored.
-EXTERNAL-NAME is a human readable name to describe the project; it
-must be unique among all autoloaded projects.
-PROJECTFILE is a file name that identifies a project of this type to EDE, such
-as a Makefile, or SConstruct file.
-CLASS is the EIEIO class that is used to track this project. It should subclass
-`ede-generic-project'."
- (ede-add-project-autoload
- (ede-project-autoload :name external-name
- :file 'ede/generic
- :proj-file projectfile
- :root-only nil
- :load-type 'ede-generic-load
- :class-sym class
- :new-p nil
- ;; NOTE: This project type is SAFE because it handles
- ;; the user-query before loading its config file. These
- ;; project types are useful without the config file so
- ;; do the safe part until the user creates a saved config
- ;; file for it.
- :safe-p t)
- ;; Generics must go at the end, since more specific types
- ;; can create Makefiles also.
- 'generic))
-
-;;;###autoload
-(defun ede-enable-generic-projects ()
- "Enable generic project loaders."
- (interactive)
- (ede-generic-new-autoloader "generic-makefile" "Generic Make"
- "Makefile" 'ede-generic-makefile-project)
- (ede-generic-new-autoloader "generic-scons" "Generic SCons"
- "SConstruct" 'ede-generic-scons-project)
- (ede-generic-new-autoloader "generic-cmake" "Generic CMake"
- "CMakeLists" 'ede-generic-cmake-project)
-
- ;; Super Generic found via revision control tags.
- (ede-generic-new-autoloader "generic-git" "Generic Git"
- ".git" 'ede-generic-vc-project)
- (ede-generic-new-autoloader "generic-bzr" "Generic Bazaar"
- ".bzr" 'ede-generic-vc-project)
- (ede-generic-new-autoloader "generic-hg" "Generic Mercurial"
- ".hg" 'ede-generic-vc-project)
- (ede-generic-new-autoloader "generic-svn" "Generic Subversions"
- ".svn" 'ede-generic-vc-project)
- (ede-generic-new-autoloader "generic-cvs" "Generic CVS"
- "CVS" 'ede-generic-vc-project)
- (ede-generic-new-autoloader "generic-mtn" "Generic Monotone"
- "_MTN" 'ede-generic-vc-project)
-
- ;; Take advantage of existing 'projectile' based projects.
- ;; @TODO - if projectile supports compile commands etc, can we
- ;; read that out? Howto if projectile is not part of core emacs.
- (ede-generic-new-autoloader "generic-projectile" "Generic .projectile"
- ".projectile" 'ede-generic-vc-project)
-
- )
-
-\f
-;;; SPECIFIC TYPES OF GENERIC BUILDS
-;;
-
-;;; MAKEFILE
-
-(defclass ede-generic-makefile-project (ede-generic-project)
- ((buildfile :initform "Makefile")
- )
- "Generic Project for makefiles.")
-
-(cl-defmethod ede-generic-setup-configuration ((_proj ede-generic-makefile-project) config)
- "Setup a configuration for Make."
- (oset config build-command "make -k")
- (oset config debug-command "gdb ")
- )
-
-
-;;; SCONS
-(defclass ede-generic-scons-project (ede-generic-project)
- ((buildfile :initform "SConstruct")
- )
- "Generic Project for scons.")
-
-(cl-defmethod ede-generic-setup-configuration ((_proj ede-generic-scons-project) config)
- "Setup a configuration for SCONS."
- (oset config build-command "scons")
- (oset config debug-command "gdb ")
- )
-
-
-;;; CMAKE
-(defclass ede-generic-cmake-project (ede-generic-project)
- ((buildfile :initform "CMakeLists")
- )
- "Generic Project for cmake.")
-
-(cl-defmethod ede-generic-setup-configuration ((_proj ede-generic-cmake-project) config)
- "Setup a configuration for CMake."
- (oset config build-command "cmake")
- (oset config debug-command "gdb ")
- )
-
-;;; Generic Version Control System
-(defclass ede-generic-vc-project (ede-generic-project)
- ()
- "Generic project found via Version Control files.")
-
-(cl-defmethod ede-generic-setup-configuration ((_proj ede-generic-vc-project) _config)
- "Setup a configuration for projects identified by revision control."
- nil)
-
-(provide 'ede/generic)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/generic"
-;; End:
-
-;;; ede/generic.el ends here
+++ /dev/null
-;;; ede/linux.el --- Special project for Linux -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Provide a special project type just for Linux, cause Linux is special.
-;;
-;; Identifies a Linux project automatically.
-;; Speedy ede-expand-filename based on extension.
-;; Pre-populates the preprocessor map from lisp.h
-;;
-;; ToDo :
-;; * Add "build" options.
-;; * Add texinfo lookup options.
-;; * Add website
-
-(require 'ede)
-(require 'ede/make)
-(require 'semantic/db)
-(eval-when-compile (require 'cl-lib))
-
-;;; Code:
-(defgroup project-linux nil
- "File and tag browser frame."
- :group 'tools
- :group 'ede
- :version "24.3")
-
-(defcustom project-linux-build-directory-default 'ask
- "Build directory."
- :version "24.4"
- :type '(choice (const :tag "Same as source directory" same)
- (const :tag "Ask the user" ask)))
-
-(defcustom project-linux-architecture-default 'ask
- "Target architecture to assume when not auto-detected."
- :version "24.4"
- :type '(choice (string :tag "Architecture name")
- (const :tag "Ask the user" ask)))
-
-
-(defcustom project-linux-compile-target-command (concat ede-make-command " -k -C %s SUBDIRS=%s")
- "Default command used to compile a target."
- :type 'string)
-
-(defcustom project-linux-compile-project-command (concat ede-make-command " -k -C %s")
- "Default command used to compile a project."
- :type 'string)
-
-(defun ede-linux-version (dir)
- "Find the Linux version for the Linux src in DIR."
- (let ((buff (get-buffer-create " *linux-query*")))
- (with-current-buffer buff
- (erase-buffer)
- (setq default-directory (file-name-as-directory dir))
- (insert-file-contents "Makefile" nil 0 512)
- (goto-char (point-min))
- (let (major minor sub)
- (re-search-forward "^VERSION *= *\\([0-9.]+\\)")
- (setq major (match-string 1))
- (re-search-forward "^PATCHLEVEL *= *\\([0-9.]+\\)")
- (setq minor (match-string 1))
- (re-search-forward "^SUBLEVEL *= *\\([0-9.]+\\)")
- (setq sub (match-string 1))
- (prog1
- (concat major "." minor "." sub)
- (kill-buffer buff)
- )))))
-
-(defclass ede-linux-project (ede-project)
- ((build-directory :initarg :build-directory
- :type string
- :documentation "Build directory.")
- (architecture :initarg :architecture
- :type string
- :documentation "Target architecture.")
- (include-path :initarg :include-path
- :type list
- :documentation "Include directories.
-Contains both common and target architecture-specific directories."))
- "Project Type for the Linux source code."
- :method-invocation-order :depth-first)
-
-
-(defun ede-linux--get-build-directory (dir)
- "Detect build directory for sources in DIR.
-If DIR has not been used as a build directory, fall back to
-`project-linux-build-directory-default'."
- (or
- ;; detected build on source directory
- (and (file-exists-p (expand-file-name ".config" dir)) dir)
- ;; use configuration
- (cl-case project-linux-build-directory-default
- (same dir)
- (ask (read-directory-name "Select Linux' build directory: " dir)))))
-
-
-(defun ede-linux--get-archs (dir)
- "Return a list of architecture names found in DIR."
- (let ((archs-dir (expand-file-name "arch" dir))
- archs)
- (when (file-directory-p archs-dir)
- (mapc (lambda (elem)
- (when (and
- (not (string= elem "."))
- (not (string= elem ".."))
- (not (string= elem "x86_64")) ; has no separate sources
- (file-directory-p
- (expand-file-name elem archs-dir)))
- (add-to-list 'archs elem t)))
- (directory-files archs-dir)))
- archs))
-
-
-(defun ede-linux--detect-architecture (dir)
- "Try to auto-detect the architecture as configured in DIR.
-DIR is Linux' build directory. If it cannot be auto-detected,
-returns `project-linux-architecture-default'."
- (let ((archs-dir (expand-file-name "arch" dir))
- (archs (ede-linux--get-archs dir))
- arch found)
- (or (and
- archs
- ;; Look for /arch/<arch>/include/generated
- (progn
- (while (and archs (not found))
- (setq arch (car archs))
- (when (file-directory-p
- (expand-file-name (concat arch "/include/generated")
- archs-dir))
- (setq found arch))
- (setq archs (cdr archs)))
- found))
- project-linux-architecture-default)))
-
-(defun ede-linux--get-architecture (dir bdir)
- "Try to auto-detect the architecture as configured in BDIR.
-Uses `ede-linux--detect-architecture' for the auto-detection.
-If the result is `ask', let the user choose from architectures
-found in DIR."
- (let ((arch (ede-linux--detect-architecture bdir)))
- (cl-case arch
- (ask
- (completing-read "Select target architecture: "
- (ede-linux--get-archs dir)))
- (t arch))))
-
-
-(defun ede-linux--include-path (dir bdir arch)
- "Return a list with include directories.
-Returned directories might not exist, since they are not created
-until Linux is built for the first time."
- (cl-map 'list
- (lambda (elem) (format (concat (car elem) "/" (cdr elem)) arch))
- ;; XXX: taken from the output of "make V=1"
- (list (cons dir "arch/%s/include")
- (cons bdir "arch/%s/include/generated")
- (cons dir "include")
- (cons bdir "include")
- (cons dir "arch/%s/include/uapi")
- (cons bdir "arch/%s/include/generated/uapi")
- (cons dir "include/uapi")
- (cons bdir "include/generated/uapi"))))
-
-;;;###autoload
-(defun ede-linux-load (dir &optional _rootproj)
- "Return a Linux Project object if there is a match.
-Return nil if there isn't one.
-Argument DIR is the directory it is created for.
-ROOTPROJ is nil, since there is only one project."
- ;; Doesn't already exist, so let's make one.
- (let* ((bdir (ede-linux--get-build-directory dir))
- (arch (ede-linux--get-architecture dir bdir))
- (include-path (ede-linux--include-path dir bdir arch)))
- (make-instance 'ede-linux-project
- :name "Linux"
- :version (ede-linux-version dir)
- :directory (file-name-as-directory dir)
- :file (expand-file-name "scripts/ver_linux"
- dir)
- :build-directory bdir
- :architecture arch
- :include-path include-path)))
-
-;;;###autoload
-(ede-add-project-autoload
- (make-instance 'ede-project-autoload
- :name "LINUX ROOT"
- :file 'ede/linux
- :proj-file "scripts/ver_linux"
- :load-type 'ede-linux-load
- :class-sym 'ede-linux-project
- :new-p nil
- :safe-p t)
- 'unique)
-
-(defclass ede-linux-target-c (ede-target)
- ()
- "EDE Linux Project target for C code.
-All directories need at least one target.")
-
-(defclass ede-linux-target-misc (ede-target)
- ()
- "EDE Linux Project target for Misc files.
-All directories need at least one target.")
-
-(cl-defmethod initialize-instance ((this ede-linux-project)
- &rest _fields)
- "Make sure the targets slot is bound."
- (cl-call-next-method)
- (unless (slot-boundp this 'targets)
- (oset this :targets nil)))
-
-;;; File Stuff
-;;
-(cl-defmethod ede-project-root-directory ((this ede-linux-project)
- &optional _file)
- "Return the root for THIS Linux project with file."
- (ede-up-directory (file-name-directory (oref this file))))
-
-(cl-defmethod ede-project-root ((this ede-linux-project))
- "Return my root."
- this)
-
-(cl-defmethod ede-find-subproject-for-directory ((proj ede-linux-project)
- _dir)
- "Return PROJ, for handling all subdirs below DIR."
- proj)
-
-;;; TARGET MANAGEMENT
-;;
-(defun ede-linux-find-matching-target (class dir targets)
- "Find a target that is a CLASS and is in DIR in the list of TARGETS."
- (let ((match nil))
- (dolist (T targets)
- (when (and (object-of-class-p T class)
- (string= (oref T path) dir))
- (setq match T)
- ))
- match))
-
-(cl-defmethod ede-find-target ((proj ede-linux-project) buffer)
- "Find an EDE target in PROJ for BUFFER.
-If one doesn't exist, create a new one for this directory."
- (let* ((ext (file-name-extension (buffer-file-name buffer)))
- (cls (cond ((not ext)
- 'ede-linux-target-misc)
- ((string-match "c\\|h" ext)
- 'ede-linux-target-c)
- (t 'ede-linux-target-misc)))
- (targets (oref proj targets))
- (dir default-directory)
- (ans (ede-linux-find-matching-target cls dir targets))
- )
- (when (not ans)
- (setq ans (make-instance
- cls
- :name (file-name-nondirectory
- (directory-file-name dir))
- :path dir
- :source nil))
- (object-add-to-list proj :targets ans)
- )
- ans))
-
-;;; UTILITIES SUPPORT.
-;;
-(cl-defmethod ede-preprocessor-map ((this ede-linux-target-c))
- "Get the pre-processor map for Linux C code.
-All files need the macros from lisp.h!"
- (require 'semantic/db)
- (let* ((proj (ede-target-parent this))
- (root (ede-project-root proj))
- (versionfile (ede-expand-filename root "include/linux/version.h"))
- (table (when (and versionfile (file-exists-p versionfile))
- (semanticdb-file-table-object versionfile)))
- (filemap '( ("__KERNEL__" . "")
- ))
- )
- (when table
- (when (semanticdb-needs-refresh-p table)
- (semanticdb-refresh-table table))
- (setq filemap (append filemap (oref table lexical-table)))
- )
- filemap
- ))
-
-(defun ede-linux-file-exists-name (name root subdir)
- "Return a file name if NAME exists under ROOT with SUBDIR in between."
- (let ((F (expand-file-name name (expand-file-name subdir root))))
- (when (file-exists-p F) F)))
-
-(cl-defmethod ede-expand-filename-impl ((proj ede-linux-project) name)
- "Within this project PROJ, find the file NAME.
-Knows about how the Linux source tree is organized."
- (let* ((ext (file-name-extension name))
- (root (ede-project-root proj))
- (dir (ede-project-root-directory root))
- (bdir (oref proj build-directory))
- (F (cond
- ((not ext) nil)
- ((string-match "h" ext)
- (let ((dirs (oref proj include-path))
- found)
- (while (and dirs (not found))
- (setq found
- (or (ede-linux-file-exists-name name bdir (car dirs))
- (ede-linux-file-exists-name name dir (car dirs))))
- (setq dirs (cdr dirs)))
- found))
- ((string-match "txt" ext)
- (ede-linux-file-exists-name name dir "Documentation"))
- (t nil))))
- (or F (cl-call-next-method))))
-
-;;; Command Support
-;;
-(cl-defmethod project-compile-project ((proj ede-linux-project)
- &optional command)
- "Compile the entire current project.
-Argument COMMAND is the command to use when compiling."
- (let* ((dir (ede-project-root-directory proj)))
-
- (require 'compile)
- (if (not project-linux-compile-project-command)
- (setq project-linux-compile-project-command compile-command))
- (if (not command)
- (setq command
- (format
- project-linux-compile-project-command
- dir)))
-
- (compile command)))
-
-(cl-defmethod project-compile-target ((obj ede-linux-target-c) &optional command)
- "Compile the current target.
-Argument COMMAND is the command to use for compiling the target."
- (let* ((proj (ede-target-parent obj))
- (root (ede-project-root proj))
- (dir (ede-project-root-directory root))
- (subdir (oref obj path)))
-
- (require 'compile)
- (if (not project-linux-compile-project-command)
- (setq project-linux-compile-project-command compile-command))
- (if (not command)
- (setq command
- (format
- project-linux-compile-target-command
- dir subdir)))
-
- (compile command)))
-
-(cl-defmethod project-rescan ((this ede-linux-project))
- "Rescan this Linux project from the sources."
- (let* ((dir (ede-project-root-directory this))
- (bdir (ede-linux--get-build-directory dir))
- (arch (ede-linux--get-architecture dir bdir))
- (inc (ede-linux--include-path dir bdir arch))
- (ver (ede-linux-version dir)))
- (oset this version ver)
- (oset this :build-directory bdir)
- (oset this :architecture arch)
- (oset this :include-path inc)
- ))
-
-(provide 'ede/linux)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/linux"
-;; End:
-
-;;; ede/linux.el ends here
+++ /dev/null
-;;; ede/locate.el --- Locate support -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Support for various LOCATE type functions.
-;;
-;; A key feature of EDE is `ede-expand-filename', which allows a
-;; project to expand a filename reference in one file to some actual
-;; filename.
-;;
-;; In that way, you may #include <foo.h>, and without knowing how to
-;; read a Makefile, find it in <root>/include/foo.h.
-;;
-;; Some projects are regular, such as the Emacs project. Some
-;; projects are completely controlled by EDE, such sh the Project.ede
-;; based projects.
-;;
-;; For other projects, having a "quick hack" to support these location
-;; routines is handy.
-;;
-;; The baseclass `ede-locate-base' provides the abstract interface to
-;; finding files in a project.
-;;
-;; New location routines will subclass `ede-locate-base'.
-;;
-;; How to use:
-;;
-;; Configure `ede-locate-setup-options' to add the types of locate
-;; features you have available. EDE will then enable the correct one
-;; when it is available.
-
-(require 'ede)
-(eval-when-compile (require 'locate))
-
-;;; Code:
-(defcustom ede-locate-setup-options
- '(ede-locate-base)
- "List of locate objects to try out by default.
-Listed in order of preference. If the first item cannot be used in
-a particular project, then the next one is tried.
-It is always assumed that `ede-locate-base' is at end of the list."
- :group 'ede
- :type '(repeat
- (choice (const :tag "None" ede-locate-base)
- (const :tag "locate" ede-locate-locate)
- (const :tag "GNU Global" ede-locate-global)
- (const :tag "ID Utils" ede-locate-idutils)
- (const :tag "CScope" ede-locate-cscope)))
- )
-
-;;;###autoload
-(defun ede-enable-locate-on-project (&optional project)
- "Enable an EDE locate feature on PROJECT.
-Attempt to guess which project locate style to use
-based on `ede-locate-setup-options'."
- (interactive)
- (let* ((proj (or project (ede-toplevel)))
- (root (ede-project-root-directory proj))
- (opts ede-locate-setup-options)
- (ans nil))
- (while (and opts (not ans))
- (when (ede-locate-ok-in-project (car opts) root)
- ;; If interactive, check with the user.
- (when (or (not (called-interactively-p 'any))
- (y-or-n-p (format "Set project locator to %s? " (car opts))))
- (setq ans (car opts))))
- (setq opts (cdr opts)))
- ;; No match? Always create the baseclass for the hashing tool.
- (when (not ans)
- (when (called-interactively-p 'interactive)
- (message "Setting locator to ede-locate-base"))
- (setq ans 'ede-locate-base))
- (oset proj locate-obj (make-instance ans "Loc" :root root))
- (when (called-interactively-p 'interactive)
- (message "Setting locator to %s" ans))
- ))
-
-;;; LOCATE BASECLASS
-;;
-;; The baseclass for all location style queries.
-(defclass ede-locate-base ()
- ((root :initarg :root
- :documentation
- "The root of these locate searches.")
- (file :documentation
- "The last file searched for with EDE locate.")
- (lastanswer :documentation
- "The last answer provided by the locator.")
- (hash :documentation
- "Hash table of previously found files.")
- )
- "Baseclass for LOCATE feature in EDE.")
-
-(cl-defmethod initialize-instance ((loc ede-locate-base) &rest _fields)
- "Make sure we have a hash table."
- ;; Basic setup.
- (cl-call-next-method)
- ;; Make sure we have a hash table.
- (ede-locate-flush-hash loc)
- )
-
-(cl-defmethod ede-locate-ok-in-project ((_loc (subclass ede-locate-base))
- _root)
- "Is it ok to use this project type under ROOT."
- t)
-
-(cl-defmethod ede-locate-flush-hash ((loc ede-locate-base))
- "For LOC, flush hash table and start from scratch."
- (oset loc hash (make-hash-table :test 'equal)))
-
-(cl-defmethod ede-locate-file-in-hash ((loc ede-locate-base)
- filestring)
- "For LOC, is the file FILESTRING in our hash table?"
- (gethash filestring (oref loc hash)))
-
-(cl-defmethod ede-locate-add-file-to-hash ((loc ede-locate-base)
- filestring fullfilename)
- "For LOC, add FILESTR to the hash with FULLFILENAME."
- (puthash filestring fullfilename (oref loc hash)))
-
-(cl-defmethod ede-locate-file-in-project ((loc ede-locate-base)
- filesubstring
- )
- "Locate with LOC occurrences of FILESUBSTRING.
-Searches are done under the current root of the EDE project
-that created this EDE locate object."
- (let ((ans (ede-locate-file-in-project-impl loc filesubstring))
- )
- (oset loc file filesubstring)
- (oset loc lastanswer ans)
- ans))
-
-(cl-defmethod ede-locate-file-in-project-impl ((_loc ede-locate-base)
- _filesubstring)
- "Locate with LOC occurrences of FILESUBSTRING.
-Searches are done under the current root of the EDE project
-that created this EDE locate object."
- nil)
-
-(cl-defmethod ede-locate-create/update-root-database
- ((loc (subclass ede-locate-base)) _root)
- "Create or update the database for the current project.
-You cannot create projects for the baseclass."
- (error "Cannot create/update a database of type %S"
- (eieio-object-name loc)))
-
-;;; LOCATE
-;;
-;; Using the standard unix "locate" command.
-;; Since locate is system wide, we need to hack the search
-;; to restrict it to within just this project.
-
-(defclass ede-locate-locate (ede-locate-base)
- ()
- "EDE Locator using the locate command.
-Configure the Emacs `locate-command' variable to also
-configure the use of EDE locate.")
-
-(cl-defmethod ede-locate-ok-in-project ((_loc (subclass ede-locate-locate))
- _root)
- "Is it ok to use this project type under ROOT."
- (or (featurep 'locate) (locate-library "locate"))
- )
-
-(cl-defmethod ede-locate-file-in-project-impl ((loc ede-locate-locate)
- filesubstring)
- "Locate with LOC occurrences of FILESUBSTRING under PROJECTROOT.
-Searches are done under the current root of the EDE project
-that created this EDE locate object."
- ;; We want something like:
- ;; /my/project/root*/filesubstring.c
- (let* ((searchstr (concat (directory-file-name (oref loc root))
- "*/" filesubstring))
- (b (get-buffer-create "*LOCATE*"))
- (cd default-directory)
- )
- (with-current-buffer b
- (setq default-directory cd)
- (erase-buffer))
- (apply #'call-process locate-command
- nil b nil
- searchstr nil)
- (with-current-buffer b
- (split-string (buffer-string) "\n" t))
- )
- )
-
-;;; GLOBAL
-;;
-
-(declare-function cedet-gnu-global-version-check "cedet-global")
-(declare-function cedet-gnu-global-root "cedet-global")
-(declare-function cedet-gnu-global-expand-filename "cedet-global")
-(declare-function cedet-gnu-global-create/update-database "cedet-global")
-
-(defclass ede-locate-global (ede-locate-base)
- ()
- "EDE Locator using GNU Global.
-Configure EDE's use of GNU Global through the cedet-global.el
-variable `cedet-global-command'.")
-
-(cl-defmethod initialize-instance ((loc ede-locate-global)
- &rest _slots)
- "Make sure that we can use GNU Global."
- (require 'cedet-global)
- ;; Get ourselves initialized.
- (cl-call-next-method)
- ;; Do the checks.
- (cedet-gnu-global-version-check)
- (let* ((default-directory (oref loc root))
- (root (cedet-gnu-global-root)))
- (when (not root)
- (error "No GNU Global project found for %s"
- (oref loc root))))
- )
-
-(cl-defmethod ede-locate-ok-in-project ((_loc (subclass ede-locate-global))
- root)
- "Is it ok to use this project type under ROOT."
- (require 'cedet-global)
- (cedet-gnu-global-version-check)
- (let* ((default-directory root)
- (newroot (cedet-gnu-global-root)))
- newroot))
-
-(cl-defmethod ede-locate-file-in-project-impl ((loc ede-locate-global)
- filesubstring)
- "Locate occurrences of FILESUBSTRING in LOC, using GNU Global."
- (require 'cedet-global)
- (let ((default-directory (oref loc root)))
- (cedet-gnu-global-expand-filename filesubstring)))
-
-(cl-defmethod ede-locate-create/update-root-database
- ((_loc (subclass ede-locate-global)) root)
- "Create or update the GNU Global database for the current project."
- (cedet-gnu-global-create/update-database root))
-
-;;; IDUTILS
-;;
-
-(declare-function cedet-idutils-version-check "cedet-idutils")
-(declare-function cedet-idutils-support-for-directory "cedet-idutils")
-(declare-function cedet-idutils-expand-filename "cedet-idutils")
-(declare-function cedet-idutils-create/update-database "cedet-idutils")
-
-(defclass ede-locate-idutils (ede-locate-base)
- ()
- "EDE Locator using IDUtils.
-Configure EDE's use of IDUtils through the cedet-idutils.el
-file name searching variable `cedet-idutils-file-command'.")
-
-(cl-defmethod initialize-instance ((loc ede-locate-idutils)
- &rest _slots)
- "Make sure that we can use IDUtils."
- ;; Get ourselves initialized.
- (cl-call-next-method)
- ;; Do the checks.
- (require 'cedet-idutils)
- (cedet-idutils-version-check)
- (when (not (cedet-idutils-support-for-directory (oref loc root)))
- (error "Cannot use IDUtils in %s"
- (oref loc root)))
- )
-
-(cl-defmethod ede-locate-ok-in-project ((_loc (subclass ede-locate-idutils))
- root)
- "Is it ok to use this project type under ROOT."
- (require 'cedet-idutils)
- (cedet-idutils-version-check)
- (when (cedet-idutils-support-for-directory root)
- root))
-
-(cl-defmethod ede-locate-file-in-project-impl ((loc ede-locate-idutils)
- filesubstring)
- "Locate with LOC occurrences of FILESUBSTRING under PROJECTROOT.
-Searches are done under the current root of the EDE project
-that created this EDE locate object."
- (require 'cedet-idutils)
- (let ((default-directory (oref loc root)))
- (cedet-idutils-expand-filename filesubstring)))
-
-(cl-defmethod ede-locate-create/update-root-database
- ((_loc (subclass ede-locate-idutils)) root)
- "Create or update the GNU Global database for the current project."
- (cedet-idutils-create/update-database root))
-
-;;; CSCOPE
-;;
-
-(declare-function cedet-cscope-version-check "cedet-cscope")
-(declare-function cedet-cscope-support-for-directory "cedet-cscope")
-(declare-function cedet-cscope-expand-filename "cedet-cscope")
-(declare-function cedet-cscope-create/update-database "cedet-cscope")
-
-(defclass ede-locate-cscope (ede-locate-base)
- ()
- "EDE Locator using Cscope.
-Configure EDE's use of Cscope through the cedet-cscope.el
-file name searching variable `cedet-cscope-command'.")
-
-(cl-defmethod initialize-instance ((loc ede-locate-cscope)
- &rest _slots)
- "Make sure that we can use Cscope."
- ;; Get ourselves initialized.
- (cl-call-next-method)
- ;; Do the checks.
- (require 'cedet-cscope)
- (cedet-cscope-version-check)
- (when (not (cedet-cscope-support-for-directory (oref loc root)))
- (error "Cannot use Cscope in %s"
- (oref loc root)))
- )
-
-(cl-defmethod ede-locate-ok-in-project ((_loc (subclass ede-locate-cscope))
- root)
- "Is it ok to use this project type under ROOT."
- (require 'cedet-cscope)
- (cedet-cscope-version-check)
- (when (cedet-cscope-support-for-directory root)
- root))
-
-(cl-defmethod ede-locate-file-in-project-impl ((loc ede-locate-cscope)
- filesubstring)
- "Locate with LOC occurrences of FILESUBSTRING under PROJECTROOT.
-Searches are done under the current root of the EDE project
-that created this EDE locate object."
- (let ((default-directory (oref loc root)))
- (require 'cedet-cscope)
- (cedet-cscope-expand-filename filesubstring)))
-
-(cl-defmethod ede-locate-create/update-root-database
- ((_loc (subclass ede-locate-cscope)) root)
- "Create or update the Cscope database for the current project."
- (require 'cedet-cscope)
- (cedet-cscope-create/update-database root))
-
-(provide 'ede/locate)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/locate"
-;; End:
-
-;;; ede/locate.el ends here
+++ /dev/null
-;;; ede/make.el --- General information about "make" -*- lexical-binding: t -*-
-
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This file needs to choose the version of "make" it wants to use.
-;; Whenever an executable "gmake" is available, we prefer that since
-;; it usually means GNU Make. If it doesn't exist, use "make".
-;;
-;; Run tests on make --version to be sure it is GNU make so that
-;; logical error messages can be provided.
-
-;;; Code:
-
-(defsubst ede--find-executable (exec)
- "Return an expanded file name for a program EXEC on the exec path."
- (declare (obsolete locate-file "28.1"))
- (locate-file exec exec-path))
-
-(defvar ede-make-min-version "3.0"
- "Minimum version of GNU make required.")
-
-(defcustom ede-make-command (cond ((executable-find "gmake")
- "gmake")
- (t "make")) ;; What to do?
- "The MAKE command to use for EDE when compiling.
-The makefile generated by EDE for C files uses syntax that depends on GNU Make,
-so this should be set to something that can execute GNU Make files."
- :group 'ede
- :type 'string)
-
-;;;###autoload
-(defun ede-make-check-version (&optional noerror)
- "Check the version of GNU Make installed.
-The check passes if the MAKE version is no high enough, or if it
-is not GNU make.
-If NOERROR is non-nil, return t for success, nil for failure.
-If NOERROR is nil, then throw an error on failure. Return t otherwise."
- (interactive)
- (let ((b (get-buffer-create "*EDE Make Version*"))
- (cd default-directory)
- (rev nil)
- (ans nil))
- (with-current-buffer b
- ;; Setup, and execute make.
- (setq default-directory cd)
- (erase-buffer)
- (call-process ede-make-command nil b nil
- "--version")
- ;; Check the buffer for the string
- (goto-char (point-min))
- (when (looking-at "GNU Make\\(?: version\\)? \\([0-9][^,[:space:]]+\\),?")
- (setq rev (match-string 1))
- (setq ans (not (version< rev ede-make-min-version))))
-
- ;; Answer reporting.
- (when (and (called-interactively-p 'interactive) ans)
- (message "GNU Make version %s. Good enough for CEDET." rev))
-
- (when (and (not noerror) (not ans))
- (error "EDE requires GNU Make version %s or later (found %s). Configure `ede-make-command' to fix"
- ede-make-min-version
- rev))
- ans)))
-
-(provide 'ede/make)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/make"
-;; End:
-
-;;; ede/make.el ends here
+++ /dev/null
-;;; makefile-edit.el --- Makefile editing/scanning commands. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Utilities for editing a Makefile for EDE Makefile management commands.
-;;
-;; Derived from project-am.el.
-;;
-;; Makefile editing and scanning commands
-;;
-;; Formatting of a makefile
-;;
-;; 1) Creating an automakefile, stick in a top level comment about
-;; being created by Emacs.
-;; 2) Leave order of variable contents alone, except for SOURCE
-;; SOURCE always keep in the order of .c, .h, the other stuff.
-
-;;; Things to do
-;; makefile-fill-paragraph -- refill a macro with backslashes
-;; makefile-insert-macro -- insert "foo = "
-
-
-;;; Code:
-
-(defun makefile-beginning-of-command ()
- "Move to the beginning of the current command."
- (interactive)
- (if (save-excursion
- (forward-line -1)
- (makefile-line-continued-p))
- (forward-line -1))
- (beginning-of-line)
- (if (not (makefile-line-continued-p))
- nil
- (while (and (makefile-line-continued-p)
- (not (bobp)))
- (forward-line -1))
- (forward-line 1)))
-
-(defun makefile-end-of-command ()
- "Move to the end of the current command."
- (interactive)
- (end-of-line)
- (while (and (makefile-line-continued-p)
- (not (eobp)))
- (forward-line 1)
- (end-of-line)))
-
-(defun makefile-line-continued-p ()
- "Return non-nil if the current line ends in continuation."
- (save-excursion
- (end-of-line)
- (= (preceding-char) ?\\)))
-
-;;; Programmatic editing of a Makefile
-;;
-(defun makefile-move-to-macro (macro &optional next)
- "Move to the definition of MACRO. Return t if found.
-If NEXT is non-nil, move to the next occurrence of MACRO."
- (let ((oldpt (point)))
- (when (not next) (goto-char (point-min)))
- (if (re-search-forward (concat "^\\s-*" (regexp-quote macro) "\\s-*[+:?]?=")
- nil t)
- t
- (goto-char oldpt)
- nil)))
-
-(defun makefile-navigate-macro (stop-before)
- "In a list of files, move forward until STOP-BEFORE is reached.
-STOP-BEFORE is a regular expression matching a file name."
- (save-excursion
- (makefile-beginning-of-command)
- (let ((e (save-excursion
- (makefile-end-of-command)
- (point))))
- (if (re-search-forward stop-before nil t)
- (goto-char (match-beginning 0))
- (goto-char e)))))
-
-(defun makefile-macro-file-list (macro)
- "Return a list of all files in MACRO."
- (save-excursion
- (goto-char (point-min))
- (let ((lst nil)
- (case-fold-search nil))
- (while (makefile-move-to-macro macro t)
- (let ((e (save-excursion
- (makefile-end-of-command)
- (point))))
- (while (re-search-forward "\\s-*\\([-a-zA-Z0-9./_@$%(){}]+\\)\\s-*" e t)
- (let ((var nil)(varexp nil)
- (match (buffer-substring-no-properties
- (match-beginning 1)
- (match-end 1))))
- (if (not (setq var (makefile-extract-varname-from-text match)))
- (setq lst (cons match lst))
- (setq varexp (makefile-macro-file-list var))
- (dolist (V varexp)
- (setq lst (cons V lst))))))))
- (nreverse lst))))
-
-(defun makefile-extract-varname-from-text (text)
- "Extract the variable name from TEXT if it is a variable reference.
-Return nil if it isn't a variable."
- (save-match-data
- (when (string-match "\\$\\s(\\([A-Za-z0-9_]+\\)\\s)" text)
- (match-string 1 text))))
-
-
-(provide 'ede/makefile-edit)
-
-;;; ede/makefile-edit.el ends here
+++ /dev/null
-;;; ede/pconf.el --- configure.ac maintenance for EDE -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Code generator for autoconf configure.ac, and support files.
-
-(require 'ede/proj)
-(require 'ede/autoconf-edit)
-(defvar compilation-in-progress)
-
-(defvar ede-pconf-create-file-query 'ask
- "Controls if queries are made while creating project files.
-A value of `ask' means to always ask the user before creating
-a file, such as AUTHORS. A value of `never' means don't ask, and
-don't do it. A value of nil means to just do it.")
-
-;;; Code:
-(cl-defmethod ede-proj-configure-file ((this ede-proj-project))
- "The configure.ac script used by project THIS."
- (ede-expand-filename (ede-toplevel this) "configure.ac" t))
-
-(cl-defmethod ede-proj-configure-test-required-file ((this ede-proj-project) file)
- "For project THIS, test that the file FILE exists, or create it."
- (let ((f (ede-expand-filename (ede-toplevel this) file t)))
- (when (not (file-exists-p f))
- (save-excursion
- (find-file f)
- (cond ((string= file "AUTHORS")
- (insert (user-full-name) " <" (user-login-name) ">"))
- ((string= file "NEWS")
- (insert "NEWS file for " (ede-name this)))
- (t (insert "\n")))
- (save-buffer)
- (when
- (and (eq ede-pconf-create-file-query 'ask)
- (not (eq ede-pconf-create-file-query 'never))
- (not (y-or-n-p
- (format "I had to create the %s file for you. Ok? "
- file))))
- (error "Quit"))))))
-
-
-(cl-defmethod ede-proj-configure-synchronize ((this ede-proj-project))
- "Synchronize what we know about project THIS into configure.ac."
- (let ((b (find-file-noselect (ede-proj-configure-file this)))
- ;;(td (file-name-directory (ede-proj-configure-file this)))
- (targs (oref this targets))
- (postcmd "")
- ) ;; (add-missing nil)
- ;; First, make sure we have a file.
- (if (not (file-exists-p (ede-proj-configure-file this)))
- (autoconf-new-program b (oref this name) "Project.ede"))
- (set-buffer b)
- ;; Next, verify all targets of all subobjects.
- (autoconf-set-version (oref this version))
- (let ((top-level-project-local this))
- (autoconf-set-output
- (ede-map-all-subprojects
- this
- (lambda (sp)
- ;; NOTE: don't put in ./Makefile - configure complains.
- (let ((dir (file-name-as-directory
- (directory-file-name
- (ede-subproject-relative-path sp top-level-project-local)))))
- (when (string= dir "./") (setq dir ""))
- ;; Use concat, because expand-file-name removes the relativity.
- (concat dir "Makefile") )))))
- ;;
- ;; NOTE TO SELF. TURN THIS INTO THE OFFICIAL LIST
- ;;
- (ede-proj-dist-makefile this)
- ;; Loop over all targets to clean and then add themselves in.
- (ede-map-all-subprojects
- this
- (lambda (sp)
- (ede-map-targets sp #'ede-proj-flush-autoconf)))
- (ede-map-all-subprojects
- this
- (lambda (_sp)
- (ede-map-targets this #'ede-proj-tweak-autoconf)))
- ;; Now save
- (save-buffer)
- (setq postcmd "autoreconf -f -i;")
-
- ;; Verify a bunch of files that are required by automake.
- (ede-proj-configure-test-required-file this "AUTHORS")
- (ede-proj-configure-test-required-file this "NEWS")
- (ede-proj-configure-test-required-file this "README")
- (ede-proj-configure-test-required-file this "ChangeLog")
- ;; Let specific targets get missing files.
- (mapc #'ede-proj-configure-create-missing targs)
- ;; Verify that we have a make system.
- (if (or (not (ede-expand-filename (ede-toplevel this) "Makefile"))
- ;; Now is this one of our old Makefiles?
- (with-current-buffer
- (find-file-noselect
- (ede-expand-filename (ede-toplevel this)
- "Makefile" t)
- t)
- (goto-char (point-min))
- ;; Here is the unique piece for our makefiles.
- (re-search-forward "For use with: make" nil t)))
- (setq postcmd (concat postcmd "./configure;")))
- (if (not (string= "" postcmd))
- (progn
- (compile postcmd)
-
- (while compilation-in-progress
- (accept-process-output)
- ;; If sit for indicates that input is waiting, then
- ;; read and discard whatever it is that is going on.
- (when (not (sit-for 1))
- (read-event nil nil .1)
- ))
-
- (with-current-buffer "*compilation*"
- (goto-char (point-max))
-
- ;; FIXME: Use `compilation-finish-functions' or similar to
- ;; avoid relying on exact format of `mode-line-process'.
- (when (not (string= (car mode-line-process) ":exit [0]"))
- (error "Configure failed!"))
-
- ;; The Makefile is now recreated by configure?
- (let ((b (get-file-buffer
- (ede-expand-filename (ede-toplevel this)
- "Makefile" 'newfile))))
- ;; This makes sure that if Makefile was loaded, and old,
- ;; that it gets flushed so we don't keep rebuilding
- ;; the autoconf system.
- (if b (kill-buffer b))))
-
- ))))
-
-(cl-defmethod ede-proj-configure-recreate ((this ede-proj-project))
- "Delete project THIS's configure script and start over."
- (if (not (ede-proj-configure-file this))
- (error "Could not determine configure.ac for %S" (eieio-object-name this)))
- (let ((b (get-file-buffer (ede-proj-configure-file this))))
- ;; Destroy all evidence of the old configure.ac
- (delete-file (ede-proj-configure-file this))
- (if b (kill-buffer b)))
- (ede-proj-configure-synchronize this))
-
-(cl-defmethod ede-proj-tweak-autoconf ((this ede-proj-target))
- "Tweak the configure file (current buffer) to accommodate THIS."
- ;; Check the compilers belonging to THIS, and call the autoconf
- ;; setup for those compilers.
- (mapc #'ede-proj-tweak-autoconf (ede-proj-compilers this))
- (mapc #'ede-proj-tweak-autoconf (ede-proj-linkers this))
- )
-
-(cl-defmethod ede-proj-flush-autoconf ((_this ede-proj-target))
- "Flush the configure file (current buffer) to accommodate THIS.
-By flushing, remove any cruft that may be in the file. Subsequent
-calls to `ede-proj-tweak-autoconf' can restore items removed by flush."
- nil)
-
-
-;; @TODO - No-one calls this ???
-(cl-defmethod ede-proj-configure-add-missing ((_this ede-proj-target))
- "Query if any files needed by THIS provided by automake are missing.
-Results in --add-missing being passed to automake."
- nil)
-
-;; @TODO - No-one implements this yet.
-(cl-defmethod ede-proj-configure-create-missing ((_this ede-proj-target))
- "Add any missing files for THIS by creating them."
- nil)
-
-(provide 'ede/pconf)
-
-;;; ede/pconf.el ends here
+++ /dev/null
-;;; ede-pmake.el --- EDE Generic Project Makefile code generator -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2005, 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Code generator for Makefiles.
-;;
-;; Here is how it should work:
-;; 1) Collect information about the project and targets
-;; 2) Insert header into the Makefile
-;; 3) Insert basic variables (target/source)
-;; 4) Conditional
-;; a) Makefile
-;; 1) Insert support variables (compiler variables, etc)
-;; 2) Insert VERSION and DISTDIR
-;; 3) Specify top build dir if necessary
-;; 4) Specify compile/link commands (c, etc)
-;; 5) Specify dependency files
-;; 6) Specify all: target
-;; 7) Include dependency files
-;; 8) Insert commonized target specify rules
-;; 9) Insert clean: and dist: rules
-;; b) Automake file
-;; 1) Insert distribution source variables for targets
-;; 2) Insert user requested rules
-
-(require 'ede/proj)
-(require 'ede/proj-obj)
-(require 'ede/proj-comp)
-(require 'seq)
-
-(declare-function ede-srecode-setup "ede/srecode")
-(declare-function ede-srecode-insert "ede/srecode")
-
-;;; Code:
-(cl-defmethod ede-proj-makefile-create ((this ede-proj-project) mfilename)
- "Create a Makefile for all Makefile targets in THIS.
-MFILENAME is the makefile to generate."
- (require 'ede/srecode)
- (let ((mt nil)
- (isdist (string= mfilename (ede-proj-dist-makefile this)))
- (depth 0)
- (orig-buffer nil)
- (buff-to-kill nil)
- )
- ;; Find out how deep this project is.
- (let ((tmp this))
- (while (setq tmp (ede-parent-project tmp))
- (setq depth (1+ depth))))
- ;; Collect the targets that belong in a makefile.
- (mapc
- (lambda (obj)
- (if (and (obj-of-class-p obj 'ede-proj-target-makefile)
- (string= (oref obj makefile) mfilename))
- (setq mt (cons obj mt))))
- (oref this targets))
- ;; Fix the order so things compile in the right direction.
- (setq mt (nreverse mt))
- ;; Add in the header part of the Makefile*
- (save-excursion
- (setq orig-buffer (get-file-buffer mfilename))
- (set-buffer (setq buff-to-kill (find-file-noselect mfilename)))
- (goto-char (point-min))
- (if (and
- (not (eobp))
- (not (looking-at "# Automatically Generated \\w+ by EDE.")))
- (if (not (y-or-n-p (format "Really replace %s? " mfilename)))
- (error "Not replacing Makefile"))
- (message "Replace EDE Makefile"))
- (erase-buffer)
- (ede-srecode-setup)
- ;; Insert a giant pile of stuff that is common between
- ;; one of our Makefiles, and a Makefile.in
- (ede-srecode-insert
- "file:ede-empty"
- "MAKETYPE"
- (with-slots (makefile-type) this
- (cond ((eq makefile-type 'Makefile) "make")
- ((eq makefile-type 'Makefile.in) "autoconf")
- ((eq makefile-type 'Makefile.am) "automake")
- (t (error ":makefile-type in project invalid")))))
-
- ;; Just this project's variables
- (ede-proj-makefile-insert-variables this)
-
- ;; Space
- (insert "\n")
-
- (cond
- ((eq (oref this makefile-type) 'Makefile)
- ;; Make sure the user has the right kind of make
- (ede-make-check-version)
-
- (let* ((targ (if isdist (oref this targets) mt))
- (sp (oref this subproj))
- (df (apply #'append
- (mapcar (lambda (tg)
- (ede-proj-makefile-dependency-files tg))
- targ))))
- ;; Distribution variables
- (ede-compiler-begin-unique
- (mapc #'ede-proj-makefile-insert-variables targ))
- ;; Only add the distribution stuff in when depth != 0
- (let ((top (ede-toplevel this))
- (tmp this)
- (subdir ""))
- (insert "VERSION=" (oref top version) "\n"
- "DISTDIR=$(top)" (oref top name) "-$(VERSION)")
- (while (ede-parent-project tmp)
- (setq subdir
- (concat
- "/"
- (file-name-nondirectory
- (directory-file-name
- (file-name-directory (oref tmp file))))
- subdir)
- tmp (ede-parent-project tmp)))
- (insert subdir "\n"))
- ;; Some built in variables for C code
- (if df
- (let ((tc depth))
- (insert "top_builddir = ")
- (while (/= 0 tc)
- (setq tc (1- tc))
- (insert "..")
- (if (/= tc 0) (insert "/")))
- (insert "\n")))
- (insert "\n")
- ;; Create a variable with all the dependency files to include
- ;; These methods borrowed from automake.
- (if (and (oref this automatic-dependencies) df)
- (progn
- (insert "DEP_FILES="
- (mapconcat (lambda (f)
- (concat ".deps/"
- (file-name-nondirectory
- (file-name-sans-extension
- f))
- ".P"))
- df " "))))
- ;;
- ;; Insert ALL Rule
- ;;
- (insert "\n\nall:")
- (mapc (lambda (c)
- (if (and (slot-exists-p c 'partofall) (oref c partofall))
- ;; Only insert this rule if it is a part of ALL.
- (insert " " (ede-proj-makefile-target-name c))))
- targ)
- (mapc (lambda (c)
- (insert " " (ede-name c))
- )
- sp)
- (insert "\n\n")
- ;;
- ;; Add in the include files
- ;;
- (mapc (lambda (c)
- (insert "include " c "\n\n"))
- (oref this include-file))
- ;; Some C inference rules
- ;; Dependency rules borrowed from automake.
- ;;
- ;; NOTE: This is GNU Make specific.
- (if (and (oref this automatic-dependencies) df)
- (insert "DEPS_MAGIC := $(shell mkdir .deps > " null-device " "
- "2>&1 || :)\n"
- "-include $(DEP_FILES)\n\n"))
- ;;
- ;; General makefile rules stored in the individual targets
- ;;
- (ede-compiler-begin-unique
- (ede-proj-makefile-insert-rules this)
- (mapc #'ede-proj-makefile-insert-rules targ))
- ;;
- ;; phony targets for sub projects
- ;;
- (mapc #'ede-proj-makefile-insert-subproj-rules sp)
- ;;
- ;; Distribution rules such as CLEAN and DIST
- ;;
- (when isdist
- (ede-proj-makefile-tags this mt)
- (ede-proj-makefile-insert-dist-rules this)))
- (save-buffer))
- ((eq (oref this makefile-type) 'Makefile.in)
- (error "Makefile.in is not supported"))
- ((eq (oref this makefile-type) 'Makefile.am)
- (require 'ede/pconf)
- ;; Basic vars needed:
- (ede-proj-makefile-automake-insert-subdirs this)
- (ede-proj-makefile-automake-insert-extradist this)
- ;; Distribution variables
- (let ((targ (if isdist (oref this targets) mt)))
- (ede-compiler-begin-unique
- (mapc #'ede-proj-makefile-insert-automake-pre-variables targ))
- (ede-compiler-begin-unique
- (mapc #'ede-proj-makefile-insert-source-variables targ))
- (ede-compiler-begin-unique
- (mapc #'ede-proj-makefile-insert-automake-post-variables targ))
- (ede-compiler-begin-unique
- (ede-proj-makefile-insert-user-rules this))
- (insert "\n# End of Makefile.am\n")
- (save-buffer))
- )
- (t (error "Unknown makefile type when generating Makefile")))
- ;; Put the cursor in a nice place
- (goto-char (point-min)))
- ;; If we have an original buffer, then don't kill it.
- (when (not orig-buffer)
- (kill-buffer buff-to-kill))
- ))
-
-;;; VARIABLE insertion
-;;
-(defun ede-pmake-end-of-variable ()
- "Move to the end of the variable declaration under point."
- (end-of-line)
- (while (= (preceding-char) ?\\)
- (forward-char 1)
- (end-of-line))
- )
-
-(defmacro ede-pmake-insert-variable-shared (varname &rest body)
- "Add VARNAME into the current Makefile.
-Execute BODY in a location where a value can be placed."
- (declare (debug t) (indent 1))
- `(let ((addcr t) (v ,varname))
- (if (save-excursion
- (goto-char (point-max))
- (re-search-backward (concat "^" v "\\s-*=") nil t))
- (progn
- (goto-char (match-end 0))
- (ede-pmake-end-of-variable)
- (if (< (current-column) 40)
- (if (and (/= (preceding-char) ?=)
- (/= (preceding-char) ? ))
- (insert " "))
- (insert "\\\n "))
- (setq addcr nil))
- (insert v "="))
- ,@body
- (if addcr (insert "\n"))
- (goto-char (point-max))))
-
-(defmacro ede-pmake-insert-variable-once (varname &rest body)
- "Add VARNAME into the current Makefile if it doesn't exist.
-Execute BODY in a location where a value can be placed."
- (declare (debug t) (indent 1))
- `(let ((v ,varname))
- (unless
- (save-excursion
- (re-search-backward (concat "^" v "\\s-*=") nil t))
- (insert v "=")
- ,@body
- (insert "\n")
- (goto-char (point-max)))))
-
-;;; SOURCE VARIABLE NAME CONSTRUCTION
-
-(defsubst ede-pmake-varname (obj)
- "Convert OBJ into a variable name.
-Change . to _ in the variable name."
- (let ((name (oref obj name)))
- (while (string-match "\\." name)
- (setq name (replace-match "_" nil t name)))
- name))
-
-(cl-defmethod ede-proj-makefile-sourcevar ((this ede-proj-target))
- "Return the variable name for THIS's sources."
- (concat (ede-pmake-varname this) "_YOU_FOUND_A_BUG"))
-
-;;; DEPENDENCY FILE GENERATOR LISTS
-;;
-(cl-defmethod ede-proj-makefile-dependency-files ((_this ede-proj-target))
- "Return a list of source files to convert to dependencies.
-Argument THIS is the target to get sources from."
- nil)
-
-;;; GENERIC VARIABLES
-;;
-(cl-defmethod ede-proj-makefile-configuration-variables ((this ede-proj-project)
- configuration)
- "Return a list of configuration variables from THIS.
-Use CONFIGURATION as the current configuration to query."
- (cdr (assoc configuration (oref this configuration-variables))))
-
-(cl-defmethod ede-proj-makefile-insert-variables-new ((_this ede-proj-project))
- "Insert variables needed by target THIS.
-
-NOTE: Not yet in use! This is part of an SRecode conversion of
- EDE that is in progress."
-; (let ((conf-table (ede-proj-makefile-configuration-variables
-; this (oref this configuration-default)))
-; (conf-done nil))
-;
-; (ede-srecode-insert-with-dictionary
-; "declaration:ede-vars"
-;
-; ;; Insert all variables, and augment them with details from
-; ;; the current configuration.
-; (mapc (lambda (c)
-;
-; (let ((ldict (srecode-dictionary-add-section-dictionary
-; dict "VARIABLE"))
-; )
-; (srecode-dictionary-set-value ldict "NAME" (car c))
-; (if (assoc (car c) conf-table)
-; (let ((vdict (srecode-dictionary-add-section-dictionary
-; ldict "VALUE")))
-; (srecode-dictionary-set-value
-; vdict "VAL" (cdr (assoc (car c) conf-table)))
-; (setq conf-done (cons (car c) conf-done))))
-; (let ((vdict (srecode-dictionary-add-section-dictionary
-; ldict "VALUE")))
-; (srecode-dictionary-set-value vdict "VAL" (cdr c))))
-; )
-;
-; (oref this variables))
-;
-; ;; Add in all variables from the configuration not already covered.
-; (mapc (lambda (c)
-;
-; (if (member (car c) conf-done)
-; nil
-; (let* ((ldict (srecode-dictionary-add-section-dictionary
-; dict "VARIABLE"))
-; (vdict (srecode-dictionary-add-section-dictionary
-; ldict "VALUE"))
-; )
-; (srecode-dictionary-set-value ldict "NAME" (car c))
-; (srecode-dictionary-set-value vdict "VAL" (cdr c))))
-; )
-;
-; conf-table)
-;
-
- ;; @TODO - finish off this function, and replace the below fcn
-
-; ))
- )
-
-(cl-defmethod ede-proj-makefile-insert-variables ((this ede-proj-project))
- "Insert variables needed by target THIS."
- (let ((conf-table (ede-proj-makefile-configuration-variables
- this (oref this configuration-default)))
- (conf-done nil))
- ;; Insert all variables, and augment them with details from
- ;; the current configuration.
- (mapc (lambda (c)
- (insert (car c) "=")
- (if (assoc (car c) conf-table)
- (progn
- (insert (cdr (assoc (car c) conf-table)) " ")
- (setq conf-done (cons (car c) conf-done))))
- (insert (cdr c) "\n"))
- (oref this variables))
- ;; Add in all variables from the configuration not already covered.
- (mapc (lambda (c)
- (if (member (car c) conf-done)
- nil
- (insert (car c) "=" (cdr c) "\n")))
- conf-table))
- (let* ((top "")
- (tmp this))
- ;; Use relative paths for subdirs.
- (while (ede-parent-project tmp)
- (setq tmp (ede-parent-project tmp)
- top (concat "../" top)))
- ;; If this is the top, then use CURDIR.
- (if (and (not (oref this metasubproject)) (string= top ""))
- (insert "\ntop=\"$(CURDIR)\"/")
- (insert "\ntop=" top)))
- (insert "\nede_FILES=" (file-name-nondirectory (oref this file)) " "
- (file-name-nondirectory (ede-proj-dist-makefile this)) "\n"))
-
-(cl-defmethod ede-proj-makefile-insert-source-variables ((this ede-proj-target)
- &optional
- moresource)
- "Insert the source variables needed by THIS.
-Optional argument MORESOURCE is a list of additional sources to add to the
-sources variable."
- (let ((sv (ede-proj-makefile-sourcevar this)))
- ;; This variable may be shared between targets
- (ede-pmake-insert-variable-shared (cond ((listp sv) (car sv))
- (t sv))
- (insert (mapconcat (lambda (a) a) (oref this source) " "))
- (if moresource
- (insert " \\\n " (mapconcat (lambda (a) a) moresource " ") "")))))
-
-(cl-defmethod ede-proj-makefile-insert-variables ((this ede-proj-target) &optional
- moresource)
- "Insert variables needed by target THIS.
-Optional argument MORESOURCE is a list of additional sources to add to the
-sources variable."
- (ede-proj-makefile-insert-source-variables this moresource)
- )
-
-(cl-defmethod ede-proj-makefile-configuration-variables ((this ede-proj-target-makefile)
- configuration)
- "Return a list of configuration variables from THIS.
-Use CONFIGURATION as the current configuration to query."
- (cdr (assoc configuration (oref this configuration-variables))))
-
-(cl-defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile)
- &optional _moresource)
- "Insert variables needed by target THIS.
-Optional argument MORESOURCE is a list of additional sources to add to the
-sources variable."
- (cl-call-next-method)
- (let* ((proj (ede-target-parent this))
- (conf-table (ede-proj-makefile-configuration-variables
- this (oref proj configuration-default)))
- ;; (conf-done nil)
- )
- ;; Add in all variables from the configuration not already covered.
- (mapc (lambda (c)
- (if nil ;; (member (car c) conf-done)
- nil
- (insert (car c) "=" (cdr c) "\n")))
- conf-table))
- (let ((comp (ede-proj-compilers this))
- (link (ede-proj-linkers this))
- (name (ede-proj-makefile-target-name this))
- (src (oref this source)))
- (ede-proj-makefile-insert-object-variables (car comp) name src)
- (dolist (obj comp)
- (ede-compiler-only-once obj
- (ede-proj-makefile-insert-variables obj)))
- (dolist (linker link)
- (ede-linker-only-once linker
- (ede-proj-makefile-insert-variables linker)))))
-
-(cl-defmethod ede-proj-makefile-insert-automake-pre-variables
- ((_this ede-proj-target))
- "Insert variables needed by target THIS in Makefile.am before SOURCES."
- nil)
-
-(cl-defmethod ede-proj-makefile-insert-automake-post-variables
- ((_this ede-proj-target))
- "Insert variables needed by target THIS in Makefile.am after SOURCES."
- nil)
-
-;;; GARBAGE PATTERNS
-;;
-(cl-defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-project))
- "Return a list of patterns that are considered garbage to THIS.
-These are removed with make clean."
- (let ((mc (ede-map-targets
- this #'ede-proj-makefile-garbage-patterns))
- (uniq nil))
- (setq mc (sort (apply #'append mc)))
- ;; Filter out duplicates from the targets.
- (while mc
- (if (and (car uniq) (string= (car uniq) (car mc)))
- nil
- (setq uniq (cons (car mc) uniq)))
- (setq mc (cdr mc)))
- (nreverse uniq)))
-
-(cl-defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-target))
- "Return a list of patterns that are considered garbage to THIS.
-These are removed with make clean."
- ;; Get the source object from THIS, and use the specified garbage.
- (let ((src (ede-target-sourcecode this))
- (garb nil))
- (while src
- (setq garb (append (oref (car src) garbagepattern) garb)
- src (cdr src)))
- garb))
-
-
-;;; RULES
-;;
-(cl-defmethod ede-proj-makefile-insert-subproj-rules ((this ede-proj-project))
- "Insert a rule for the project THIS which should be a subproject."
- (insert ".PHONY:" (ede-name this))
- (newline)
- (insert (ede-name this) ":")
- (newline)
- (insert "\t$(MAKE) -C " (directory-file-name (ede-subproject-relative-path this)))
- (newline)
- (newline)
- )
-
-(cl-defmethod ede-proj-makefile-insert-rules ((this ede-proj-project))
- "Insert rules needed by THIS target."
- (mapc #'ede-proj-makefile-insert-rules (oref this inference-rules))
- )
-
-(cl-defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-project))
- "Insert any symbols that the DIST rule should depend on.
-Argument THIS is the project that should insert stuff."
- (mapc #'ede-proj-makefile-insert-dist-dependencies (oref this targets))
- )
-
-(cl-defmethod ede-proj-makefile-insert-dist-dependencies ((_this ede-proj-target))
- "Insert any symbols that the DIST rule should depend on.
-Argument THIS is the target that should insert stuff."
- nil)
-
-(cl-defmethod ede-proj-makefile-insert-dist-filepatterns ((this ede-proj-target))
- "Insert any symbols that the DIST rule should depend on.
-Argument THIS is the target that should insert stuff."
- (ede-proj-makefile-insert-dist-dependencies this)
- )
-
-(cl-defmethod ede-proj-makefile-automake-insert-subdirs ((this ede-proj-project))
- "Insert a SUBDIRS variable for Automake."
- (proj-comp-insert-variable-once "SUBDIRS"
- (ede-map-subprojects
- this (lambda (sproj)
- (insert " " (ede-subproject-relative-path sproj))
- ))))
-
-(cl-defmethod ede-proj-makefile-automake-insert-extradist ((_this ede-proj-project))
- "Insert the EXTRADIST variable entries needed for Automake and EDE."
- (proj-comp-insert-variable-once "EXTRA_DIST" (insert "Project.ede")))
-
-(cl-defmethod ede-proj-makefile-insert-dist-rules ((this ede-proj-project))
- "Insert distribution rules for THIS in a Makefile, such as CLEAN and DIST."
- (let ((junk (ede-proj-makefile-garbage-patterns this))
- tmp)
- ;; Build CLEAN, DIST, TAG, and other rules here.
- (if junk
- (insert "\nclean:\n"
- "\trm -f "
- (mapconcat (lambda (c) c) junk " ")
- "\n\n"))
- ;; @TODO: ^^^ Clean should also recurse. ^^^
-
- (insert ".PHONY: dist\n")
- (insert "\ndist:")
- (ede-proj-makefile-insert-dist-dependencies this)
- (insert "\n")
- (unless (or (ede-subproject-p this)
- (oref this metasubproject))
- ;; Only delete if we are the toplevel project.
- (insert "\trm -rf $(DISTDIR)\n"))
- (insert "\tmkdir $(DISTDIR)\n") ;We may need a -p, but I think not.
- (setq tmp (oref this targets))
- (insert "\tcp")
- (while tmp
- (let ((sv (ede-proj-makefile-sourcevar (car tmp))))
- (if (listp sv)
- ;; Handle special case variables.
- (cond ((eq (cdr sv) 'share)
- ;; This variable may be shared between multiple targets.
- (if (re-search-backward (concat "\\$(" (car sv) ")")
- (line-beginning-position) t)
- ;; If its already in the dist target, then skip it.
- nil
- (setq sv (car sv))))
- (t (setq sv (car sv)))))
- (if (stringp sv)
- (insert " $(" sv ")"))
- (ede-proj-makefile-insert-dist-filepatterns (car tmp))
- (setq tmp (cdr tmp))))
- (insert " $(ede_FILES) $(DISTDIR)\n")
-
- ;; Call our sub projects.
- (ede-map-subprojects
- this (lambda (sproj)
- (let ((rp (directory-file-name (ede-subproject-relative-path sproj))))
- (insert "\t$(MAKE) -C " rp " $(MFLAGS) DISTDIR=$(DISTDIR)/" rp
- " dist"
- "\n"))))
-
- ;; Tar up the stuff.
- (unless (or (ede-subproject-p this)
- (oref this metasubproject))
- (insert "\ttar -cvzf $(DISTDIR).tar.gz $(DISTDIR)\n"
- "\trm -rf $(DISTDIR)\n"))
-
- ;; Make sure the Makefile is ok.
- (insert "\n"
- (file-name-nondirectory (buffer-file-name)) ": "
- (file-name-nondirectory (oref this file)) "\n"
-;; "$(EMACS) -batch Project.ede -l ede -f ede-proj-regenerate"
- "\t@echo Makefile is out of date! "
- "It needs to be regenerated by EDE.\n"
- "\t@echo If you have not modified Project.ede, you can"
- (format-message
- " use `touch' to update the Makefile time stamp.\n")
- "\t@false\n\n"
- "\n\n# End of Makefile\n")))
-
-(cl-defmethod ede-proj-makefile-insert-rules ((_this ede-proj-target))
- "Insert rules needed by THIS target."
- nil)
-
-(cl-defmethod ede-proj-makefile-insert-rules ((this ede-proj-target-makefile))
- "Insert rules needed by THIS target."
- (mapc #'ede-proj-makefile-insert-rules (oref this rules))
- (let ((c (ede-proj-compilers this)))
- (when c
- (mapc #'ede-proj-makefile-insert-rules c)
- (if (oref this phony)
- (insert ".PHONY: " (ede-proj-makefile-target-name this) "\n"))
- (insert (ede-proj-makefile-target-name this) ": "
- (ede-proj-makefile-dependencies this) "\n")
- (ede-proj-makefile-insert-commands this)
- )))
-
-(cl-defmethod ede-proj-makefile-insert-commands ((this ede-proj-target-makefile))
- "Insert the commands needed by target THIS.
-For targets, insert the commands needed by the chosen compiler."
- (mapc #'ede-proj-makefile-insert-commands (ede-proj-compilers this))
- (when (object-assoc t :uselinker (ede-proj-compilers this))
- (mapc #'ede-proj-makefile-insert-commands (ede-proj-linkers this))))
-
-
-(cl-defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-project))
- "Insert user specified rules needed by THIS target.
-This is different from `ede-proj-makefile-insert-rules' in that this
-function won't create the building rules which are auto created with
-automake."
- (mapc #'ede-proj-makefile-insert-user-rules (oref this inference-rules)))
-
-(cl-defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-target))
- "Insert user specified rules needed by THIS target."
- (mapc #'ede-proj-makefile-insert-rules (oref this rules)))
-
-(cl-defmethod ede-proj-makefile-dependencies ((this ede-proj-target-makefile))
- "Return a string representing the dependencies for THIS.
-Some compilers only use the first element in the dependencies, others
-have a list of intermediates (object files), and others don't care.
-This allows customization of how these elements appear."
- (let* ((c (ede-proj-compilers this))
- (io (seq-some #'ede-compiler-intermediate-objects-p c))
- (out nil))
- (if io
- (progn
- (while c
- (setq out
- (concat out "$(" (ede-compiler-intermediate-object-variable
- (car c)
- (ede-proj-makefile-target-name this))
- ")")
- c (cdr c)))
- out)
- (let ((sv (ede-proj-makefile-sourcevar this))
- (aux (oref this auxsource)))
- (setq out
- (if (and (stringp sv) (not (string= sv "")))
- (concat "$(" sv ")")
- ""))
- (while aux
- (setq out (concat out " " (car aux)))
- (setq aux (cdr aux)))
- out))))
-
-;; Tags
-(cl-defmethod ede-proj-makefile-tags ((this ede-proj-project) targets)
- "Insert into the current location rules to make recursive TAGS files.
-Argument THIS is the project to create tags for.
-Argument TARGETS are the targets we should depend on for TAGS."
- (insert "tags: ")
- (let ((tg targets))
- ;; Loop over all source variables and insert them
- (while tg
- (insert "$(" (ede-proj-makefile-sourcevar (car tg)) ") ")
- (setq tg (cdr tg)))
- (insert "\n")
- (if targets
- (insert "\tetags $^\n"))
- ;; Now recurse into all subprojects
- (setq tg (oref this subproj))
- (while tg
- (insert "\t$(MAKE) -C " (ede-subproject-relative-path (car tg)) " $(MFLAGS) $@\n")
- (setq tg (cdr tg)))
- (insert "\n")))
-
-
-(provide 'ede/pmake)
-
-;;; ede/pmake.el ends here
+++ /dev/null
-;;; ede/proj-archive.el --- EDE Generic Project archive support -*- lexical-binding: t -*-
-
-;; Copyright (C) 1998-2001, 2009-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handle object code archives in and EDE Project file.
-
-(require 'ede/pmake)
-(require 'ede/proj-obj)
-
-;;; Code:
-
-(defclass ede-proj-target-makefile-archive
- (ede-proj-target-makefile-objectcode)
- ((availablelinkers :initform '(ede-archive-linker)))
- "This target generates an object code archive.")
-
-(defvar ede-archive-linker
- (ede-linker
- :name "ar"
- :variables '(("AR" . "ar")
- ("AR_CMD" . "$(AR) cr"))
- :commands '("$(AR_CMD) lib$@.a $^")
- :autoconf '(("AC_CHECK_PROGS" . "RANLIB, ranlib"))
- :objectextention "")
- "Linker object for creating an archive.")
-
-(cl-defmethod ede-proj-makefile-insert-source-variables :before
- ((this ede-proj-target-makefile-archive) &optional _moresource)
- "Insert bin_PROGRAMS variables needed by target THIS.
-We aren't actually inserting SOURCE details, but this is used by the
-Makefile.am generator, so use it to add this important bin program."
- (ede-pmake-insert-variable-shared
- (concat "lib" (ede-name this) "_a_LIBRARIES")
- (insert (concat "lib" (ede-name this) ".a"))))
-
-(cl-defmethod ede-proj-makefile-garbage-patterns
- ((this ede-proj-target-makefile-archive))
- "Add archive name to the garbage patterns.
-This makes sure that the archive is removed with `make clean'."
- (let ((garb (cl-call-next-method)))
- (append garb (list (concat "lib" (ede-name this) ".a")))))
-
-(provide 'ede/proj-archive)
-
-;;; ede/proj-archive.el ends here
+++ /dev/null
-;;; ede/proj-aux.el --- EDE Generic Project auxiliary file support -*- lexical-binding: t -*-
-
-;; Copyright (C) 1998-2000, 2007, 2009-2024 Free Software Foundation,
-;; Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handle auxiliary files (README, FAQ, etc) in and EDE Project file.
-
-(require 'ede/proj)
-(require 'ede/pmake)
-
-;;; Code:
-(defclass ede-proj-target-aux (ede-proj-target)
- ((sourcetype :initform '(ede-aux-source)))
- "This target consists of aux files such as READMEs and COPYING.")
-
-(defvar ede-aux-source
- (ede-sourcecode :name "Auxiliary Text"
- :sourcepattern "^[A-Z]+$\\|\\.txt$")
- "Miscellaneous fields definition.")
-
-(cl-defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-aux))
- "Return the variable name for THIS's sources."
- (concat (ede-pmake-varname this) "_AUX"))
-
-(provide 'ede/proj-aux)
-
-;;; ede/proj-aux.el ends here
+++ /dev/null
-;;; ede/proj-comp.el --- EDE Generic Project compiler/rule driver -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2001, 2004-2005, 2007, 2009-2024 Free Software
-;; Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This software handles the maintenance of compiler and rule definitions
-;; for different object types.
-;;
-;; The `ede-compiler' class lets different types of project objects create
-;; definitions of compilers that can be swapped in and out for compiling
-;; source code. Users can also define new compiler types whenever they
-;; some customized behavior.
-;;
-;; The `ede-makefile-rule' class lets users add customized rules into their
-;; objects, and also lets different compilers add chaining rules to their
-;; behaviors.
-;;
-;; It is important that all new compiler types be registered once. That
-;; way the chaining rules and variables are inserted into any given Makefile
-;; only once.
-;;
-;; To insert many compiler elements, wrap them in `ede-compiler-begin-unique'
-;; before calling their insert methods.
-;; To write a method that inserts a variable or rule for a compiler
-;; based object, wrap the body of your call in `ede-compiler-only-once'
-
-(require 'ede) ;source object
-(require 'ede/autoconf-edit)
-
-;;; Types:
-(defclass ede-compilation-program (eieio-instance-inheritor)
- ((name :initarg :name
- :type string
- :custom string
- :documentation "Name of this type of compiler.")
- (variables :initarg :variables
- :type list
- :custom (repeat (cons (string :tag "Variable")
- (string :tag "Value")))
- :documentation
- "Variables needed in the Makefile for this compiler.
-An assoc list where each element is (VARNAME . VALUE) where VARNAME
-is a string, and VALUE is either a string, or a list of strings.
-For example, GCC would define CC=gcc, and emacs would define EMACS=emacs.")
- (sourcetype :initarg :sourcetype
- :type list ;; of symbols
- :documentation
- "A list of `ede-sourcecode' objects this class will handle.
-This is used to match target objects with the compilers and linkers
-they can use, and which files this object is interested in."
- :accessor ede-object-sourcecode)
- (rules :initarg :rules
- :initform nil
- :type list
- :custom (repeat (object :objecttype ede-makefile-rule))
- :documentation
- "Auxiliary rules needed for this compiler to run.
-For example, yacc/lex files need additional chain rules, or inferences.")
- (commands :initarg :commands
- :type list
- :custom (repeat string)
- :documentation
- "The commands used to execute this compiler.
-The object which uses this compiler will place these commands after
-its rule definition.")
- (autoconf :initarg :autoconf
- :initform nil
- :type list
- :custom (repeat string)
- :documentation
- "Autoconf function to call if this type of compiler is used.
-When a project is in Automake mode, this defines the autoconf function to
-call to initialize automake to use this compiler.
-For example, there may be multiple C compilers, but they all probably
-use the same autoconf form.")
- (objectextention :initarg :objectextention
- :type string
- :documentation
- "A string which is the extension used for object files.
-For example, C code uses .o on Unix, and Emacs Lisp uses .elc.")
- )
- "A program used to compile or link a program via a Makefile.
-Contains everything needed to output code into a Makefile, or autoconf
-file.")
-
-(defclass ede-compiler (ede-compilation-program)
- ((makedepends :initarg :makedepends
- :initform nil
- :type boolean
- :documentation
- "Non-nil if this compiler can make dependencies.")
- (uselinker :initarg :uselinker
- :initform nil
- :type boolean
- :documentation
- "Non-nil if this compiler creates code that can be linked.
-This requires that the containing target also define a list of available
-linkers that can be used.")
- )
- "Definition for a compiler.
-Different types of objects will provide different compilers for
-different situations.")
-
-(defclass ede-linker (ede-compilation-program)
- ()
- "Contains information needed to link many generated object files together.")
-
-(defclass ede-makefile-rule ()
- ((target :initarg :target
- :initform ""
- :type string
- :custom string
- :documentation "The target pattern.
-A pattern of \"%.o\" is used for inference rules, and would match object files.
-A target of \"foo.o\" explicitly matches the file foo.o.")
- (dependencies :initarg :dependencies
- :initform ""
- :type string
- :custom string
- :documentation "Dependencies on this target.
-A pattern of \"%.o\" would match a file of the same prefix as the target
-if that target is also an inference rule pattern.
-A dependency of \"foo.c\" explicitly lists foo.c as a dependency.
-A variable such as $(name_SOURCES) will list all the source files
-belonging to the target name.")
- (rules :initarg :rules
- :initform nil
- :type list
- :custom (repeat string)
- :documentation "Scripts to execute.
-These scripts will be executed in sh (Unless the SHELL variable is overridden).
-Do not prefix with TAB.
-Each individual element of this list can be either a string, or
-a lambda function. (The custom element does not yet express that.")
- (phony :initarg :phony
- :initform nil
- :type boolean
- :custom boolean
- :documentation "Is this a phony rule?
-Adds this rule to a .PHONY list."))
- "A single rule for building some target.")
-
-;;; Code:
-(defvar ede-compiler-list nil
- "The master list of all EDE compilers.")
-
-(defvar ede-linker-list nil
- "The master list of all EDE compilers.")
-
-(defvar ede-current-build-list nil
- "List of EDE compilers that have already inserted parts of themselves.
-This is used when creating a Makefile to prevent duplicate variables and
-rules from being created.")
-
-(cl-defmethod initialize-instance :after ((this ede-compiler) &rest _fields)
- "Make sure that all ede compiler objects are cached in
-`ede-compiler-list'."
- (add-to-list 'ede-compiler-list this))
-
-(cl-defmethod initialize-instance :after ((this ede-linker) &rest _fields)
- "Make sure that all ede compiler objects are cached in
-`ede-linker-list'."
- (add-to-list 'ede-linker-list this))
-
-(defmacro ede-compiler-begin-unique (&rest body)
- "Execute BODY, making sure that `ede-current-build-list' is maintained.
-This will prevent rules from creating duplicate variables or rules."
- (declare (indent 0) (debug t))
- `(let ((ede-current-build-list nil))
- ,@body))
-
-(defmacro ede-compiler-only-once (object &rest body)
- "Using OBJECT, execute BODY only once per Makefile generation."
- (declare (indent 1) (debug t))
- `(if (not (member ,object ede-current-build-list))
- (progn
- (add-to-list 'ede-current-build-list ,object)
- ,@body)))
-
-(defmacro ede-linker-begin-unique (&rest body)
- "Execute BODY, making sure that `ede-current-build-list' is maintained.
-This will prevent rules from creating duplicate variables or rules."
- (declare (indent 0) (debug t))
- `(let ((ede-current-build-list nil))
- ,@body))
-
-(defmacro ede-linker-only-once (object &rest body)
- "Using OBJECT, execute BODY only once per Makefile generation."
- (declare (indent 1) (debug t))
- `(if (not (member ,object ede-current-build-list))
- (progn
- (add-to-list 'ede-current-build-list ,object)
- ,@body)))
-
-;;; Queries
-(defun ede-proj-find-compiler (compilers sourcetype)
- "Return a compiler from the list COMPILERS that will compile SOURCETYPE."
- (while (and compilers
- (not (member sourcetype (oref (car compilers) sourcetype))))
- (setq compilers (cdr compilers)))
- (car-safe compilers))
-
-(defun ede-proj-find-linker (linkers sourcetype)
- "Return a compiler from the list LINKERS to be used with SOURCETYPE."
- (while (and linkers
- (slot-boundp (car linkers) 'sourcetype)
- (not (member sourcetype (oref (car linkers) sourcetype))))
- (setq linkers (cdr linkers)))
- (car-safe linkers))
-
-;;; Methods:
-(cl-defmethod ede-proj-tweak-autoconf ((this ede-compilation-program))
- "Tweak the configure file (current buffer) to accommodate THIS."
- (mapcar
- (lambda (obj)
- (cond ((stringp obj)
- (autoconf-insert-new-macro obj))
- ((consp obj)
- (autoconf-insert-new-macro (car obj) (cdr obj)))
- (t (error "Autoconf directives must be a string, or cons cell")))
- )
- (oref this autoconf)))
-
-(cl-defmethod ede-proj-flush-autoconf ((_this ede-compilation-program))
- "Flush the configure file (current buffer) to accommodate THIS."
- nil)
-
-(defmacro proj-comp-insert-variable-once (varname &rest body)
- "Add VARNAME into the current Makefile if it doesn't exist.
-Execute BODY in a location where a value can be placed."
- (declare (indent 1) (debug (sexp body)))
- `(let ((v ,varname))
- (unless (re-search-backward (concat "^" v "\\s-*=") nil t)
- (insert v "=")
- ,@body
- (insert "\n")
- (goto-char (point-max)))))
-
-(cl-defmethod ede-proj-makefile-insert-variables ((this ede-compilation-program))
- "Insert variables needed by the compiler THIS."
- (if (eieio-instance-inheritor-slot-boundp this 'variables)
- (with-slots (variables) this
- (mapcar
- (lambda (var)
- (proj-comp-insert-variable-once (car var)
- (let ((cd (cdr var)))
- (if (listp cd)
- (mapc (lambda (c) (insert " " c)) cd)
- (insert cd)))))
- variables))))
-
-(cl-defmethod ede-compiler-intermediate-objects-p ((this ede-compiler))
- "Return non-nil if THIS has intermediate object files.
-If this compiler creates code that can be linked together,
-then the object files created by the compiler are considered intermediate."
- (oref this uselinker))
-
-(cl-defmethod ede-compiler-intermediate-object-variable ((_this ede-compiler)
- targetname)
- "Return a string based on THIS representing a make object variable.
-TARGETNAME is the name of the target that these objects belong to."
- (concat targetname "_OBJ"))
-
-(cl-defmethod ede-proj-makefile-insert-object-variables ((this ede-compiler)
- targetname sourcefiles)
- "Insert an OBJ variable to specify object code to be generated for THIS.
-The name of the target is TARGETNAME as a string. SOURCEFILES is the list of
-files to be objectified.
-Not all compilers do this."
- (if (ede-compiler-intermediate-objects-p this)
- (progn
- (insert (ede-compiler-intermediate-object-variable this targetname)
- "=")
- (let ((src (oref this sourcetype)))
- (mapc (lambda (s)
- (let ((ts src))
- (while (and ts (not (ede-want-file-source-p
- (symbol-value (car ts)) s)))
- (setq ts (cdr ts)))
- ;; Only insert the object if the given file is a major
- ;; source-code type.
- (if ts;; a match as a source file.
- (insert " " (file-name-sans-extension s)
- (oref this objectextention)))))
- sourcefiles)
- (insert "\n")))))
-
-(cl-defmethod ede-proj-makefile-insert-rules ((this ede-compilation-program))
- "Insert rules needed for THIS compiler object."
- (ede-compiler-only-once this
- (mapc #'ede-proj-makefile-insert-rules (oref this rules))))
-
-(cl-defmethod ede-proj-makefile-insert-rules ((this ede-makefile-rule))
- "Insert rules needed for THIS rule object."
- (if (oref this phony) (insert ".PHONY: " (oref this target) "\n"))
- (insert (oref this target) ": " (oref this dependencies) "\n\t"
- (mapconcat (lambda (c) c) (oref this rules) "\n\t")
- "\n\n"))
-
-(cl-defmethod ede-proj-makefile-insert-commands ((this ede-compilation-program))
- "Insert the commands needed to use compiler THIS.
-The object creating makefile rules must call this method for the
-compiler it decides to use after inserting in the rule."
- (when (slot-boundp this 'commands)
- (with-slots (commands) this
- (mapc
- (lambda (obj) (insert
- (if (bolp) "\t" " ")
- (cond ((stringp obj)
- obj)
- ((and (listp obj)
- (eq (car obj) 'lambda))
- (funcall obj))
- (t
- (format "%S" obj)))
- "\n"))
- commands))
- (insert "\n")))
-
-(provide 'ede/proj-comp)
-
-;;; ede/proj-comp.el ends here
+++ /dev/null
-;;; ede-proj-elisp.el --- EDE Generic Project Emacs Lisp support -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2005, 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handle Emacs Lisp in an EDE Project file.
-
-(require 'ede/proj)
-(require 'ede/pmake)
-(require 'ede/pconf)
-
-(autoload 'semantic-ede-proj-target-grammar "semantic/ede-grammar")
-
-;;; Code:
-(defclass ede-proj-target-elisp (ede-proj-target-makefile)
- ((menu :initform nil)
- (keybindings :initform nil)
- (phony :initform t)
- (sourcetype :initform '(ede-source-emacs))
- (availablecompilers :initform '(ede-emacs-compiler))
- (aux-packages :initarg :aux-packages
- :initform nil
- :type list
- :custom (repeat string)
- :documentation "Additional packages needed.
-There should only be one toplevel package per auxiliary tool needed.
-These packages location is found, and added to the compile time
-load path."
- )
- (pre-load-packages :initarg :pre-load-packages
- :initform nil
- :type list
- :custom (repeat string)
- :documentation "Additional packages to pre-load.
-Each package name will be loaded with `require'.
-Each package's directory should also appear in :aux-packages via a package name.")
- )
- "This target consists of a group of Lisp files.
-A Lisp target may be one general program with many separate Lisp files in it.")
-
-(cl-defmethod ede-proj-makefile-insert-rules :after ((this ede-proj-target-elisp))
- "Insert rules needed by THIS target.
-This inserts the PRELOADS target-local variable."
- (let ((preloads (oref this pre-load-packages)))
- (when preloads
- (insert (format "%s: PRELOADS=%s\n"
- (oref this name)
- (mapconcat #'identity preloads " ")))))
- (insert "\n"))
-
-(cl-defmethod ede-proj-makefile-dependencies ((this ede-proj-target-elisp))
- "Return a string representing the dependencies for THIS.
-Some compilers only use the first element in the dependencies, others
-have a list of intermediates (object files), and others don't care.
-This allows customization of how these elements appear.
-For Emacs Lisp, return addsuffix command on source files."
- (format "$(addsuffix c, $(%s))"
- (ede-proj-makefile-sourcevar this)))
-
-(defvar ede-source-emacs
- (ede-sourcecode :name "Emacs Lisp"
- :sourcepattern "\\.el$"
- :garbagepattern '("*.elc"))
- "Emacs Lisp source code definition.")
-
-(defvar ede-emacs-compiler
- (ede-compiler
- :name "emacs"
- :variables '(("EMACS" . "emacs")
- ("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'")
- ("require" . "$(foreach r,$(1),(require (quote $(r))))"))
- :rules (list (ede-makefile-rule
- :target "%.elc"
- :dependencies "%.el"
- :rules '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \
---eval '(progn $(call require, $(PRELOADS)))' -f batch-byte-compile $^")))
- :autoconf '("AM_PATH_LISPDIR")
- :sourcetype '(ede-source-emacs)
- :objectextention ".elc"
- )
- "Compile Emacs Lisp programs.")
-
-(defvar ede-xemacs-compiler
- (clone ede-emacs-compiler
- :name "xemacs"
- :variables '(("EMACS" . "xemacs")))
- "Compile Emacs Lisp programs with XEmacs.")
-(make-obsolete-variable 'ede-xemacs-compiler 'ede-emacs-compiler "28.1")
-
-;;; Claiming files
-(cl-defmethod ede-buffer-mine ((this ede-proj-target-elisp) buffer)
- "Return t if object THIS lays claim to the file in BUFFER.
-Lays claim to all .elc files that match .el files in this target."
- (if (string-match "\\.elc$" (buffer-file-name buffer))
- (let ((fname
- (concat
- (file-name-sans-extension (buffer-file-name buffer))
- ".el")
- ))
- ;; Is this in our list.
- (member fname (oref this auxsource))
- )
- (cl-call-next-method) ; The usual thing.
- ))
-
-;;; Emacs Lisp Compiler
-;;; Emacs Lisp Target
-(defun ede-proj-elisp-packages-to-loadpath (packages)
- "Convert a list of PACKAGES, to a list of load path."
- (let ((paths nil)
- (ldir nil))
- (while packages
- (or (setq ldir (locate-library (car packages)))
- (error "Cannot find package %s" (car packages)))
- (let* ((fnd (file-name-directory ldir))
- (rel (file-relative-name fnd))
- (full nil)
- )
- ;; Make sure the relative name isn't to far off
- (when (string-match "^\\.\\./\\.\\./\\.\\./\\.\\./\\.\\." rel)
- (setq full fnd))
- ;; Do the setup.
- (setq paths (cons (or full rel) paths)
- packages (cdr packages))))
- paths))
-
-(cl-defmethod project-compile-target ((obj ede-proj-target-elisp))
- "Compile all sources in a Lisp target OBJ.
-Bonus: Return a cons cell: (COMPILED . UPTODATE)."
- (let* ((proj (ede-target-parent obj))
- (dir (oref proj directory))
- (comp 0)
- (utd 0))
- (mapc (lambda (src)
- (let* ((fsrc (expand-file-name src dir))
- ) ;; (elc (concat (file-name-sans-extension fsrc) ".elc"))
- (with-no-warnings
- (if (eq (byte-recompile-file fsrc nil 0) t)
- (setq comp (1+ comp))
- (setq utd (1+ utd))))))
-
- (oref obj source))
- (message "All Emacs Lisp sources are up to date in %s" (eieio-object-name obj))
- (cons comp utd)))
-
-(cl-defmethod ede-update-version-in-source ((this ede-proj-target-elisp) version)
- "In a Lisp file, updated a version string for THIS to VERSION.
-There are standards in Elisp files specifying how the version string
-is found, such as a `-version' variable, or the standard header."
- (if (and (slot-boundp this 'versionsource)
- (oref this versionsource))
- (let ((vs (oref this versionsource))
- ) ;; (match nil)
- (while vs
- (with-current-buffer (find-file-noselect
- (ede-expand-filename this (car vs)))
- (goto-char (point-min))
- (let ((case-fold-search t))
- (if (re-search-forward "-version\\s-+\"\\([^\"]+\\)\"" nil t)
- (progn
- ;; (setq match t)
- (delete-region (match-beginning 1)
- (match-end 1))
- (goto-char (match-beginning 1))
- (insert version)))))
- (setq vs (cdr vs)))
- ;; The next method will include comments such as "Version:"
- (cl-call-next-method))))
-
-
-;;; Makefile generation functions
-;;
-(cl-defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-elisp))
- "Return the variable name for THIS's sources."
- (cond ((ede-proj-automake-p) '("lisp_LISP" . share))
- (t (concat (ede-pmake-varname this) "_LISP"))))
-
-(defun ede-proj-makefile-insert-loadpath-items (items)
- "Insert a sequence of ITEMS into the Makefile LOADPATH variable."
- (when items
- (ede-pmake-insert-variable-shared "LOADPATH"
- (let ((begin (save-excursion (re-search-backward "\\s-*="))))
- (while items
- (when (not (save-excursion
- (re-search-backward
- (concat "\\s-" (regexp-quote (car items)) "[ \n\t\\]")
- begin t)))
- (insert " " (car items)))
- (setq items (cdr items)))))
- ))
-
-(cl-defmethod ede-proj-makefile-insert-variables :after ((this ede-proj-target-elisp))
- "Insert variables needed by target THIS."
- (let ((newitems (if (oref this aux-packages)
- (ede-proj-elisp-packages-to-loadpath
- (oref this aux-packages)))))
- (ede-proj-makefile-insert-loadpath-items newitems)))
-
-(defun ede-proj-elisp-add-path (path)
- "Add path PATH into the file if it isn't already there."
- (goto-char (point-min))
- (if (re-search-forward (concat "(cons \\\""
- (regexp-quote path))
- nil t)
- nil;; We have it already
- (if (re-search-forward "(cons nil" nil t)
- (progn
- ;; insert stuff here
- (end-of-line)
- (insert "\n"
- " echo \"(setq load-path (cons \\\""
- path
- "\\\" load-path))\" >> script")
- )
- (error "Don't know how to update load path"))))
-
-(cl-defmethod ede-proj-tweak-autoconf ((this ede-proj-target-elisp))
- "Tweak the configure file (current buffer) to accommodate THIS."
- (cl-call-next-method)
- ;; Ok, now we have to tweak the autoconf provided `elisp-comp' program.
- (let ((ec (ede-expand-filename this "elisp-comp" 'newfile))
- (enable-local-variables nil))
- (if (or (not ec) (not (file-exists-p ec)))
- (message "No elisp-comp file. There may be compile errors? Rerun a second time.")
- (save-excursion
- (if (file-symlink-p ec)
- (progn
- ;; Change symlinks to copies.
- (rename-file ec (concat ec ".tmp"))
- (copy-file (concat ec ".tmp") ec)
- (delete-file (concat ec ".tmp"))))
- (set-buffer (find-file-noselect ec t))
- (ede-proj-elisp-add-path "..")
- (let ((paths (ede-proj-elisp-packages-to-loadpath
- (oref this aux-packages))))
- ;; Add in the current list of paths
- (while paths
- (ede-proj-elisp-add-path (car paths))
- (setq paths (cdr paths))))
- (save-buffer)
- (kill-buffer)))))
-
-(cl-defmethod ede-proj-flush-autoconf ((this ede-proj-target-elisp))
- "Flush the configure file (current buffer) to accommodate THIS."
- ;; Remove crufty old paths from elisp-compile
- (let ((ec (ede-expand-filename this "elisp-comp" 'newfile))
- (enable-local-variables nil))
- (if (and ec (file-exists-p ec))
- (with-current-buffer (find-file-noselect ec t)
- (goto-char (point-min))
- (while (re-search-forward "(cons \\([^ ]+\\) load-path)"
- nil t)
- (let ((path (match-string 1)))
- (if (string= path "nil")
- nil
- (delete-region (line-beginning-position)
- (line-beginning-position 2)))))))))
-
-;;;
-;; Autoload generators
-;;
-(defclass ede-proj-target-elisp-autoloads (ede-proj-target-elisp)
- ((availablecompilers :initform '(ede-emacs-cedet-autogen-compiler))
- (phony :initform t)
- (rules :initform nil)
- (autoload-file :initarg :autoload-file
- :initform "loaddefs.el"
- :type string
- :custom string
- :documentation "The file that autoload definitions are placed in.
-There should be one load defs file for a given package. The load defs are created
-for all Emacs Lisp sources that exist in the directory of the created target.")
- (autoload-dirs :initarg :autoload-dirs
- :initform nil
- :type list
- :custom (repeat string)
- :documentation "The directories to scan for autoload definitions.
-If nil defaults to the current directory.")
- )
- "Target that builds an autoload file.
-Files do not need to be added to this target.")
-
-
-;;; Claiming files
-(cl-defmethod ede-buffer-mine ((this ede-proj-target-elisp-autoloads) buffer)
- "Return t if object THIS lays claim to the file in BUFFER.
-Lays claim to all .elc files that match .el files in this target."
- (if (string-match
- (concat (regexp-quote (oref this autoload-file)) "$")
- (buffer-file-name buffer))
- t
- (cl-call-next-method) ; The usual thing.
- ))
-
-;; Compilers
-(defvar ede-emacs-cedet-autogen-compiler
- (ede-compiler
- :name "emacs"
- :variables '(("EMACS" . "emacs")
- ("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'")
- ("require" . "$(foreach r,$(1),(require (quote $(r))))"))
- :commands
- '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \
--f loaddefs-generate-batch $(abspath $(LOADDEFS)) $(abspath $(LOADDIRS))")
- :rules (list (ede-makefile-rule :target "clean-autoloads" :phony t :rules '("rm -f $(LOADDEFS)")))
- :sourcetype '(ede-source-emacs)
- )
- "Build an autoloads file.")
-
-(cl-defmethod ede-proj-compilers ((obj ede-proj-target-elisp-autoloads))
- "List of compilers being used by OBJ.
-If the `compiler' slot is empty, get the car of the compilers list."
- (let ((comp (oref obj compiler)))
- (if comp
- (setq comp (if (listp comp)
- (mapcar #'symbol-value comp)
- (list (symbol-value comp))))
- ;; Get the first element from our list of compilers.
- (let ((avail (mapcar #'symbol-value (oref obj availablecompilers))))
- (setq comp (list (car avail)))))
- comp))
-
-(cl-defmethod ede-proj-makefile-insert-source-variables ((_this ede-proj-target-elisp-autoloads)
- &optional
- _moresource)
- "Insert the source variables needed by THIS.
-Optional argument MORESOURCE is a list of additional sources to add to the
-sources variable."
- nil)
-
-(cl-defmethod ede-proj-makefile-sourcevar ((_this ede-proj-target-elisp-autoloads))
- "Return the variable name for THIS's sources."
- nil) ; "LOADDEFS")
-
-(cl-defmethod ede-proj-makefile-dependencies ((_this ede-proj-target-elisp-autoloads))
- "Return a string representing the dependencies for THIS.
-Always return an empty string for an autoloads generator."
- "")
-
-(cl-defmethod ede-proj-makefile-insert-variables :after ((this ede-proj-target-elisp-autoloads))
- "Insert variables needed by target THIS."
- (ede-pmake-insert-variable-shared "LOADDEFS"
- (insert (oref this autoload-file)))
- (ede-pmake-insert-variable-shared "LOADDIRS"
- (insert (mapconcat #'identity
- (or (oref this autoload-dirs) '("."))
- " ")))
- )
-
-(cl-defmethod project-compile-target ((obj ede-proj-target-elisp-autoloads))
- "Create or update the autoload target."
- (require 'cedet-autogen) ;FIXME: We don't have this file!
- (declare-function cedet-update-autoloads "cedet-autogen")
- (let ((default-directory (ede-expand-filename obj ".")))
- (apply #'cedet-update-autoloads
- (oref obj autoload-file)
- (oref obj autoload-dirs))
- ))
-
-(cl-defmethod ede-update-version-in-source ((_this ede-proj-target-elisp-autoloads) _version)
- "In a Lisp file, updated a version string for THIS to VERSION.
-There are standards in Elisp files specifying how the version string
-is found, such as a `-version' variable, or the standard header."
- nil)
-
-(cl-defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target-elisp-autoloads))
- "Insert any symbols that the DIST rule should depend on.
-Emacs Lisp autoload files ship the generated .el files.
-Argument THIS is the target which needs to insert an info file."
- ;; In some cases, this is ONLY the index file. That should generally
- ;; be ok.
- (insert " " (ede-proj-makefile-target-name this))
- )
-
-(cl-defmethod ede-proj-makefile-insert-dist-filepatterns ((this ede-proj-target-elisp-autoloads))
- "Insert any symbols that the DIST rule should distribute.
-Emacs Lisp autoload files ship the generated .el files.
-Argument THIS is the target which needs to insert an info file."
- (insert " " (oref this autoload-file))
- )
-
-(cl-defmethod ede-proj-tweak-autoconf ((_this ede-proj-target-elisp-autoloads))
- "Tweak the configure file (current buffer) to accommodate THIS."
- (error "Autoloads not supported in autoconf yet"))
-
-(cl-defmethod ede-proj-flush-autoconf ((_this ede-proj-target-elisp-autoloads))
- "Flush the configure file (current buffer) to accommodate THIS."
- nil)
-
-(provide 'ede/proj-elisp)
-
-;;; ede/proj-elisp.el ends here
+++ /dev/null
-;;; ede-proj-info.el --- EDE Generic Project texinfo support -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handle texinfo in and EDE Project file.
-
-(require 'ede/pmake)
-
-;;; Code:
-(defclass ede-proj-target-makefile-info (ede-proj-target-makefile)
- ((menu :initform nil)
- (keybindings :initform nil)
- (availablecompilers :initform '(ede-makeinfo-compiler
- ede-texi2html-compiler))
- (sourcetype :initform '(ede-makeinfo-source))
- (mainmenu :initarg :mainmenu
- :initform ""
- :type string
- :custom string
- :documentation "The main menu resides in this file.
-All other sources should be included independently."))
- "Target for a single info file.")
-
-(defvar ede-makeinfo-source
- (ede-sourcecode :name "Texinfo"
- :sourcepattern "\\.texi?$"
- :garbagepattern '("*.info*" "*.html"))
- "Texinfo source code definition.")
-
-(defvar ede-makeinfo-compiler
- (ede-compiler
- :name "makeinfo"
- :variables '(("MAKEINFO" . "makeinfo"))
- :commands '("$(MAKEINFO) $<")
- :autoconf '(("AC_CHECK_PROG" . "MAKEINFO, makeinfo"))
- :sourcetype '(ede-makeinfo-source)
- )
- "Compile texinfo files into info files.")
-
-(defvar ede-texi2html-compiler
- (ede-compiler
- :name "texi2html"
- :variables '(("TEXI2HTML" . "makeinfo -html"))
- :commands '("makeinfo -o $@ $<")
- :sourcetype '(ede-makeinfo-source)
- )
- "Compile texinfo files into html files.")
-
-;;; Makefile generation
-;;
-(cl-defmethod ede-proj-configure-add-missing
- ((_this ede-proj-target-makefile-info))
- "Query if any files needed by THIS provided by automake are missing.
-Results in --add-missing being passed to automake."
- (not (ede-expand-filename (ede-toplevel) "texinfo.tex")))
-
-(cl-defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-makefile-info))
- "Return the variable name for THIS's sources."
- (concat (ede-pmake-varname this) "_TEXINFOS"))
-
-(cl-defmethod ede-proj-makefile-insert-source-variables
- ((this ede-proj-target-makefile-info) &optional moresource)
- "Insert the source variables needed by THIS info target.
-Optional argument MORESOURCE is a list of additional sources to add to the
-sources variable.
-Does the usual for Makefile mode, but splits source into two variables
-when working in Automake mode."
- (if (not (ede-proj-automake-p))
- (cl-call-next-method)
- (let* ((sv (ede-proj-makefile-sourcevar this))
- (src (copy-sequence (oref this source)))
- (menu (or (oref this menu) (car src))))
- (setq src (delq menu src))
- ;; the info_TEXINFOS variable is probably shared
- (ede-pmake-insert-variable-shared "info_TEXINFOS"
- (insert menu))
- ;; Now insert the rest of the source elsewhere
- (ede-pmake-insert-variable-shared sv
- (insert (mapconcat #'identity src " ")))
- (if moresource
- (error "Texinfo files should not have moresource")))))
-
-(defun ede-makeinfo-find-info-filename (source)
- "Find the info filename produced by SOURCE texinfo file."
- (let ((opened (get-file-buffer source))
- (buffer (or (get-file-buffer source)
- (find-file-noselect source nil t)))
- info)
- (with-current-buffer buffer
- (save-excursion
- (goto-char (point-min))
- (and (re-search-forward "^@setfilename\\s-+\\([^.]+\\).info$" nil t)
- (setq info (match-string 1)))))
- (unless (eq buffer opened)
- (kill-buffer buffer))
- info))
-
-(cl-defmethod ede-proj-makefile-target-name ((this ede-proj-target-makefile-info))
- "Return the name of the main target for THIS target."
- ;; The target should be the main-menu file name translated to .info.
- (let* ((source (if (not (string= (oref this mainmenu) ""))
- (oref this mainmenu)
- (car (oref this source))))
- (info (ede-makeinfo-find-info-filename source)))
- (concat (or info (file-name-sans-extension source)) ".info")))
-
-(cl-defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target-makefile-info))
- "Insert any symbols that the DIST rule should depend on.
-Texinfo files want to insert generated `.info' files.
-Argument THIS is the target which needs to insert an info file."
- ;; In some cases, this is ONLY the index file. That should generally
- ;; be ok.
- (insert " " (ede-proj-makefile-target-name this))
- )
-
-(cl-defmethod ede-proj-makefile-insert-dist-filepatterns ((this ede-proj-target-makefile-info))
- "Insert any symbols that the DIST rule should depend on.
-Texinfo files want to insert generated `.info' files.
-Argument THIS is the target which needs to insert an info file."
- ;; In some cases, this is ONLY the index file. That should generally
- ;; be ok.
- (insert " " (ede-proj-makefile-target-name this) "*")
- )
-
-; (let ((n (ede-name this)))
-; (if (string-match "\\.info$" n)
-; n
-; (concat n ".info"))))
-
-(cl-defmethod object-write ((this ede-proj-target-makefile-info))
- "Before committing any change to THIS, make sure the mainmenu is first."
- (let ((mm (oref this mainmenu))
- (s (oref this source))
- (nl nil))
- (if (or (string= mm "") (not mm) (string= mm (car s)))
- nil
- ;; Make sure that MM is first in the list of items.
- (setq nl (cons mm (delq mm s)))
- (oset this source nl)))
- (cl-call-next-method))
-
-(cl-defmethod ede-documentation ((this ede-proj-target-makefile-info))
- "Return a list of files that provides documentation.
-Documentation is not for object THIS, but is provided by THIS for other
-files in the project."
- (let* ((src (oref this source))
- (proj (ede-target-parent this))
- (dir (oref proj directory))
- (out nil)
- )
- ;; convert src to full file names.
- (while src
- (setq out (cons
- (expand-file-name (car src) dir)
- out))
- (setq src (cdr src)))
- ;; Return it
- out))
-
-(provide 'ede/proj-info)
-
-;;; ede/proj-info.el ends here
+++ /dev/null
-;;; ede-proj-misc.el --- EDE Generic Project Emacs Lisp support -*- lexical-binding: t -*-
-
-;; Copyright (C) 1998-2001, 2008-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handle miscellaneous compilable projects in and EDE Project file.
-;; This misc target lets the user link in custom makefiles to an EDE
-;; project.
-
-(require 'ede/pmake)
-(require 'ede/proj-comp)
-
-;;; Code:
-
-;; FIXME this isn't how you spell "miscellaneous". :(
-(defclass ede-proj-target-makefile-miscelaneous (ede-proj-target-makefile)
- ((sourcetype :initform '(ede-misc-source))
- (availablecompilers :initform '(ede-misc-compile))
- (submakefile :initarg :submakefile
- :initform ""
- :type string
- :custom string
- :documentation
- "Miscellaneous sources which have a specialized makefile.
-The sub-makefile is used to build this target.")
- )
- "Miscellaneous target type.
-A user-written makefile is used to build this target.
-All listed sources are included in the distribution.")
-
-(defvar ede-misc-source
- (ede-sourcecode :name "Miscellaneous"
- :sourcepattern ".*")
- "Miscellaneous field definition.")
-
-(defvar ede-misc-compile
- (ede-compiler :name "Sub Makefile"
- :commands
- '(
- )
- :autoconf nil
- :sourcetype '(ede-misc-source)
- )
- "Compile code via a sub-makefile.")
-
-(cl-defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-makefile-miscelaneous))
- "Return the variable name for THIS's sources."
- (concat (ede-pmake-varname this) "_MISC"))
-
-(cl-defmethod ede-proj-makefile-dependency-files
- ((this ede-proj-target-makefile-miscelaneous))
- "Return a list of files which THIS target depends on."
- (with-slots (submakefile) this
- (cond ((string= submakefile "")
- nil)
- ((not submakefile)
- nil)
- (t (list submakefile)))))
-
-(cl-defmethod ede-proj-makefile-insert-rules ((this ede-proj-target-makefile-miscelaneous))
- "Create the make rule needed to create an archive for THIS."
- ;; DO NOT call the next method. We will never have any compilers,
- ;; or any dependencies, or stuff like this. This rule will let us
- ;; deal with it in a nice way.
- (insert (ede-name this) ": ")
- (with-slots (submakefile) this
- (if (string= submakefile "")
- (insert "\n\t@\n\n")
- (insert submakefile "\n" "\t$(MAKE) -f " submakefile "\n\n"))))
-
-(provide 'ede/proj-misc)
-
-;;; ede/proj-misc.el ends here
+++ /dev/null
-;;; ede/proj-obj.el --- EDE Generic Project Object code generation support -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handles a superclass of target types which create object code in
-;; and EDE Project file.
-
-(require 'ede/proj)
-(declare-function ede-pmake-varname "ede/pmake")
-
-(defvar ede-proj-objectcode-dodependencies nil
- "Flag specifies to do automatic dependencies.")
-
-;;; Code:
-(defclass ede-proj-target-makefile-objectcode (ede-proj-target-makefile)
- (;; Give this a new default
- (configuration-variables :initform '("debug" . (("CFLAGS" . "-g")
- ("LDFLAGS" . "-g"))))
- ;; @TODO - add an include path.
- (availablecompilers :initform '(ede-gcc-compiler
- ede-g++-compiler
- ede-gfortran-compiler
- ede-gfortran-module-compiler
- ede-lex-compiler
- ede-yacc-compiler
- ;; More C and C++ compilers, plus
- ;; fortran or pascal can be added here
- ))
- (availablelinkers :initform '(ede-g++-linker
- ede-cc-linker
- ede-ld-linker
- ede-gfortran-linker
- ;; Add more linker thingies here.
- ))
- (sourcetype :initform '(ede-source-c
- ede-source-c++
- ede-source-f77
- ede-source-f90
- ede-source-lex
- ede-source-yacc
- ;; ede-source-other
- ;; This object should take everything that
- ;; gets compiled into objects like fortran
- ;; and pascal.
- ))
- )
- "Abstract class for Makefile based object code generating targets.
-Belonging to this group assumes you could make a .o from an element source
-file.")
-
-(defclass ede-object-compiler (ede-compiler)
- ((uselinker :initform t)
- (dependencyvar :initarg :dependencyvar
- :type list
- :custom (cons (string :tag "Variable")
- (string :tag "Value"))
- :documentation
- "A variable dedicated to dependency generation."))
- "Ede compiler class for source which must compiler, and link.")
-
-;;; C/C++ Compilers and Linkers
-;;
-(defvar ede-source-c
- (ede-sourcecode :name "C"
- :sourcepattern "\\.c$"
- :auxsourcepattern "\\.h$"
- :garbagepattern '("*.o" "*.obj" ".deps/*.P" ".lo"))
- "C source code definition.")
-
-(defvar ede-gcc-compiler
- (ede-object-compiler
- :name "gcc"
- :dependencyvar '("C_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P")
- :variables '(("CC" . "gcc")
- ("C_COMPILE" .
- "$(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)"))
- :rules (list (ede-makefile-rule
- :target "%.o"
- :dependencies "%.c"
- :rules '("@echo '$(C_COMPILE) -c $<'; \\"
- "$(C_COMPILE) $(C_DEPENDENCIES) -o $@ -c $<"
- )
- ))
- :autoconf '("AC_PROG_CC" "AC_PROG_GCC_TRADITIONAL")
- :sourcetype '(ede-source-c)
- :objectextention ".o"
- :makedepends t
- :uselinker t)
- "Compiler for C sourcecode.")
-
-(defvar ede-cc-linker
- (ede-linker
- :name "cc"
- :sourcetype '(ede-source-c)
- :variables '(("C_LINK" . "$(CC) $(CFLAGS) $(LDFLAGS) -L."))
- :commands '("$(C_LINK) -o $@ $^ $(LDDEPS)")
- :objectextention "")
- "Linker for C sourcecode.")
-
-(defvar ede-source-c++
- (ede-sourcecode :name "C++"
- :sourcepattern "\\.\\(c\\(pp?\\|c\\|xx\\|++\\)\\|C\\(PP\\)?\\)$"
- :auxsourcepattern "\\.\\(hpp?\\|hh?\\|hxx\\|H\\)$"
- :garbagepattern '("*.o" "*.obj" ".deps/*.P" ".lo"))
- "C++ source code definition.")
-
-(defvar ede-g++-compiler
- (ede-object-compiler
- :name "g++"
- :dependencyvar '("CXX_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P")
- :variables '(("CXX" "g++")
- ("CXX_COMPILE" .
- "$(CXX) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)")
- )
- :rules (list (ede-makefile-rule
- :target "%.o"
- :dependencies "%.cpp"
- :rules '("@echo '$(CXX_COMPILE) -c $<'; \\"
- "$(CXX_COMPILE) $(CXX_DEPENDENCIES) -o $@ -c $<"
- )
- ))
- :autoconf '("AC_PROG_CXX")
- :sourcetype '(ede-source-c++)
- :objectextention ".o"
- :makedepends t
- :uselinker t)
- "Compiler for C sourcecode.")
-
-(defvar ede-g++-linker
- (ede-linker
- :name "g++"
- ;; Only use this linker when c++ exists.
- :sourcetype '(ede-source-c++)
- :variables '(("CXX_LINK" . "$(CXX) $(CFLAGS) $(LDFLAGS) -L."))
- :commands '("$(CXX_LINK) -o $@ $^ $(LDDEPS)")
- :autoconf '("AC_PROG_CXX")
- :objectextention "")
- "Linker needed for c++ programs.")
-
-;;; LEX
-(defvar ede-source-lex
- (ede-sourcecode :name "lex"
- :sourcepattern "\\.l\\(l\\|pp\\|++\\)")
- "Lex source code definition.
-No garbage pattern since it creates C or C++ code.")
-
-(defvar ede-lex-compiler
- (ede-object-compiler
- ;; Can we support regular makefiles too??
- :autoconf '("AC_PROG_LEX")
- :sourcetype '(ede-source-lex))
- "Compiler used for Lexical source.")
-
-;;; YACC
-(defvar ede-source-yacc
- (ede-sourcecode :name "yacc"
- :sourcepattern "\\.y\\(y\\|pp\\|++\\)")
- "Yacc source code definition.
-No garbage pattern since it creates C or C++ code.")
-
-(defvar ede-yacc-compiler
- (ede-object-compiler
- ;; Can we support regular makefiles too??
- :autoconf '("AC_PROG_YACC")
- :sourcetype '(ede-source-yacc))
- "Compiler used for yacc/bison grammar files source.")
-
-;;; Fortran Compiler/Linker
-;;
-;; Contributed by David Engster
-(defvar ede-source-f90
- (ede-sourcecode :name "Fortran 90/95"
- :sourcepattern "\\.[fF]9[05]$"
- :auxsourcepattern "\\.incf$"
- :garbagepattern '("*.o" "*.mod" ".deps/*.P"))
- "Fortran 90/95 source code definition.")
-
-(defvar ede-source-f77
- (ede-sourcecode :name "Fortran 77"
- :sourcepattern "\\.\\([fF]\\|for\\)$"
- :auxsourcepattern "\\.incf$"
- :garbagepattern '("*.o" ".deps/*.P"))
- "Fortran 77 source code definition.")
-
-(defvar ede-gfortran-compiler
- (ede-object-compiler
- :name "gfortran"
- :dependencyvar '("F90_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P")
- :variables '(("F90" . "gfortran")
- ("F90_COMPILE" .
- "$(F90) $(DEFS) $(INCLUDES) $(F90FLAGS)"))
- :rules (list (ede-makefile-rule
- :target "%.o"
- :dependencies "%.f90"
- :rules '("@echo '$(F90_COMPILE) -c $<'; \\"
- "$(F90_COMPILE) $(F90_DEPENDENCIES) -o $@ -c $<"
- )
- ))
- :sourcetype '(ede-source-f90 ede-source-f77)
- :objectextention ".o"
- :makedepends t
- :uselinker t)
- "Compiler for Fortran sourcecode.")
-
-(defvar ede-gfortran-module-compiler
- (clone ede-gfortran-compiler
- :name "gfortranmod"
- :sourcetype '(ede-source-f90)
- :commands '("$(F90_COMPILE) -c $^")
- :objectextention ".mod"
- :uselinker nil)
- "Compiler for Fortran 90/95 modules.")
-
-
-(defvar ede-gfortran-linker
- (ede-linker
- :name "gfortran"
- :sourcetype '(ede-source-f90 ede-source-f77)
- :variables '(("F90_LINK" . "$(F90) $(CFLAGS) $(LDFLAGS) -L."))
- :commands '("$(F90_LINK) -o $@ $^")
- :objectextention "")
- "Linker needed for Fortran programs.")
-
-;;; Generic Linker
-;;
-(defvar ede-ld-linker
- (ede-linker
- :name "ld"
- :variables '(("LD" . "ld")
- ("LD_LINK" . "$(LD) $(LDFLAGS) -L."))
- :commands '("$(LD_LINK) -o $@ $^ $(LDDEPS)")
- :objectextention "")
- "Linker needed for c++ programs.")
-
-;;; The EDE object compiler
-;;
-(cl-defmethod ede-proj-makefile-insert-variables ((this ede-object-compiler))
- "Insert variables needed by the compiler THIS."
- (cl-call-next-method)
- (if (eieio-instance-inheritor-slot-boundp this 'dependencyvar)
- (with-slots (dependencyvar) this
- (insert (car dependencyvar) "=")
- (let ((cd (cdr dependencyvar)))
- (if (listp cd)
- (mapc (lambda (c) (insert " " c)) cd)
- (insert cd))
- (insert "\n")))))
-
-;;; EDE Object target type methods
-;;
-(cl-defmethod ede-proj-makefile-sourcevar
- ((this ede-proj-target-makefile-objectcode))
- "Return the variable name for THIS's sources."
- (require 'ede/pmake)
- (concat (ede-pmake-varname this) "_SOURCES"))
-
-(cl-defmethod ede-proj-makefile-dependency-files
- ((this ede-proj-target-makefile-objectcode))
- "Return a list of source files to convert to dependencies.
-Argument THIS is the target to get sources from."
- (append (oref this source) (oref this auxsource)))
-
-(cl-defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile-objectcode)
- &optional _moresource)
- "Insert variables needed by target THIS.
-Optional argument MORESOURCE is not used."
- (let ((ede-proj-objectcode-dodependencies
- (oref (ede-target-parent this) automatic-dependencies)))
- (cl-call-next-method)))
-
-(cl-defmethod ede-buffer-header-file ((this ede-proj-target-makefile-objectcode)
- _buffer)
- "There are no default header files."
- (or (cl-call-next-method)
- ;; Ok, nothing obvious. Try looking in ourselves.
- (let ((h (oref this auxsource)))
- ;; Add more logic here when the problem is better understood.
- (car-safe h))))
-
-(provide 'ede/proj-obj)
-
-;;; ede/proj-obj.el ends here
+++ /dev/null
-;;; ede-proj-prog.el --- EDE Generic Project program support -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2001, 2005, 2008-2024 Free Software Foundation,
-;; Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handle building programs from object files in and EDE Project file.
-
-(require 'ede/pmake)
-(require 'ede/proj-obj)
-
-(declare-function ede-shell-run-something "ede/shell")
-
-;;; Code:
-(defclass ede-proj-target-makefile-program
- (ede-proj-target-makefile-objectcode)
- ((ldlibs-local :initarg :ldlibs-local
- :initform nil
- :type list
- :custom (repeat (string :tag "Local Library"))
- :documentation
- "Libraries that are part of this project.
-The full path to these libraries should be specified, such as:
-../lib/libMylib.la or ../ar/myArchive.a
-
-Note: Currently only used for Automake projects."
- )
- (ldflags :initarg :ldflags
- :initform nil
- :type list
- :custom (repeat (string :tag "Link Flag"))
- :documentation
- "Additional flags to add when linking this target.
-Use this to specify specific options to the linker.
-A Common use may be to add -L to specify in-project locations of libraries
-specified with ldlibs.")
- (ldlibs :initarg :ldlibs
- :initform nil
- :type list
- :custom (repeat (string :tag "Library"))
- :documentation
- "Libraries, such as \"m\" or \"Xt\" which this program depends on.
-The linker flag \"-l\" is automatically prepended. Do not include a \"lib\"
-prefix, or a \".so\" suffix.
-Use the `ldflags' slot to specify where in-project libraries might be.
-
-Note: Currently only used for Automake projects."
- )
- )
- "This target is an executable program.")
-
-(cl-defmethod ede-proj-makefile-insert-automake-pre-variables
- ((this ede-proj-target-makefile-program))
- "Insert bin_PROGRAMS variables needed by target THIS."
- (ede-pmake-insert-variable-shared "bin_PROGRAMS"
- (insert (ede-name this)))
- (cl-call-next-method))
-
-(cl-defmethod ede-proj-makefile-insert-automake-post-variables
- ((this ede-proj-target-makefile-program))
- "Insert bin_PROGRAMS variables needed by target THIS."
- (ede-pmake-insert-variable-shared
- (concat (ede-name this) "_LDADD")
- (mapc (lambda (l) (insert " " l)) (oref this ldlibs-local))
- (mapc (lambda (c) (insert " " c)) (oref this ldflags))
- (when (oref this ldlibs)
- (mapc (lambda (d) (insert " -l" d)) (oref this ldlibs)))
- )
- (cl-call-next-method))
-
-(cl-defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile-program))
- "Insert variables needed by the compiler THIS."
- (cl-call-next-method)
- (let ((lf (mapconcat #'identity (oref this ldflags) " ")))
- (with-slots (ldlibs) this
- (if ldlibs
- (setq lf
- (concat lf " -l" (mapconcat #'identity ldlibs " -l")))))
- ;; LDFLAGS as needed.
- (when (and lf (not (string= "" lf)))
- (ede-pmake-insert-variable-once "LDDEPS" (insert lf)))))
-
-(cl-defmethod project-debug-target ((obj ede-proj-target-makefile-program))
- "Debug a program target OBJ."
- (let ((tb (get-buffer-create " *padt*"))
- (dd (if (not (string= (oref obj path) ""))
- (oref obj path)
- default-directory))
- (cmd nil))
- (unwind-protect
- (progn
- (set-buffer tb)
- (setq default-directory dd)
- (setq cmd (read-from-minibuffer
- "Run (like this): "
- (concat (symbol-name ede-debug-program-function)
- " " (ede-target-name obj))))
- (funcall ede-debug-program-function cmd))
- (kill-buffer tb))))
-
-(cl-defmethod project-run-target ((obj ede-proj-target-makefile-program) &optional command)
- "Run a program target OBJ.
-Optional COMMAND is the command to run in place of asking the user."
- (require 'ede/shell)
- (let ((tb (get-buffer-create " *padt*"))
- (dd (if (not (string= (oref obj path) ""))
- (oref obj path)
- default-directory))
- (cmd nil))
- (unwind-protect
- (progn
- (set-buffer tb)
- (setq default-directory dd)
- (setq cmd (or command
- (read-from-minibuffer
- "Run (like this): "
- (concat "./" (ede-target-name obj)))))
- (ede-shell-run-something obj cmd)
- )
- (kill-buffer tb))))
-
-(provide 'ede/proj-prog)
-
-;;; ede/proj-prog.el ends here
+++ /dev/null
-;;; ede/proj-scheme.el --- EDE Generic Project scheme (guile) support -*- lexical-binding: t -*-
-
-;; Copyright (C) 1998-2000, 2009-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make, scheme
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handle scheme (Guile) in and EDE Project file.
-;; This is a specialized do nothing class.
-
-(require 'ede/proj)
-(require 'ede/autoconf-edit)
-
-;;; Code:
-(defclass ede-proj-target-scheme (ede-proj-target)
- ((menu :initform nil)
- (keybindings :initform nil)
- (interpreter :initarg :interpreter
- :initform "guile"
- :type string
- :custom string
- :documentation "The preferred interpreter for this code.")
- )
- "This target consists of scheme files.")
-
-(cl-defmethod ede-proj-tweak-autoconf ((_this ede-proj-target-scheme))
- "Tweak the configure file (current buffer) to accommodate THIS."
- (autoconf-insert-new-macro "AM_INIT_GUILE_MODULE"))
-
-(provide 'ede/proj-scheme)
-
-;;; ede/proj-scheme.el ends here
+++ /dev/null
-;;; ede-proj-shared.el --- EDE Generic Project shared library support -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handle shared object libraries in and EDE Project file.
-;; Tries to deal with libtool and non-libtool situations.
-
-(require 'ede/pmake)
-(require 'ede/proj-obj)
-(require 'ede/proj-prog)
-
-;;; THIS NEEDS WORK. SEE ede-proj-obj.
-
-;;; Code:
-(defclass ede-proj-target-makefile-shared-object
- (ede-proj-target-makefile-program)
- ((availablecompilers :initform '(ede-gcc-libtool-shared-compiler
- ;;ede-gcc-shared-compiler
- ede-g++-libtool-shared-compiler
- ;;ede-g++-shared-compiler
- ))
- (availablelinkers :initform '(ede-cc-linker-libtool
- ede-g++-linker-libtool
- ;; Add more linker thingies here.
- ))
- (ldflags :custom (repeat (string :tag "Libtool flag"))
- :documentation
- "Additional flags to add when linking this shared library.
-Use ldlibs to add addition libraries.")
- )
- "This target generates a shared library.")
-
-(defvar ede-gcc-shared-compiler
- (clone ede-gcc-compiler
- "ede-c-shared-compiler"
- :name "gcc -shared"
- :variables '(("CC_SHARED" . "gcc")
- ("C_SHARED_COMPILE" .
- "$(CC_SHARED) -shared $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)"))
-; :linkvariables '(("C_SHARED_LINK" .
-; "$(CC_SHARED) -shared $(CFLAGS) $(LDFLAGS) -L. -o $@ $^")
-; )
-; :commands '("$(C_SHARED_LINK) %s")
- ;; @TODO - additive modification of autoconf.
- :autoconf '("AC_PROG_LIBTOOL")
- )
- "Compiler for C sourcecode.")
-
-(defvar ede-gcc-libtool-shared-compiler
- (clone ede-gcc-shared-compiler
- "ede-c-shared-compiler-libtool"
- :name "libtool"
- :variables '(("LIBTOOL" . "libtool")
- ("LTCOMPILE" . "$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)")
- ("LTLINK" . "$(LIBTOOL) --mode=link $(CC) $(CFLAGS) $(LDFLAGS) -L. -o $@")
- )
- :rules (list (ede-makefile-rule
- :target "%.o"
- :dependencies "%.c"
- :rules '("@echo '$(LTCOMPILE) -o $@ $<'; \\"
- "$(LTCOMPILE) -o $@ $<"
- )
- ))
- :autoconf '("AC_PROG_LIBTOOL")
- )
- "Compiler for C sourcecode.")
-
-(defvar ede-cc-linker-libtool
- (clone ede-cc-linker
- "ede-cc-linker-libtool"
- :name "cc shared"
- ;; Only use this linker when c++ exists.
- :sourcetype '(ede-source-c++)
- :variables '(
- ("LIBTOOL" . "libtool")
- ("LTLINK" . "$(LIBTOOL) --tag=CPP --mode=link $(CPP) $(CFLAGS) $(LDFLAGS) -L. -o $@")
- )
- :commands '("$(LTLINK) -o $@ $^")
- :autoconf '("AC_PROG_LIBTOOL")
- :objectextention ".la")
- "Linker needed for c++ programs.")
-
-(defvar ede-g++-shared-compiler
- (clone ede-g++-compiler
- "ede-c++-shared-compiler"
- :name "gcc -shared"
- :variables '(("CXX_SHARED" . "g++")
- ("CXX_SHARED_COMPILE" .
- "$(CXX_SHARED) -shared $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)"))
- ;; @TODO - additive modification of autoconf.
- :autoconf '("AC_PROG_LIBTOOL")
- )
- "Compiler for C sourcecode.")
-
-(defvar ede-g++-libtool-shared-compiler
- (clone ede-g++-shared-compiler
- "ede-c++-shared-compiler-libtool"
- :name "libtool"
- :variables '(("CXX" "g++")
- ("LIBTOOL" . "libtool")
- ("LTCOMPILE" . "$(LIBTOOL) --tag=CXX --mode=compile $(CXX) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)")
- )
- :rules (list (ede-makefile-rule
- :target "%.o"
- :dependencies "%.cpp"
- :rules '("@echo '$(LTCOMPILE) -o $@ $<'; \\"
- "$(LTCOMPILE) -o $@ $<"
- )
- ))
- :autoconf '("AC_PROG_LIBTOOL")
- )
- "Compiler for C sourcecode.")
-
-(defvar ede-g++-linker-libtool
- (clone ede-g++-linker
- "ede-g++-linker-libtool"
- :name "g++"
- ;; Only use this linker when c++ exists.
- :sourcetype '(ede-source-c++)
- :variables '(
- ("LIBTOOL" . "libtool")
- ("LTLINK" . "$(LIBTOOL) --tag=CXX --mode=link $(CXX) $(CFLAGS) $(LDFLAGS) -L. -o $@")
- )
- :commands '("$(LTLINK) -o $@ $^")
- :autoconf '("AC_PROG_LIBTOOL")
- :objectextention ".la")
- "Linker needed for c++ programs.")
-
-;;; @TODO - C++ versions of the above.
-
-(when nil
-
-
- (insert;; These C to O rules create dependencies
- "%.o: %.c\n"
- "\t@echo '$(COMPILE) -c $<'; \\\n"
- "\t$(COMPILE)"
- (if (oref this automatic-dependencies)
- " -Wp,-MD,.deps/$(*F).P"
- "")
- " -c $<\n\n")
- (if have-libtool
- (insert;; These C to shared o rules create pic code.
- "%.lo: %.c\n"
- "\t@echo '$(LTCOMPILE) -c $<'; \\\n"
- "\t$(LTCOMPILE) -Wp,-MD,.deps/$(*F).p -c $<\n"
- "\t@-sed -e 's/^\\([^:]*\\)\\.o:/\\1.lo \\1.o:/' \\\n"
- "\t < .deps/$(*F).p > .deps/$(*F).P\n"
- "\t@-rm -f .deps/$(*F).p\n\n"))
- )
-
-(cl-defmethod ede-proj-configure-add-missing
- ((_this ede-proj-target-makefile-shared-object))
- "Query if any files needed by THIS provided by automake are missing.
-Results in --add-missing being passed to automake."
- (not (and (ede-expand-filename (ede-toplevel) "ltconfig")
- (ede-expand-filename (ede-toplevel) "ltmain.sh"))))
-
-(cl-defmethod ede-proj-makefile-insert-automake-pre-variables
- ((this ede-proj-target-makefile-shared-object))
- "Insert bin_PROGRAMS variables needed by target THIS.
-We aren't actually inserting SOURCE details, but this is used by the
-Makefile.am generator, so use it to add this important bin program."
- (ede-pmake-insert-variable-shared "lib_LTLIBRARIES"
- (insert (concat "lib" (ede-name this) ".la"))))
-
-(cl-defmethod ede-proj-makefile-insert-automake-post-variables
- ((_this ede-proj-target-makefile-shared-object))
- "Insert bin_PROGRAMS variables needed by target THIS.
-We need to override -program which has an LDADD element."
- nil)
-
-(cl-defmethod ede-proj-makefile-target-name ((this ede-proj-target-makefile-shared-object))
- "Return the name of the main target for THIS target."
- ;; We need some platform gunk to make the .so change to .sl, or .a,
- ;; depending on the platform we are going to compile against.
- (concat "lib" (ede-name this) ".la"))
-
-(cl-defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-makefile-shared-object))
- "Return the variable name for THIS's sources."
- (if (eq (oref (ede-target-parent this) makefile-type) 'Makefile.am)
- (concat "lib" (oref this name) "_la_SOURCES")
- (cl-call-next-method)))
-
-
-(provide 'ede/proj-shared)
-
-;;; ede/proj-shared.el ends here
+++ /dev/null
-;;; ede/proj.el --- EDE Generic Project file driver -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2003, 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; EDE defines a method for managing a project. EDE-PROJ aims to be a
-;; generic project file format based on the EIEIO object stream
-;; methods. Changes in the project structure will require Makefile
-;; rebuild. The targets provided in ede-proj can be augmented with
-;; additional target types inherited directly from `ede-proj-target'.
-
-(require 'ede/proj-comp)
-(require 'ede/make)
-
-(declare-function ede-proj-makefile-create "ede/pmake")
-(declare-function ede-proj-configure-synchronize "ede/pconf")
-
-(autoload 'ede-proj-target-aux "ede/proj-aux"
- "Target class for a group of lisp files." nil nil)
-(autoload 'ede-proj-target-elisp "ede/proj-elisp"
- "Target class for a group of lisp files." nil nil)
-(autoload 'ede-proj-target-elisp-autoloads "ede/proj-elisp"
- "Target class for generating autoload files." nil nil)
-(autoload 'ede-proj-target-scheme "ede/proj-scheme"
- "Target class for a group of lisp files." nil nil)
-(autoload 'ede-proj-target-makefile-miscelaneous "ede/proj-misc"
- "Target class for a group of miscellaneous with a special makefile." nil nil)
-(autoload 'ede-proj-target-makefile-program "ede/proj-prog"
- "Target class for building a program." nil nil)
-(autoload 'ede-proj-target-makefile-archive "ede/proj-archive"
- "Target class for building an archive of object code." nil nil)
-(autoload 'ede-proj-target-makefile-shared-object "ede/proj-shared"
- "Target class for building a shared object." nil nil)
-(autoload 'ede-proj-target-makefile-info "ede/proj-info"
- "Target class for info files." nil nil)
-
-(eieio-defclass-autoload 'ede-proj-target-aux '(ede-proj-target)
- "ede/proj-aux"
- "Target class for a group of lisp files.")
-(eieio-defclass-autoload 'ede-proj-target-elisp '(ede-proj-target-makefile)
- "ede/proj-elisp"
- "Target class for a group of lisp files.")
-(eieio-defclass-autoload 'ede-proj-target-elisp-autoloads '(ede-proj-target-elisp)
- "ede/proj-elisp"
- "Target class for generating autoload files.")
-(eieio-defclass-autoload 'ede-proj-target-scheme '(ede-proj-target)
- "ede/proj-scheme"
- "Target class for a group of lisp files.")
-(eieio-defclass-autoload 'ede-proj-target-makefile-miscelaneous '(ede-proj-target-makefile)
- "ede/proj-misc"
- "Target class for a group of miscellaneous with a special makefile.")
-(eieio-defclass-autoload 'ede-proj-target-makefile-program '(ede-proj-target-makefile-objectcode)
- "ede/proj-prog"
- "Target class for building a program.")
-(eieio-defclass-autoload 'ede-proj-target-makefile-archive '(ede-proj-target-makefile-objectcode)
- "ede/proj-archive"
- "Target class for building an archive of object code.")
-(eieio-defclass-autoload 'ede-proj-target-makefile-shared-object '(ede-proj-target-makefile-program)
- "ede/proj-shared"
- "Target class for building a shared object.")
-(eieio-defclass-autoload 'ede-proj-target-makefile-info '(ede-proj-target-makefile)
- "ede/proj-info"
- "Target class for info files.")
-
-;; Not in ede/ , but part of semantic.
-(eieio-defclass-autoload 'semantic-ede-proj-target-grammar '(ede-proj-target-elisp)
- "semantic/ede-grammar"
- "Target classfor Semantic grammar files.")
-
-;;; Class Definitions:
-(defclass ede-proj-target (ede-target)
- ((auxsource :initarg :auxsource
- :initform nil
- :type list
- :custom (repeat (string :tag "File"))
- :label "Auxiliary Source Files"
- :group (default source)
- :documentation "Auxiliary source files included in this target.
-Each of these is considered equivalent to a source file, but it is not
-distributed, and each should have a corresponding rule to build it.")
- (dirty :initform nil
- :type boolean
- :documentation "Non-nil when generated files needs updating.")
- (compiler :initarg :compiler
- :initform nil
- :type (or null symbol)
- :custom (choice (const :tag "None" nil)
- (symbol :tag "Custom Compiler Symbol")
- :slotofchoices availablecompilers)
- :label "Compiler for building sources"
- :group make
- :documentation
- "The compiler to be used to compile this object.
-This should be a symbol, which contains the object defining the compiler.
-This enables save/restore to do so by name, permitting the sharing
-of these compiler resources, and global customization thereof.")
- (linker :initarg :linker
- :initform nil
- :type (or null symbol)
- :custom (choice (const :tag "None" nil)
- (symbol :tag "Custom Linker Symbol")
- :slotofchoices availablelinkers)
- :label "Linker for combining intermediate object files."
- :group make
- :documentation
- "The linker to be used to link compiled sources for this object.
-This should be a symbol, which contains the object defining the linker.
-This enables save/restore to do so by name, permitting the sharing
-of these linker resources, and global customization thereof.")
- ;; Class allocated slots
- (phony :allocation :class
- :initform nil
- :type boolean
- :documentation
- "A phony target is one where the build target does not relate to a file.
-Such targets are always built, but make knows how to deal with them..")
- (availablecompilers :allocation :class
- :initform nil
- :type (or null list)
- :documentation
- "A list of `ede-compiler' objects.
-These are the compilers the user can choose from when setting the
-`compiler' slot.")
- (availablelinkers :allocation :class
- :initform nil
- :type (or null list)
- :documentation
- "A list of `ede-linker' objects.
-These are the linkers the user can choose from when setting the
-`linker' slot.")
- )
- "Abstract class for ede-proj targets.")
-
-(defclass ede-proj-target-makefile (ede-proj-target)
- ((makefile :initarg :makefile
- :initform "Makefile"
- :type string
- :custom string
- :label "Parent Makefile"
- :group make
- :documentation "File name of generated Makefile.")
- (partofall :initarg :partofall
- :initform t
- :type boolean
- :custom boolean
- :label "Part of all: target"
- :group make
- :documentation
- "Non-nil means the rule created is part of the all: target.
-Setting this to nil creates the rule to build this item, but does not
-include it in the all: rule.")
- (configuration-variables
- :initarg :configuration-variables
- :initform nil
- :type list
- :custom (repeat (cons (string :tag "Configuration")
- (repeat
- (cons (string :tag "Name")
- (string :tag "Value")))))
- :label "Environment Variables for configurations"
- :group make
- :documentation "Makefile variables appended to use in different configurations.
-These variables are used in the makefile when a configuration becomes active.
-Target variables are always renamed such as foo_CFLAGS, then included into
-commands where the variable would usually appear.")
- (rules :initarg :rules
- :initform nil
- :type (list-of ede-makefile-rule)
- :custom (repeat (object :objecttype ede-makefile-rule))
- :label "Additional Rules"
- :group (make)
- :documentation
- "Arbitrary rules and dependencies needed to make this target.
-It is safe to leave this blank.")
- )
- "Abstract class for Makefile based targets.")
-
-(defvar ede-proj-target-alist
- '(("program" . ede-proj-target-makefile-program)
- ("archive" . ede-proj-target-makefile-archive)
- ("sharedobject" . ede-proj-target-makefile-shared-object)
- ("emacs lisp" . ede-proj-target-elisp)
- ("emacs lisp autoloads" . ede-proj-target-elisp-autoloads)
- ("info" . ede-proj-target-makefile-info)
- ("auxiliary" . ede-proj-target-aux)
- ("scheme" . ede-proj-target-scheme)
- ("miscellaneous" . ede-proj-target-makefile-miscelaneous)
- )
- "Alist of names to class types for available project target classes.")
-
-(defun ede-proj-register-target (name class)
- "Register a new target class with NAME and class symbol CLASS.
-This enables the creation of your target type."
- (let ((a (assoc name ede-proj-target-alist)))
- (if a
- (setcdr a class)
- (setq ede-proj-target-alist
- (cons (cons name class) ede-proj-target-alist)))))
-
-(defclass ede-proj-project (eieio-persistent ede-project eieio-named)
- ((extension :initform ".ede")
- (file-header-line :initform ";; EDE Project Files are auto generated: Do Not Edit")
- (makefile-type :initarg :makefile-type
- :initform 'Makefile
- :type symbol
- :custom (choice (const Makefile)
- ;(const Makefile.in)
- (const Makefile.am)
- ;(const cook)
- )
- :documentation "The type of Makefile to generate.
-Can be one of 'Makefile, 'Makefile.in, or 'Makefile.am.
-If this value is NOT 'Makefile, then that overrides the :makefile slot
-in targets.")
- (variables :initarg :variables
- :initform nil
- :type list
- :custom (repeat (cons (string :tag "Name")
- (string :tag "Value")))
- :group (settings)
- :documentation "Variables to set in this Makefile.")
- (configuration-variables
- :initarg :configuration-variables
- :initform '("debug" (("DEBUG" . "1")))
- :type list
- :custom (repeat (cons (string :tag "Configuration")
- (repeat
- (cons (string :tag "Name")
- (string :tag "Value")))))
- :group (settings)
- :documentation "Makefile variables to use in different configurations.
-These variables are used in the makefile when a configuration becomes active.")
- (inference-rules :initarg :inference-rules
- :initform nil
- :custom (repeat
- (object :objecttype ede-makefile-rule))
- :documentation "Inference rules to add to the makefile.")
- (include-file :initarg :include-file
- :initform nil
- :custom (repeat
- (string :tag "Include File"))
- :documentation "Additional files to include.
-These files can contain additional rules, variables, and customizations.")
- (automatic-dependencies
- :initarg :automatic-dependencies
- :initform t
- :type boolean
- :custom boolean
- :group (default settings)
- :documentation
- "Non-nil to do implement automatic dependencies in the Makefile.")
- (menu :initform
- '(
- [ "Regenerate Makefiles" ede-proj-regenerate t ]
- [ "Upload Distribution" ede-upload-distribution t ]
- )
- )
- (metasubproject
- :initarg :metasubproject
- :initform nil
- :type boolean
- :custom boolean
- :group (default settings)
- :documentation
- "Non-nil if this is a metasubproject.
-Usually, a subproject is determined by a parent project. If multiple top level
-projects are grouped into a large project not maintained by EDE, then you need
-to set this to non-nil. The only effect is that the `dist' rule will then avoid
-making a tar file.")
- )
- "The EDE-PROJ project definition class.")
-
-;;; Code:
-(defun ede-proj-load (project &optional rootproj)
- "Load a project file from PROJECT directory.
-If optional ROOTPROJ is provided then ROOTPROJ is the root project
-for the tree being read in. If ROOTPROJ is nil, then assume that
-the PROJECT being read in is the root project."
- (save-excursion
- (let ((ret (eieio-persistent-read (concat project "Project.ede")
- 'ede-proj-project))
- (subdirs (directory-files project nil "[^.].*" nil)))
- (if (not (object-of-class-p ret 'ede-proj-project))
- (error "Corrupt project file"))
- (oset ret directory project)
- (oset ret rootproject rootproj)
-
- ;; Load the project file of each subdirectory containing a
- ;; loadable Project.ede.
- (while subdirs
- (let ((sd (file-name-as-directory
- (expand-file-name (car subdirs) project))))
- (if (and (file-directory-p sd)
- (file-exists-p (expand-file-name "Project.ede" sd)))
- (oset ret subproj
- (cons (ede-proj-load sd (or rootproj ret))
- (oref ret subproj))))
- (setq subdirs (cdr subdirs))))
- ret)))
-
-(defun ede-proj-save (&optional project)
- "Write out object PROJECT into its file."
- (save-excursion
- (if (not project) (setq project (ede-current-project)))
- (let ((cdir (oref project directory)))
- (unwind-protect
- (progn
- (slot-makeunbound project :directory)
- (eieio-persistent-save project))
- ;; Restore the directory slot
- (oset project directory cdir))) ))
-
-(cl-defmethod ede-commit-local-variables ((proj ede-proj-project))
- "Commit change to local variables in PROJ."
- (ede-proj-save proj))
-
-(cl-defmethod eieio-done-customizing ((proj ede-proj-project))
- "Call this when a user finishes customizing this object.
-Argument PROJ is the project to save."
- (cl-call-next-method)
- (ede-proj-save proj))
-
-(cl-defmethod eieio-done-customizing ((_target ede-proj-target))
- "Call this when a user finishes customizing this object.
-Argument TARGET is the project we are completing customization on."
- (cl-call-next-method)
- (ede-proj-save (ede-current-project)))
-
-(cl-defmethod ede-commit-project ((proj ede-proj-project))
- "Commit any change to PROJ to its file."
- (ede-proj-save proj))
-
-(cl-defmethod ede-buffer-mine ((this ede-proj-project) buffer)
- "Return t if object THIS lays claim to the file in BUFFER."
- (let ((f (ede-convert-path this (buffer-file-name buffer))))
- (or (string= (file-name-nondirectory (oref this file)) f)
- (string= (ede-proj-dist-makefile this) f)
- (string-match "Makefile\\(\\.\\(in\\|am\\)\\)?$" f)
- (string-match "config\\(ure\\.\\(in\\|ac\\)\\|\\.status\\)?$" f)
- (string-match "config.h\\(\\.in\\)?" f)
- (member f '("AUTHORS" "NEWS" "COPYING" "INSTALL" "README"))
- )))
-
-(cl-defmethod ede-buffer-mine ((this ede-proj-target) buffer)
- "Return t if object THIS lays claim to the file in BUFFER."
- (or (cl-call-next-method)
- (ede-target-buffer-in-sourcelist this buffer (oref this auxsource))))
-
-\f
-;;; EDE command functions
-;;
-(defvar ede-proj-target-history nil
- "History when querying for a target type.")
-
-(cl-defmethod project-new-target ((this ede-proj-project)
- &optional name type autoadd)
- "Create a new target in THIS based on the current buffer."
- (let* ((name (or name (read-string "Name: " "")))
- (type (or type
- (completing-read "Type: " ede-proj-target-alist
- nil t nil '(ede-proj-target-history . 1))))
- (ot nil)
- (src (if (and (buffer-file-name)
- (if (and autoadd (stringp autoadd))
- (string= autoadd "y")
- (y-or-n-p (format "Add %s to %s? " (buffer-name) name))))
- (buffer-file-name)))
- (fcn (cdr (assoc type ede-proj-target-alist)))
- )
-
- (when (not fcn)
- (error "Unknown target type %s for EDE Project" type))
-
- (setq ot (funcall fcn name :name name
- :path (ede-convert-path this default-directory)
- :source (if src
- (list (file-name-nondirectory src))
- nil)))
- ;; If we added it, set the local buffer's object.
- (if src (progn
- (setq ede-object ot)
- (ede-apply-object-keymap)))
- ;; Add it to the project object
- ;;(oset this targets (cons ot (oref this targets)))
- ;; New form: Add to the end using fancy eieio function.
- ;; @todone - Some targets probably want to be in the front.
- ;; How to do that?
- ;; @ans - See elisp autoloads for answer
- (object-add-to-list this 'targets ot t)
- ;; And save
- (ede-proj-save this)))
-
-(cl-defmethod project-new-target-custom ((this ede-proj-project))
- "Create a new target in THIS for custom."
- (let* ((name (read-string "Name: " ""))
- (type (completing-read "Type: " ede-proj-target-alist
- nil t nil '(ede-proj-target-history . 1))))
- (funcall (cdr (assoc type ede-proj-target-alist)) name :name name
- :path (ede-convert-path this default-directory)
- :source nil)))
-
-(cl-defmethod project-delete-target ((this ede-proj-target))
- "Delete the current target THIS from its parent project."
- (let ((p (ede-current-project))
- (ts (oref this source)))
- ;; Loop across all sources. If it exists in a buffer,
- ;; clear its object.
- (while ts
- (let* ((default-directory (oref this path))
- (b (get-file-buffer (car ts))))
- (if b
- (with-current-buffer b
- (if (eq ede-object this)
- (progn
- (setq ede-object nil)
- (ede-apply-object-keymap))))))
- (setq ts (cdr ts)))
- ;; Remove THIS from its parent.
- ;; The two vectors should be pointer equivalent.
- (oset p targets (delq this (oref p targets)))
- (ede-proj-save (ede-current-project))))
-
-(cl-defmethod project-add-file ((this ede-proj-target) file)
- "Add to target THIS the current buffer represented as FILE."
- (let ((file (ede-convert-path this file))
- (src (ede-target-sourcecode this)))
- (while (and src (not (ede-want-file-p (car src) file)))
- (setq src (cdr src)))
- (when src
- (setq src (car src))
- (cond ((ede-want-file-source-p this file)
- (object-add-to-list this 'source file t))
- ((ede-want-file-auxiliary-p this file)
- (object-add-to-list this 'auxsource file t))
- (t (error "`project-add-file(ede-target)' source mismatch error")))
- (ede-proj-save))))
-
-(cl-defmethod project-remove-file ((target ede-proj-target) file)
- "For TARGET, remove FILE.
-FILE must be massaged by `ede-convert-path'."
- ;; Speedy delete should be safe.
- (object-remove-from-list target 'source (ede-convert-path target file))
- (object-remove-from-list target 'auxsource (ede-convert-path target file))
- (ede-proj-save))
-
-(cl-defmethod project-update-version ((_this ede-proj-project))
- "The :version of project THIS has changed."
- (ede-proj-save))
-
-(cl-defmethod project-make-dist ((this ede-proj-project))
- "Build a distribution for the project based on THIS target."
- (let ((pm (ede-proj-dist-makefile this))
- (df (project-dist-files this)))
- (if (and (file-exists-p (car df))
- (not (y-or-n-p "Dist file already exists. Rebuild? ")))
- (error "Try `ede-update-version' before making a distribution"))
- (ede-proj-setup-buildenvironment this)
- (if (ede-proj-automake-p this)
- (setq pm (expand-file-name "Makefile"
- (file-name-directory pm))))
- (compile (concat ede-make-command " -f " pm " dist"))))
-
-(cl-defmethod project-dist-files ((this ede-proj-project))
- "Return a list of files that constitutes a distribution of THIS project."
- (list
- ;; Note to self, keep this first for the above fn to check against.
- (concat (oref this name) "-" (oref this version) ".tar.gz")
- ))
-
-(cl-defmethod project-compile-project ((proj ede-proj-project) &optional _command)
- "Compile the entire current project PROJ.
-Argument COMMAND is the command to use when compiling."
- (let ((pm (ede-proj-dist-makefile proj))
- (default-directory (file-name-directory (oref proj file))))
- (ede-proj-setup-buildenvironment proj)
- (if (ede-proj-automake-p proj)
- (setq pm (expand-file-name "Makefile"
- (file-name-directory pm))))
- (compile (concat ede-make-command" -f " pm " all"))))
-
-;;; Target type specific compilations/debug
-;;
-(cl-defmethod project-compile-target ((_obj ede-proj-target) &optional command)
- "Compile the current target OBJ.
-Argument COMMAND is the command to use for compiling the target."
- (project-compile-project (ede-current-project) command))
-
-(cl-defmethod project-compile-target ((obj ede-proj-target-makefile)
- &optional _command)
- "Compile the current target program OBJ.
-Optional argument COMMAND is the s the alternate command to use."
- (ede-proj-setup-buildenvironment (ede-current-project))
- (compile (concat ede-make-command " -f " (oref obj makefile) " "
- (ede-proj-makefile-target-name obj))))
-
-(cl-defmethod project-debug-target ((obj ede-proj-target))
- "Run the current project target OBJ in a debugger."
- (error "Debug-target not supported by %s" (eieio-object-name obj)))
-
-(cl-defmethod project-run-target ((obj ede-proj-target))
- "Run the current project target OBJ."
- (error "Run-target not supported by %s" (eieio-object-name obj)))
-
-(cl-defmethod ede-proj-makefile-target-name ((this ede-proj-target))
- "Return the name of the main target for THIS target."
- (ede-name this))
-\f
-;;; Compiler and source code generators
-;;
-(cl-defmethod ede-want-file-auxiliary-p ((this ede-target) file)
- "Return non-nil if THIS target wants FILE."
- ;; By default, all targets reference the source object, and let it decide.
- (let ((src (ede-target-sourcecode this)))
- (while (and src (not (ede-want-file-auxiliary-p (car src) file)))
- (setq src (cdr src)))
- src))
-
-(cl-defmethod ede-proj-compilers ((obj ede-proj-target))
- "List of compilers being used by OBJ.
-If the `compiler' slot is empty, concoct one on a first match found
-basis for any given type from the `availablecompilers' slot.
-Otherwise, return the `compiler' slot.
-Converts all symbols into the objects to be used."
- (when (slot-exists-p obj 'compiler)
- (let ((comp (oref obj compiler)))
- (if comp
- ;; Now that we have a pre-set compilers to use, convert type symbols
- ;; into objects for ease of use
- (setq comp (if (listp comp)
- (mapcar #'symbol-value comp)
- (list (symbol-value comp))))
- (let* ((acomp (oref obj availablecompilers))
- (avail (mapcar #'symbol-value acomp))
- (st (oref obj sourcetype))
- (sources (oref obj source)))
- ;; COMP is not specified, so generate a list from the available
- ;; compilers list.
- (while st
- (if (ede-want-any-source-files-p (symbol-value (car st)) sources)
- (let ((c (ede-proj-find-compiler avail (car st))))
- (if c (setq comp (cons c comp)))))
- (setq st (cdr st)))
- ;; Provide a good error msg.
- (unless comp
- (error "Could not find compiler match for source code extension \"%s\".
-You may need to add support for this type of file"
- (if sources
- (file-name-extension (car sources))
- "")))
- ))
- ;; Return the discovered compilers.
- comp)))
-
-(cl-defmethod ede-proj-linkers ((obj ede-proj-target))
- "List of linkers being used by OBJ.
-If the `linker' slot is empty, concoct one on a first match found
-basis for any given type from the `availablelinkers' slot.
-Otherwise, return the `linker' slot.
-Converts all symbols into the objects to be used."
- (when (slot-exists-p obj 'linker)
- (let ((link (oref obj linker)))
- (if link
- ;; Now that we have a pre-set linkers to use, convert type symbols
- ;; into objects for ease of use
- (if (symbolp link)
- (setq link (list (symbol-value link)))
- (error ":linker is not a symbol. Howd you do that?"))
- (let* ((alink (oref obj availablelinkers))
- (avail (mapcar #'symbol-value alink))
- (st (oref obj sourcetype))
- (sources (oref obj source)))
- ;; LINKER is not specified, so generate a list from the available
- ;; compilers list.
- (while st
- (if (ede-want-any-source-files-p (symbol-value (car st)) sources)
- (let ((c (ede-proj-find-linker avail (car st))))
- (if c (setq link (cons c link)))))
- (setq st (cdr st)))
- (unless link
- ;; No linker stands out! Loop over our linkers and pull out
- ;; the first that has no source type requirement.
- (while (and avail (not (eieio-instance-inheritor-slot-boundp (car avail) 'sourcetype)))
- (setq avail (cdr avail)))
- (setq link (cdr avail)))))
- ;; Return the discovered linkers.
- link)))
-
-\f
-;;; Target type specific autogenerating gobbledygook.
-;;
-
-(defun ede-proj-makefile-type (&optional proj)
- "Makefile type of the current project PROJ."
- (oref (or proj (ede-current-project)) makefile-type))
-
-(defun ede-proj-automake-p (&optional proj)
- "Return non-nil if the current project PROJ is automake mode."
- (eq (ede-proj-makefile-type proj) 'Makefile.am))
-
-(defun ede-proj-autoconf-p (&optional proj)
- "Return non-nil if the current project PROJ is automake mode."
- (eq (ede-proj-makefile-type proj) 'Makefile.in))
-
-(defun ede-proj-make-p (&optional proj)
- "Return non-nil if the current project PROJ is automake mode."
- (eq (ede-proj-makefile-type proj) 'Makefile))
-
-(cl-defmethod ede-proj-dist-makefile ((this ede-proj-project))
- "Return the name of the Makefile with the DIST target in it for THIS."
- (cond ((eq (oref this makefile-type) 'Makefile.am)
- (concat (file-name-directory (oref this file))
- "Makefile.am"))
- ((eq (oref this makefile-type) 'Makefile.in)
- (expand-file-name "Makefile.in"
- (file-name-directory (oref this file))))
- ((object-assoc "Makefile" 'makefile (oref this targets))
- (expand-file-name "Makefile"
- (file-name-directory (oref this file))))
- (t
- (let ((targets (oref this targets)))
- (while (and targets
- (not (obj-of-class-p
- (car targets)
- 'ede-proj-target-makefile)))
- (setq targets (cdr targets)))
- (if targets (oref (car targets) makefile)
- (expand-file-name "Makefile"
- (file-name-directory (oref this file))))))))
-
-(defun ede-proj-regenerate ()
- "Regenerate Makefiles for and edeproject project."
- (interactive)
- (ede-proj-setup-buildenvironment (ede-current-project) t))
-
-(cl-defmethod ede-proj-makefile-create-maybe ((this ede-proj-project) mfilename)
- "Create a Makefile for all Makefile targets in THIS if needed.
-MFILENAME is the makefile to generate."
- ;; For now, pass through until dirty is implemented.
- (require 'ede/pmake)
- (if (or (not (file-exists-p mfilename))
- (file-newer-than-file-p (oref this file) mfilename))
- (ede-proj-makefile-create this mfilename)))
-
-(cl-defmethod ede-proj-setup-buildenvironment ((this ede-proj-project)
- &optional force)
- "Setup the build environment for project THIS.
-Handles the Makefile, or a Makefile.am configure.ac combination.
-Optional argument FORCE will force items to be regenerated."
- (if (not force)
- (ede-proj-makefile-create-maybe this (ede-proj-dist-makefile this))
- (require 'ede/pmake)
- (ede-proj-makefile-create this (ede-proj-dist-makefile this)))
- ;; Rebuild all subprojects
- (ede-map-subprojects
- this (lambda (sproj) (ede-proj-setup-buildenvironment sproj force)))
- ;; Autoconf projects need to do other kinds of initializations.
- (when (and (ede-proj-automake-p this)
- (eq this (ede-toplevel this)))
- (require 'ede/pconf)
- ;; If the user wants to force this, do it some other way?
- (ede-proj-configure-synchronize this)
- ;; Now run automake to fill in the blanks, autoconf, and other
- ;; auto thingies so that we can just say "make" when done.
- )
- )
-
-\f
-;;; Lower level overloads
-;;
-(cl-defmethod project-rescan ((this ede-proj-project))
- "Rescan the EDE proj project THIS."
- (let ((root (or (ede-project-root this) this))
- )
- ;; @TODO - VERIFY THE BELOW WORKS
- (ede-project-directory-remove-hash
- (file-name-directory (ede-project-root-directory root)))
- (ede-delete-project-from-global-list root)
- ;; NOTE : parent function double-checks that this dir was
- ;; already in memory once.
- (ede-load-project-file (ede-project-root-directory root))
- ))
-
-(provide 'ede/proj)
-
-;;; ede/proj.el ends here
+++ /dev/null
-;;; project-am.el --- A project management scheme based on automake files. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2000, 2003, 2005, 2007-2024 Free Software
-;; Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Old-Version: 0.0.3
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; The GNU Automake tool is the first step towards having a really
-;; good project management system. It provides a simple and concise
-;; look at what is actually in a project, and records it in a simple
-;; fashion.
-;;
-;; project-am uses the structure defined in all good GNU projects with
-;; the Automake file as its base template, and then maintains that
-;; information during edits, automatically updating the automake file
-;; where appropriate.
-
-(require 'make-mode)
-(require 'ede)
-(require 'ede/make)
-(require 'ede/makefile-edit)
-(require 'semantic/find) ;; for semantic-find-tags-by-...
-(require 'ede/autoconf-edit)
-
-(declare-function autoconf-parameters-for-macro "ede/autoconf-edit")
-(declare-function ede-shell-run-something "ede/shell")
-(eval-when-compile (require 'compile))
-
-;;; Code:
-(defgroup project-am nil
- "File and tag browser frame."
- :group 'tools
- :group 'ede
- )
-
-(defcustom project-am-compile-project-command nil
- "Default command used to compile a project."
- :type '(choice (const nil) string))
-
-(defcustom project-am-compile-target-command (concat ede-make-command " -k %s")
- "Default command used to compile a project."
- :type 'string)
-
-(defcustom project-am-debug-target-function 'gdb
- "Default Emacs command used to debug a target."
- :type 'function) ; make this be a list some day
-
-(defconst project-am-type-alist
- '(("bin" project-am-program "bin_PROGRAMS" t)
- ("sbin" project-am-program "sbin_PROGRAMS" t)
- ("noinstbin" project-am-program "noinst_PROGRAMS" t)
- ("checkbin" project-am-program "check_PROGRAMS" t)
- ("lib" project-am-lib "lib_LIBS" t)
- ("libraries" project-am-lib "lib_LIBRARIES" t)
- ("librariesnoinst" project-am-lib "noinst_LIBRARIES" t)
- ("pkglibraries" project-am-lib "pkglib_LIBRARIES" t)
- ("checklibs" project-am-lib "check_LIBRARIES" t)
- ("ltlibraries" project-am-lib "lib_LTLIBRARIES" t)
- ("ltlibrariesnoinst" project-am-lib "noinst_LTLIBRARIES" t)
- ("pkgltlibraries" project-am-lib "pkglib_LTLIBRARIES" t)
- ("checkltlibs" project-am-lib "check_LTLIBRARIES" t)
- ("headernoinst" project-am-header-noinst "noinst_HEADERS")
- ("headerinst" project-am-header-inst "include_HEADERS")
- ("headerpkg" project-am-header-pkg "pkginclude_HEADERS")
- ("headerpkg" project-am-header-chk "check_HEADERS")
- ("texinfo" project-am-texinfo "info_TEXINFOS" t)
- ("man" project-am-man "man_MANS")
- ("lisp" project-am-lisp "lisp_LISP")
- ;; for other global files track EXTRA_
- ("extrabin" project-am-program "EXTRA_PROGRAMS" t)
- ("builtsrcs" project-am-built-src "BUILT_SOURCES")
- ("extradist" project-am-extra-dist "EXTRA_DIST")
- ;; Custom libraries targets?
- ;; ("ltlibcustom" project-am-lib ".*?_LTLIBRARIES" t)
- )
- "Alist of type names and the type of object to create for them.
-Each entry is of the form:
- (EMACSNAME CLASS AUTOMAKEVAR INDIRECT)
-where EMACSNAME is a name for Emacs to use.
-CLASS is the EDE target class to represent the target.
-AUTOMAKEVAR is the Automake variable to identify. This cannot be a
- regular expression.
-INDIRECT is optional. If it is non-nil, then the variable in
-question lists other variables that need to be looked up.")
-
-
-(defconst project-am-meta-type-alist
- '((project-am-program "_PROGRAMS$" t)
- (project-am-lib "_\\(LIBS\\|LIBRARIES\\|LTLIBRARIES\\)$" t)
-
- ;; direct primary target use a dummy object (man target)
- ;; update to: * 3.3 Uniform in automake-1.11 info node.
- (project-am-man "_\\(DATA\\|HEADERS\\|PYTHON\\|JAVA\\|SCRIPTS\\|MANS\\|TEXINFOS\\)$" nil)
- )
- "Alist of meta-target type, each entry has form:
- (CLASS REGEXPVAR INDIRECT)
-where CLASS is the EDE target class for target.
-REGEXPVAR is the regexp used in `semantic-find-tags-by-name-regexp'.
-INDIRECT is optional. If it is non-nil, then the variable in it have
-other meta-variable based on this name.")
-
-
-(defclass project-am-target (ede-target)
- nil
- "Base target class for everything in project-am.")
-
-(defclass project-am-objectcode (project-am-target)
- ((source :initarg :source :documentation "List of source files."))
- "A target which creates object code, like a C program or library.")
-
-(defclass project-am-program (project-am-objectcode)
- ((ldadd :initarg :ldadd :documentation "Additional LD args."
- :initform nil))
- "A top level program to build.")
-
-(defclass project-am-header (project-am-target)
- ()
- "A group of misc source files, such as headers.")
-
-(defclass project-am-header-noinst (project-am-header)
- ()
- "A group of header files that are not installed.")
-
-(defclass project-am-header-inst (project-am-header)
- ()
- "A group of header files that are not installed.")
-
-(defclass project-am-header-pkg (project-am-header)
- ()
- "A group of header files that are not installed.")
-
-(defclass project-am-header-chk (project-am-header)
- ()
- "A group of header files that are not installed.")
-
-(defclass project-am-lib (project-am-objectcode)
- nil
- "A top level library to build.")
-
-(defclass project-am-lisp (project-am-target)
- ()
- "A group of Emacs Lisp programs to byte compile.")
-
-(defclass project-am-texinfo (project-am-target)
- ((include :initarg :include
- :initform nil
- :documentation "Additional texinfo included in this one."))
- "A top level texinfo file to build.")
-
-(defclass project-am-man (project-am-target)
- nil
- "A top level man file to build.")
-
-;; For generic files tracker like EXTRA_DIST
-(defclass project-am-built-src (project-am-target)
- ()
- "A group of Emacs Lisp programs to byte compile.")
-
-(defclass project-am-extra-dist (project-am-target)
- ()
- "A group of Emacs Lisp programs to byte compile.")
-
-(defclass project-am-makefile (ede-project)
- ((targets :initarg :targets
- :initform nil
- :documentation "Top level targets in this makefile.")
- (configureoutputfiles
- :initform nil
- :documentation
- "List of files output from configure system.")
- )
- "Encode one makefile.")
-
-;;; Code:
-(cl-defmethod project-add-file ((ot project-am-target) &optional _file)
- "Add the current buffer into a project.
-_FILE is ignored.
-OT is the object target. DIR is the directory to start in."
- (let* ((target (if ede-object (error "Already associated with a target")
- (let ((amf (project-am-load default-directory)))
- (if (not amf) (error "No project file"))
- (completing-read "Target: "
- (object-assoc-list 'name
- (oref amf targets))
- nil t))))
- ;; The input target might be new. See if we can find it.
- (amf (ede-target-parent ot))
- (ot (object-assoc target 'name (oref amf targets)))
- (ofn (file-name-nondirectory (buffer-file-name))))
- (if (not ot)
- (setq ot
- (project-new-target
- target (project-am-preferred-target-type (buffer-file-name)))))
- (ede-with-projectfile ot
- (makefile-move-to-macro (project-am-macro ot))
- (makefile-end-of-command)
- (insert " " ofn)
- (makefile-fill-paragraph nil)
- (project-rescan ot)
- (save-buffer))
- (setq ede-object ot)))
-
-(cl-defmethod project-remove-file ((ot project-am-target) fnnd)
- "Remove the current buffer from any project targets."
- (ede-with-projectfile ot
- (makefile-move-to-macro (project-am-macro ot))
- (makefile-navigate-macro (concat " *" (regexp-quote (ede-name fnnd))))
- (replace-match "" t t nil 0)
- (makefile-fill-paragraph nil)
- (project-rescan ot)
- (save-buffer))
- (setq ede-object nil))
-
-(cl-defmethod project-edit-file-target ((obj project-am-target))
- "Edit the target associated with this file."
- (find-file (concat (oref obj path) "Makefile.am"))
- (goto-char (point-min))
- (makefile-move-to-macro (project-am-macro obj))
- (if (= (point-min) (point))
- (re-search-forward (ede-target-name obj))))
-
-(cl-defmethod project-new-target ((_proj project-am-makefile)
- &optional name type)
- "Create a new target named NAME.
-Argument TYPE is the type of target to insert. This is a string
-matching something in `project-am-type-alist' or type class symbol.
-Despite the fact that this is a method, it depends on the current
-buffer being in order to provide a smart default target type."
- (let* ((name (or name (read-string "Name: " "")))
- (type (or type
- (completing-read "Type: "
- project-am-type-alist
- nil t
- (cond ((eq major-mode 'texinfo-mode)
- "texinfo")
- ((eq major-mode 'nroff-mode)
- "man")
- ((eq major-mode 'emacs-lisp-mode)
- "lisp")
- (t "bin")))))
- (ntype (assoc type project-am-type-alist))
- (ot nil))
- (setq ot (apply (car (cdr ntype)) name :name name
- :path (expand-file-name default-directory) nil))
- (if (not ot) (error "Error creating target object %S" ntype))
- (ede-with-projectfile ot
- (goto-char (point-min))
- (makefile-next-dependency)
- (if (= (point) (point-min))
- (goto-char (point-max))
- (beginning-of-line)
- (insert "\n")
- (forward-char -1))
- ;; Add the new target sources macro (if needed)
- (if (project-am-macro ot)
- (makefile-insert-macro (project-am-macro ot)))
- ;; Add to the list of objects.
- (goto-char (point-min))
- (makefile-move-to-macro (car (cdr (cdr ntype))))
- (if (= (point) (point-min))
- (progn
- (if (re-search-forward makefile-macroassign-regex nil t)
- (progn (forward-line -1)
- (end-of-line)
- (insert "\n"))
- ;; If the above search fails, that's ok. We'd just want to be at
- ;; point-min anyway.
- )
- (makefile-insert-macro (car (cdr (cdr ntype))))))
- (makefile-end-of-command)
- (insert " " (ede-target-name ot))
- (save-buffer)
- ;; Rescan the object in this makefile.
- (project-rescan ede-object))))
-
-;;
-;; NOTE TO SELF
-;;
-;; This should be handled at the EDE level, calling a method of the
-;; top most project.
-;;
-(cl-defmethod project-compile-project ((_obj project-am-target) &optional command)
- "Compile the entire current project.
-Argument COMMAND is the command to use when compiling."
- (require 'compile)
- (if (not command)
- (setq
- command
- ;; This interactive statement was taken from compile, and I'll
- ;; use the same command history too.
- (progn
- (if (not project-am-compile-project-command)
- (setq project-am-compile-project-command compile-command))
- (if (or compilation-read-command current-prefix-arg)
- (read-from-minibuffer "Project compile command: "
- ;; hardcode make -k
- ;; This is compile project after all.
- project-am-compile-project-command
- nil nil '(compile-history . 1))
- project-am-compile-project-command))))
- ;; When compile a project, we might be in a subdirectory,
- ;; so we have to make sure we move all the way to the top.
- (let* ((default-directory (project-am-find-topmost-level default-directory)))
- (compile command)))
-
-(cl-defmethod project-compile-project ((_obj project-am-makefile)
- &optional command)
- "Compile the entire current project.
-Argument COMMAND is the command to use when compiling."
- (require 'compile)
- (if (not command)
- (setq
- command
- ;; This interactive statement was taken from compile, and I'll
- ;; use the same command history too.
- (progn
- (if (not project-am-compile-project-command)
- (setq project-am-compile-project-command compile-command))
- (if (or compilation-read-command current-prefix-arg)
- (read-from-minibuffer "Project compile command: "
- ;; hardcode make -k
- ;; This is compile project after all.
- project-am-compile-project-command
- nil nil '(compile-history . 1))
- project-am-compile-project-command))))
- ;; When compile a project, we might be in a subdirectory,
- ;; so we have to make sure we move all the way to the top.
- (let* ((default-directory (project-am-find-topmost-level default-directory)))
- (compile command)))
-
-(cl-defmethod project-compile-target ((_obj project-am-target) &optional command)
- "Compile the current target.
-Argument COMMAND is the command to use for compiling the target."
- (require 'compile)
- (if (not project-am-compile-project-command)
- (setq project-am-compile-project-command compile-command))
- (if (not command)
- (setq
- command
- (if compilation-read-command
- (read-from-minibuffer "Project compile command: "
- ;; hardcode make -k
- ;; This is compile project after all.
- (if ede-object
- (format
- project-am-compile-target-command
- (project-compile-target-command
- ede-object))
- project-am-compile-target-command)
- nil nil
- '(compile-history . 1))
- (if ede-object
- project-am-compile-project-command
- (format
- project-am-compile-target-command
- (project-compile-target-command ede-object))))))
- ;; We better be in the right place when compiling a specific target.
- (compile command))
-
-(cl-defmethod project-debug-target ((obj project-am-objectcode))
- "Run the current project target in a debugger."
- (let ((tb (get-buffer-create " *padt*"))
- (dd (oref obj path))
- (cmd nil))
- (unwind-protect
- (progn
- (require 'ede/shell)
- (set-buffer tb)
- (setq default-directory dd)
- (setq cmd (read-from-minibuffer
- "Run (like this): "
- (concat (symbol-name project-am-debug-target-function)
- " " (ede-target-name obj))))
- (funcall project-am-debug-target-function cmd))
- (kill-buffer tb))))
-
-(declare-function ede-shell-run-something "ede/shell")
-
-(cl-defmethod project-run-target ((obj project-am-objectcode))
- "Run the current project target in comint buffer."
- (require 'ede/shell)
- (let ((tb (get-buffer-create " *padt*"))
- (dd (oref obj path))
- (cmd nil))
- (unwind-protect
- (progn
- (set-buffer tb)
- (setq default-directory dd)
- (setq cmd (read-from-minibuffer
- "Run (like this): "
- (concat "./" (ede-target-name obj))))
- (ede-shell-run-something obj cmd))
- (kill-buffer tb))))
-
-(cl-defmethod project-make-dist ((this project-am-target))
- "Run the current project in the debugger."
- (require 'compile)
- (if (not project-am-compile-project-command)
- (setq project-am-compile-project-command compile-command))
- (project-compile-project this (concat project-am-compile-project-command
- " dist")))
-
-;;; Project loading and saving
-;;
-(defun project-am-load (directory &optional _rootproj)
- "Read an automakefile DIRECTORY into our data structure.
-If a given set of projects has already been loaded, then do nothing
-but return the project for the directory given.
-Optional ROOTPROJ is the root EDE project."
- ;; Just jump into creating the project from the Makefiles.
- (project-am-load-makefile directory))
-
-(defun project-am-find-topmost-level (dir)
- "Find the topmost automakefile starting with DIR."
- (let ((newdir dir))
- (while (or (file-exists-p (concat newdir "Makefile.am"))
- (file-exists-p (concat newdir "configure.ac"))
- (file-exists-p (concat newdir "configure.in"))
- )
- (setq dir newdir newdir
- (file-name-directory (directory-file-name newdir))))
- (expand-file-name dir)))
-
-(defvar recentf-exclude)
-
-(defmacro project-am-with-makefile-current (dir &rest forms)
- "Set the Makefile.am in DIR to be the current buffer.
-Run FORMS while the makefile is current."
- (declare (indent 1) (debug (form def-body)))
- `(project-am--with-makefile-current ,dir (lambda () ,@forms)))
-
-(defun project-am--with-makefile-current (dir fun)
- (let* ((fn (expand-file-name "Makefile.am" dir))
- (kb (get-file-buffer fn)))
- (if (not (file-exists-p fn))
- nil
- (with-current-buffer
- (or kb
- ;; We need to find-file this thing, but don't use
- ;; any semantic features.
- (let ((semantic-init-hook nil)
- (recentf-exclude `(,(lambda (_f) t))))
- (find-file-noselect fn)))
- (unwind-protect (funcall fun)
- (if (not kb) (kill-buffer (current-buffer))))))))
-
-(defun project-am-load-makefile (path &optional suggestedname)
- "Convert PATH into a project Makefile, and return its project object.
-It does not check for existing project objects. Use `project-am-load'.
-Optional argument SUGGESTEDNAME will be the project name.
-This is used when subprojects are made in named subdirectories."
- (project-am-with-makefile-current path
- (if (and ede-object (project-am-makefile-p ede-object))
- ede-object
- (let* ((pi (project-am-package-info path))
- (fn buffer-file-name)
- (sfn (when suggestedname
- (project-am-last-dir suggestedname)))
- (pn (or sfn (nth 0 pi) (project-am-last-dir fn)))
- (ver (or (nth 1 pi) "0.0"))
- (bug (nth 2 pi))
- (cof (nth 3 pi))
- (ampf (project-am-makefile
- pn :name pn
- :version ver
- :mailinglist (or bug "")
- :file fn)))
- (oset ampf directory (file-name-directory fn))
- (oset ampf configureoutputfiles cof)
- (setq-local ede-object ampf)
- ;; Move the rescan after we set ede-object to prevent recursion
- (project-rescan ampf)
- ampf))))
-
-;;; Methods:
-(cl-defmethod project-targets-for-file ((proj project-am-makefile))
- "Return a list of targets the project PROJ."
- (oref proj targets))
-
-(defun project-am-scan-for-targets (currproj dir)
- "Scan the current Makefile.am for targets.
-CURRPROJ is the current project being scanned.
-DIR is the directory to apply to new targets."
- (let* ((otargets (oref currproj targets))
- ;; `ntargets' results in complete targets list
- ;; not only the new targets by diffing.
- (ntargets nil)
- (tmp nil)
- )
-
- (mapc
- ;; Map all the different types
- (lambda (typecar)
- (let ((macro (nth 2 typecar))
- (class (nth 1 typecar))
- (indirect (nth 3 typecar))
- )
- (if indirect
- ;; Map all the found objects
- (mapc (lambda (lstcar)
- (setq tmp (object-assoc lstcar 'name otargets))
- (when (not tmp)
- (setq tmp (apply class lstcar :name lstcar
- :path dir nil)))
- (project-rescan tmp)
- (setq ntargets (cons tmp ntargets)))
- (makefile-macro-file-list macro))
- ;; Non-indirect will have a target whose sources
- ;; are actual files, not names of other targets.
- (let ((files (makefile-macro-file-list macro)))
- (when files
- (setq tmp (object-assoc macro 'name otargets))
- (when (not tmp)
- (setq tmp (apply class macro :name macro
- :path dir nil)))
- (project-rescan tmp)
- (setq ntargets (cons tmp ntargets))
- ))
- )
- ))
- project-am-type-alist)
-
- ;; At now check variables for meta-target regexp
- ;; We have to check ntargets to avoid useless rescan.
- ;; Also we have check otargets to prevent duplication.
- (mapc
- (lambda (typecar)
- (let ((class (nth 0 typecar))
- (metaregex (nth 1 typecar))
- (indirect (nth 2 typecar)))
- (if indirect
- ;; Map all the found objects
- (mapc
- (lambda (lstcar)
- (unless (object-assoc lstcar 'name ntargets)
- (or
- (setq tmp (object-assoc lstcar 'name otargets))
- (setq tmp (apply class lstcar :name lstcar
- :path dir nil)))
- (project-rescan tmp)
- (setq ntargets (cons tmp ntargets))))
- ;; build a target list to map over
- (let (atargets)
- (dolist (TAG
- (semantic-find-tags-by-name-regexp
- metaregex (semantic-find-tags-by-class
- 'variable (semantic-fetch-tags))))
- ;; default-value have to be a list
- (when (cadr (assoc ':default-value TAG))
- (setq atargets
- (append
- (nreverse (cadr (assoc ':default-value TAG)))
- atargets))))
- (nreverse atargets)))
-
- ;; else not indirect, TODO: FIX various direct meta type in a sane way.
- (dolist (T (semantic-find-tags-by-name-regexp
- metaregex (semantic-find-tags-by-class
- 'variable (semantic-fetch-tags))))
- (unless (setq tmp (object-assoc (car T) 'name ntargets))
- (or (setq tmp (object-assoc (car T) 'name otargets))
- ;; we are really new
- (setq tmp (apply class (car T) :name (car T)
- :path dir nil)))
- (project-rescan tmp)
- (setq ntargets (cons tmp ntargets))))
- )))
- project-am-meta-type-alist)
- ntargets))
-
-(defun project-am-expand-subdirlist (place subdirs)
- "Store in PLACE the SUBDIRS expanded from variables.
-Strip out duplicates, and recurse on variables."
- (mapc (lambda (sp)
- (let ((var (makefile-extract-varname-from-text sp)))
- (if var
- ;; If it is a variable, expand that variable, and keep going.
- (project-am-expand-subdirlist
- place (makefile-macro-file-list var))
- ;; Else, add SP in if it isn't a dup.
- (cl-pushnew sp (gv-deref place) :test #'equal) ;; add
- )))
- subdirs)
- )
-
-(cl-defmethod project-rescan ((this project-am-makefile) &optional suggestedname)
- "Rescan the makefile for all targets and sub targets."
- (project-am-with-makefile-current (file-name-directory (oref this file))
- ;;(message "Scanning %s..." (oref this file))
- (let* ((pi (project-am-package-info (oref this directory)))
- (pn (nth 0 pi))
- (pv (nth 1 pi))
- (bug (nth 2 pi))
- (cof (nth 3 pi))
- (osubproj (oref this subproj))
- ;; 1/30/10 - We need to append these two lists together,
- ;; then strip out duplicates. Expanding this list (via
- ;; references to other variables should also strip out dups
- (csubproj (append
- (makefile-macro-file-list "DIST_SUBDIRS")
- (makefile-macro-file-list "SUBDIRS")))
- (csubprojexpanded nil)
- (nsubproj nil)
- ;; Targets are excluded here because they require
- ;; special attention.
- (dir (expand-file-name default-directory))
- (tmp nil)
- (ntargets (project-am-scan-for-targets this dir))
- )
- (if suggestedname
- (oset this name (project-am-last-dir suggestedname))
- ;; Else, setup toplevel project info.
- (and pn (string= (directory-file-name
- (oref this directory))
- (directory-file-name
- (project-am-find-topmost-level
- (oref this directory))))
- (oset this name pn)
- (and pv (oset this version pv))
- (and bug (oset this mailinglist bug))
- (oset this configureoutputfiles cof)))
- ;; Now that we have this new list, chuck the old targets
- ;; and replace it with the new list of targets I just created.
- (oset this targets (nreverse ntargets))
- ;; We still have a list of targets. For all buffers, make sure
- ;; their object still exists!
- ;; FIGURE THIS OUT
- (project-am-expand-subdirlist (gv-ref csubprojexpanded) csubproj)
- ;; Ok, now let's look at all our sub-projects.
- (mapc (lambda (sp)
- (let* ((subdir (file-name-as-directory
- (expand-file-name
- sp (file-name-directory (oref this file)))))
- (submake (expand-file-name
- "Makefile.am"
- subdir)))
- (if (string= submake (oref this file))
- nil ;; don't recurse.. please!
- ;; For each project id found, see if we need to recycle,
- ;; and if we do not, then make a new one. Check the deep
- ;; rescan value for behavior patterns.
- (setq tmp (object-assoc
- submake
- 'file osubproj))
- (if (not tmp)
- (setq tmp
- (condition-case nil
- ;; In case of problem, ignore it.
- (project-am-load-makefile subdir subdir)
- (error nil)))
- ;; If we have tmp, then rescan it only if deep mode.
- (if ede-deep-rescan
- (project-rescan tmp subdir)))
- ;; Tac tmp onto our list of things to keep, but only
- ;; if tmp was found.
- (when tmp
- ;;(message "Adding %S" (object-print tmp))
- (setq nsubproj (cons tmp nsubproj)))))
- )
- (nreverse csubprojexpanded))
- (oset this subproj nsubproj)
- ;; All elements should be updated now.
- )))
-
-
-(cl-defmethod project-rescan ((this project-am-program))
- "Rescan object THIS."
- (oset this source (makefile-macro-file-list (project-am-macro this)))
- (unless (oref this source)
- (oset this source (list (concat (oref this name) ".c"))))
- (oset this ldadd (makefile-macro-file-list
- (concat (oref this name) "_LDADD"))))
-
-(cl-defmethod project-rescan ((this project-am-lib))
- "Rescan object THIS."
- (oset this source (makefile-macro-file-list (project-am-macro this)))
- (unless (oref this source)
- (oset this source (list (concat (file-name-sans-extension
- (oref this name)) ".c")))))
-
-(cl-defmethod project-rescan ((this project-am-texinfo))
- "Rescan object THIS."
- (oset this include (makefile-macro-file-list (project-am-macro this))))
-
-(cl-defmethod project-rescan ((this project-am-man))
- "Rescan object THIS."
- (oset this source (makefile-macro-file-list (project-am-macro this))))
-
-(cl-defmethod project-rescan ((this project-am-lisp))
- "Rescan the Lisp sources."
- (oset this source (makefile-macro-file-list (project-am-macro this))))
-
-(cl-defmethod project-rescan ((this project-am-header))
- "Rescan the Header sources for object THIS."
- (oset this source (makefile-macro-file-list (project-am-macro this))))
-
-(cl-defmethod project-rescan ((this project-am-built-src))
- "Rescan built sources for object THIS."
- (oset this source (makefile-macro-file-list "BUILT_SOURCES")))
-
-(cl-defmethod project-rescan ((this project-am-extra-dist))
- "Rescan object THIS."
- (oset this source (makefile-macro-file-list "EXTRA_DIST")))
-
-(cl-defmethod project-am-macro ((this project-am-objectcode))
- "Return the default macro to `edit' for this object type."
- (concat (subst-char-in-string ?- ?_ (oref this name)) "_SOURCES"))
-
-(cl-defmethod project-am-macro ((_this project-am-header-noinst))
- "Return the default macro to `edit' for this object."
- "noinst_HEADERS")
-
-(cl-defmethod project-am-macro ((_this project-am-header-inst))
- "Return the default macro to `edit' for this object."
- "include_HEADERS")
-
-(cl-defmethod project-am-macro ((_this project-am-header-pkg))
- "Return the default macro to `edit' for this object."
- "pkginclude_HEADERS")
-
-(cl-defmethod project-am-macro ((_this project-am-header-chk))
- "Return the default macro to `edit' for this object."
- "check_HEADERS")
-
-(cl-defmethod project-am-macro ((this project-am-texinfo))
- "Return the default macro to `edit' for this object type."
- (concat (file-name-sans-extension (oref this name)) "_TEXINFOS"))
-
-(cl-defmethod project-am-macro ((this project-am-man))
- "Return the default macro to `edit' for this object type."
- (oref this name))
-
-(cl-defmethod project-am-macro ((_this project-am-lisp))
- "Return the default macro to `edit' for this object."
- "lisp_LISP")
-
-(defun project-am-buffer-object (amf buffer)
- "Return an object starting with AMF associated with BUFFER.
-nil means that this buffer belongs to no-one."
- (if (not amf)
- nil
- (if (ede-buffer-mine amf buffer)
- amf
- (let ((targ (oref amf targets))
- (sobj (oref amf subproj))
- (obj nil))
- (while (and targ (not obj))
- (if (ede-buffer-mine (car targ) buffer)
- (setq obj (car targ)))
- (setq targ (cdr targ)))
- (while (and sobj (not obj))
- (setq obj (project-am-buffer-object (car sobj) buffer)
- sobj (cdr sobj)))
- obj))))
-
-(cl-defmethod ede-buffer-mine ((this project-am-makefile) buffer)
- "Return t if object THIS lays claim to the file in BUFFER."
- (let ((efn (expand-file-name (buffer-file-name buffer))))
- (or (string= (oref this file) efn)
- (string-match "/configure\\(?:\\.ac\\|\\.in\\)?\\'" efn)
- ;; Search output files.
- (let ((ans nil))
- (dolist (f (oref this configureoutputfiles))
- (when (string-match (concat (regexp-quote f) "\\'") efn)
- (setq ans t)))
- ans)
- )))
-
-(cl-defmethod ede-buffer-mine ((this project-am-objectcode) buffer)
- "Return t if object THIS lays claim to the file in BUFFER."
- (member (file-relative-name (buffer-file-name buffer) (oref this path))
- (oref this source)))
-
-(cl-defmethod ede-buffer-mine ((this project-am-texinfo) buffer)
- "Return t if object THIS lays claim to the file in BUFFER."
- (let ((bfn (file-relative-name (buffer-file-name buffer)
- (oref this path))))
- (or (string= (oref this name) bfn)
- (member bfn (oref this include)))))
-
-(cl-defmethod ede-buffer-mine ((this project-am-man) buffer)
- "Return t if object THIS lays claim to the file in BUFFER."
- (string= (oref this name)
- (file-relative-name (buffer-file-name buffer) (oref this path))))
-
-(cl-defmethod ede-buffer-mine ((this project-am-lisp) buffer)
- "Return t if object THIS lays claim to the file in BUFFER."
- (member (file-relative-name (buffer-file-name buffer) (oref this path))
- (oref this source)))
-
-(cl-defmethod project-am-subtree ((ampf project-am-makefile) subdir)
- "Return the sub project in AMPF specified by SUBDIR."
- (object-assoc (expand-file-name subdir) 'file (oref ampf subproj)))
-
-(cl-defmethod project-compile-target-command ((_this project-am-target))
- "Default target to use when compiling a given target."
- ;; This is a pretty good default for most.
- "")
-
-(cl-defmethod project-compile-target-command ((this project-am-objectcode))
- "Default target to use when compiling an object code target."
- (oref this name))
-
-(cl-defmethod project-compile-target-command ((this project-am-texinfo))
- "Default target t- use when compiling a texinfo file."
- (let ((n (oref this name)))
- (if (string-match "\\.texi?\\(nfo\\)?" n)
- (setq n (replace-match ".info" t t n)))
- n))
-
-\f
-;;; Generic useful functions
-
-(defun project-am-last-dir (file)
- "Return the last part of a directory name.
-Argument FILE is the file to extract the end directory name from."
- (let* ((s (file-name-directory file))
- (d (directory-file-name s))
- )
- (file-name-nondirectory d))
- )
-
-(defun project-am-preferred-target-type (file)
- "For FILE, return the preferred type for that file."
- (cond ((string-match "\\.texi?\\(nfo\\)$" file)
- 'project-am-texinfo)
- ((string-match "\\.[0-9]$" file)
- 'project-am-man)
- ((string-match "\\.el$" file)
- 'project-am-lisp)
- (t
- 'project-am-program)))
-
-(cl-defmethod ede-buffer-header-file((this project-am-objectcode) _buffer)
- "There are no default header files."
- (or (cl-call-next-method)
- (let ((s (oref this source))
- (found nil))
- (while (and s (not found))
- ;; Add more logic here if applicable.
- (if (string-match "\\.\\(h\\|H\\|hh\\|hpp\\)" (car s))
- (setq found (car s)))
- (setq s (cdr s)))
- found)))
-
-(cl-defmethod ede-documentation ((this project-am-texinfo))
- "Return a list of files that provides documentation.
-Documentation is not for object THIS, but is provided by THIS for other
-files in the project."
- (let* ((src (append (oref this source)
- (oref this include)))
- (proj (ede-target-parent this))
- (dir (oref proj directory))
- (out nil))
- ;; Loop over all entries and expand
- (while src
- (setq out (cons
- (expand-file-name (car src) dir)
- out))
- (setq src (cdr src)))
- ;; return it
- out))
-
-
-;;; Configure.ac queries.
-;;
-(defvar project-am-autoconf-file-options
- '("configure.ac" "configure.in")
- "List of possible configure files to look in for project info.")
-
-(defun project-am-autoconf-file (dir)
- "Return the name of the autoconf file to use in DIR."
- (let ((ans nil))
- (dolist (L project-am-autoconf-file-options)
- (when (file-exists-p (expand-file-name L dir))
- (setq ans (expand-file-name L dir))))
- ans))
-
-(defmacro project-am-with-config-current (file &rest forms)
- "Set the Configure FILE in the top most directory above DIR as current.
-Run FORMS in the configure file.
-Kill the Configure buffer if it was not already in a buffer."
- (declare (indent 1) (debug t))
- `(with-temp-buffer
- (erase-buffer)
- (insert-file-contents ,file)
- ,@forms))
-
-(defun project-am-extract-shell-variable (var)
- "Extract the value of the shell variable VAR from a shell script."
- (save-excursion
- (goto-char (point-min))
- (when (re-search-forward (concat "^" (regexp-quote var) "\\s-*=\\s-*")
- nil t)
- (buffer-substring-no-properties (point) (line-end-position)))))
-
-(defun project-am-extract-package-info (dir)
- "Extract the package information for directory DIR."
- (let ((conf-in (project-am-autoconf-file dir))
- (conf-sh (expand-file-name "configure" dir))
- (name (file-name-nondirectory
- (directory-file-name dir)))
- (ver "1.0")
- (bugrep nil)
- (configfiles nil)
- )
- (cond
- ;; Try configure.ac or configure.in
- (conf-in
- (project-am-with-config-current conf-in
- (let ((aci (autoconf-parameters-for-macro "AC_INIT"))
- (aia (autoconf-parameters-for-macro "AM_INIT_AUTOMAKE"))
- (acf (autoconf-parameters-for-macro "AC_CONFIG_FILES"))
- (aco (autoconf-parameters-for-macro "AC_OUTPUT"))
- )
- (cond
- ;; AC init has more than 1 parameter
- ((> (length aci) 1)
- (setq name (nth 0 aci)
- ver (nth 1 aci)
- bugrep (nth 2 aci)))
- ;; The init automake has more than 1 parameter
- ((> (length aia) 1)
- (setq name (nth 0 aia)
- ver (nth 1 aia)
- bugrep (nth 2 aia)))
- )
- ;; AC_CONFIG_FILES, or AC_OUTPUT lists everything that
- ;; should be detected as part of this PROJECT, but not in a
- ;; particular TARGET.
- (let ((outfiles (cond (aco (list (car aco)))
- (t acf))))
- (if (> (length outfiles) 1)
- (setq configfiles outfiles)
- (setq configfiles (split-string (car outfiles) "\\s-" t)))
- )
- ))
- )
- ;; Else, try the script
- ((file-exists-p conf-sh)
- (project-am-with-config-current conf-sh
- (setq name (project-am-extract-shell-variable "PACKAGE_NAME")
- ver (project-am-extract-shell-variable "PACKAGE_VERSION")
- )
- ))
- ;; Don't know what else....
- (t
- nil))
- ;; Return stuff
- (list name ver bugrep configfiles)
- ))
-
-(defun project-am-package-info (dir)
- "Get the package information for directory topmost project dir over DIR.
-Calculates the info with `project-am-extract-package-info'."
- (let ((top (ede-toplevel)))
- (when top (setq dir (oref top directory)))
- (project-am-extract-package-info dir)))
-
-;; for simple per project include path extension
-(cl-defmethod ede-system-include-path ((_this project-am-makefile))
- "Return `project-am-localvars-include-path', usually local variable
-per file or in .dir-locals.el or similar."
- (bound-and-true-p project-am-localvars-include-path))
-
-(cl-defmethod ede-system-include-path ((_this project-am-target))
- "Return `project-am-localvars-include-path', usually local variable
-per file or in .dir-locals.el or similar."
- (bound-and-true-p project-am-localvars-include-path))
-
-
-(provide 'ede/project-am)
-
-;; Local variables:
-;; generated-autoload-load-name: "ede/project-am"
-;; End:
-
-;;; ede/project-am.el ends here
+++ /dev/null
-;;; ede/shell.el --- A shell controlled by EDE. -*- lexical-binding: t; -*-
-;;
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Run commands through a specialized EDE shell buffer. Commands will
-;; be run as shell commands so users can type in their own thing in
-;; the shells for testing purposes.
-;;
-;; Each thing that EDE wants to use will create a shell to interact with it.
-
-;;; Code:
-
-(require 'ede)
-
-(declare-function comint-send-input "comint")
-
-(cl-defmethod ede-shell-run-something ((target ede-target) command)
- "Create a shell to run stuff for TARGET.
-COMMAND is a text string representing the thing to be run."
- (let* ((buff (ede-shell-buffer target))
- (cp (ede-target-parent target))
- (dd (oref cp directory)))
- ;; Show the new buffer.
- (when (not (get-buffer-window buff))
- (switch-to-buffer-other-window buff t))
- ;; Force a shell into the buffer, but only if the buffer
- ;; doesn't already have a shell in it.
- ;; Newer versions of `shell' pop the window forward.
- (set-buffer buff)
- (when (not (eq major-mode 'shell-mode))
- (shell buff)
- ;; Make sure the shell has started.
- (while (eq (point-min) (point))
- (accept-process-output)))
- ;; Change the default directory
- (if (not (string= (file-name-as-directory (expand-file-name default-directory))
- (file-name-as-directory (expand-file-name dd))))
- ;; Go there.
- (setq command (concat (concat "cd " dd ";" command))))
- ;; Run the command itself.
- (ede-shell-run-command command)
- ))
-
-(defun ede-shell-run-command (command)
- "Run the COMMAND in the current shell-buffer."
- (require 'comint)
- ;; go to end
- (goto-char (point-max))
- ;; Insert the stuff.
- (goto-char (point-max))
- (insert command)
- ;; Send the command.
- (comint-send-input)
- )
-
-(cl-defmethod ede-shell-buffer ((target ede-target))
- "Get the buffer for running shell commands for TARGET."
- (let ((name (ede-name target)))
- (get-buffer-create (format "*EDE Shell %s*" name))))
-
-(provide 'ede/shell)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/shell"
-;; End:
-
-;;; ede/shell.el ends here
+++ /dev/null
-;;; ede/simple.el --- Overlay an EDE structure on an existing project -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; NOTE: EDE Simple Projects are considered obsolete. Use generic
-;; projects instead. They have much better automatic support and
-;; simpler configuration.
-;;
-;; A vast majority of projects use non-EDE project techniques, such
-;; as hand written Makefiles, or other IDE's.
-;;
-;; The EDE-SIMPLE project type allows EDE to wrap an existing mechanism
-;; with minimal configuration, and then provides project-root
-;; information to Semantic or other tools, and also provides structure
-;; information for in-project include header discovery, or speedbar
-;; support.
-;;
-;; It will also support a the minimal EDE UI for compilation and
-;; configuration.
-
-;; @todo - Add support for cpp-root as an ede-simple project.
-;; @todo - Allow ede-simple to store locally.
-
-(require 'ede)
-(require 'cedet-files)
-
-;;; Code:
-
-(add-to-list 'ede-project-class-files
- (ede-project-autoload
- :name "Simple" :file 'ede/simple
- :proj-file 'ede-simple-projectfile-for-dir
- :load-type 'ede-simple-load
- :class-sym 'ede-simple-project
- :safe-p nil)
- t)
-
-(defcustom ede-simple-save-directory "~/.ede"
- "Directory where simple EDE project overlays are saved."
- :group 'ede
- :type 'directory)
-
-(defcustom ede-simple-save-file-name "ProjSimple.ede"
- "File name used for simple project wrappers."
- :group 'ede
- :type 'string)
-
-(defun ede-simple-projectfile-for-dir (&optional dir)
- "Return a full file name to the project file stored in the current directory.
-The directory has three parts:
- <STORAGE ROOT>/<PROJ DIR AS FILE>/ProjSimple.ede"
- (let ((d (or dir default-directory)))
- (concat
- ;; Storage root
- (file-name-as-directory (expand-file-name ede-simple-save-directory))
- ;; Convert directory to filename
- (cedet-directory-name-to-file-name d)
- ;; Filename
- ede-simple-save-file-name)
- ))
-
-(defun ede-simple-load (dir &optional _rootproj)
- "Load a project of type `Simple' for the directory DIR.
-Return nil if there isn't one.
-ROOTPROJ is nil, since we will only create a single EDE project here."
- (let ((pf (ede-simple-projectfile-for-dir dir))
- (obj nil))
- (when pf
- (setq obj (eieio-persistent-read pf))
- (oset obj :directory dir)
- )
- obj))
-
-(defclass ede-simple-target (ede-target)
- ()
- "EDE Simple project target.
-All directories need at least one target.")
-
-(defclass ede-simple-project (ede-project eieio-persistent)
- ((extension :initform ".ede")
- (file-header-line :initform ";; EDE Simple Project")
- )
- "EDE Simple project class.
-Each directory needs a project file to control it.")
-
-(cl-defmethod ede-commit-project ((proj ede-simple-project))
- "Commit any change to PROJ to its file."
- (when (not (file-exists-p ede-simple-save-directory))
- (if (y-or-n-p (concat ede-simple-save-directory
- " doesn't exist. Create? "))
- (make-directory ede-simple-save-directory)
- (error "No save directory for new project")))
- (eieio-persistent-save proj))
-
-(cl-defmethod ede-find-subproject-for-directory ((proj ede-simple-project)
- _dir)
- "Return PROJ, for handling all subdirs below DIR."
- proj)
-
-(provide 'ede/simple)
-
-;; Local variables:
-;; generated-autoload-load-name: "ede/simple"
-;; End:
-
-;;; ede/simple.el ends here
+++ /dev/null
-;; ede/source.el --- EDE source code object -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000, 2008-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Manage different types of source code. A master list of source code types
-;; will be maintained, and used to track target objects, what they accept,
-;; and what compilers can be used.
-
-(require 'eieio-base)
-
-;;; Code:
-(defclass ede-sourcecode (eieio-instance-inheritor)
- ((name :initarg :name
- :type string
- :documentation
- "The name of this type of source code.
-Such as \"C\" or \"Emacs Lisp\"")
- (sourcepattern :initarg :sourcepattern
- :initform ".*"
- :type string
- :documentation
- "Emacs regexp matching sourcecode this target accepts.")
- (auxsourcepattern :initarg :auxsourcepattern
- :initform nil
- :type (or null string)
- :documentation
- "Emacs regexp matching auxiliary source code this target accepts.
-Aux source are source code files needed for compilation, which are not compiled
-themselves.")
- (enable-subdirectories :initarg :enable-subdirectories
- :initform nil
- :type boolean
- :documentation
- "Non nil if this sourcecode type uses subdirectories.
-If sourcecode always lives near the target creating it, this should be nil.
-If sourcecode can, or typically lives in a subdirectory of the owning
-target, set this to t.")
- (garbagepattern :initarg :garbagepattern
- :initform nil
- :type list
- :documentation
- "Shell file regexp matching files considered as garbage.
-This is a list of items added to an `rm' command when executing a `clean'
-type directive.")
- )
- "Description of some type of source code.
-Objects will use sourcecode objects to define the types of source
-that they are willing to use.")
-
-(defvar ede-sourcecode-list nil
- "The master list of all EDE compilers.")
-
-;;; Methods
-;;
-(cl-defmethod initialize-instance :after ((this ede-sourcecode) &rest _fields)
- "Make sure that all ede compiler objects are cached in
-`ede-compiler-list'."
- (let ((lst ede-sourcecode-list))
- ;; Find an object of the same name.
- (while (and lst (not (string= (oref this name) (oref (car lst) name))))
- (setq lst (cdr lst)))
- (if lst
- ;; Replace old definition
- (setcar lst this)
- ;; Add to the beginning of the list.
- (setq ede-sourcecode-list (cons this ede-sourcecode-list)))))
-
-(cl-defmethod ede-want-file-p ((this ede-sourcecode) filename)
- "Return non-nil if sourcecode definition THIS will take FILENAME."
- (or (ede-want-file-source-p this filename)
- (ede-want-file-auxiliary-p this filename)))
-
-(cl-defmethod ede-want-file-source-p ((this ede-sourcecode) filename)
- "Return non-nil if THIS will take FILENAME as an auxiliary."
- (let ((case-fold-search nil))
- (string-match (oref this sourcepattern) filename)))
-
-(cl-defmethod ede-want-file-auxiliary-p ((this ede-sourcecode) filename)
- "Return non-nil if THIS will take FILENAME as an auxiliary."
- (let ((case-fold-search nil))
- (and (slot-boundp this 'auxsourcepattern)
- (oref this auxsourcepattern)
- (string-match (oref this auxsourcepattern) filename))))
-
-(cl-defmethod ede-want-any-source-files-p ((this ede-sourcecode) filenames)
- "Return non-nil if THIS will accept any source files in FILENAMES."
- (let (found)
- (while (and (not found) filenames)
- (setq found (ede-want-file-source-p this (pop filenames))))
- found))
-
-(cl-defmethod ede-want-any-auxiliary-files-p ((this ede-sourcecode) filenames)
- "Return non-nil if THIS will accept any aux files in FILENAMES."
- (let (found)
- (while (and (not found) filenames)
- (setq found (ede-want-file-auxiliary-p this (pop filenames))))
- found))
-
-(cl-defmethod ede-want-any-files-p ((this ede-sourcecode) filenames)
- "Return non-nil if THIS will accept any files in FILENAMES."
- (let (found)
- (while (and (not found) filenames)
- (setq found (ede-want-file-p this (pop filenames))))
- found))
-
-(cl-defmethod ede-buffer-header-file ((this ede-sourcecode) filename)
- "Return a list of file names of header files for THIS with FILENAME.
-Used to guess header files, but uses the auxsource regular expression."
- (let ((dn (file-name-directory filename))
- (ts (file-name-sans-extension (file-name-nondirectory filename)))
- (ae (oref this auxsourcepattern)))
- (if (not ae)
- nil
- (directory-files dn t (concat (regexp-quote ts) ae)))))
-
-;;; Utility functions
-;;
-(when nil
- ;; not used at the moment.
-(defun ede-source-find (name)
- "Find the sourcecode object based on NAME."
- (object-assoc name :name ede-sourcecode-list))
-
-(defun ede-source-match (file)
- "Find the list of sourcecode objects which matches FILE."
- (let ((lst ede-sourcecode-list)
- (match nil))
- (while lst
- ;; ede-file-mine doesn't exist yet
- (if (ede-file-mine (car lst) file)
- (setq match (cons (car lst) match)))
- (setq lst (cdr lst)))
- match))
-)
-;;; Master list of source code types
-;;
-;; This must appear at the end so that the init method will work.
-(defvar ede-source-scheme
- (ede-sourcecode :name "Scheme"
- :sourcepattern "\\.scm$")
- "Scheme source code definition.")
-
-;;(defvar ede-source-
-;; (ede-sourcecode :name ""
-;; :sourcepattern "\\.$"
-;; :garbagepattern '("*."))
-;; " source code definition.")
-
-(provide 'ede/source)
-
-;;; ede/source.el ends here
+++ /dev/null
-;;; ede/speedbar.el --- Speedbar viewing of EDE projects -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1998-2001, 2003, 2005, 2007-2024 Free Software
-;; Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make, tags
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Display a project's hierarchy in speedbar.
-;;
-
-;;; Code:
-
-(require 'speedbar)
-(require 'eieio-speedbar)
-(require 'ede)
-
-;;; Speedbar support mode
-;;
-(defvar ede-speedbar-key-map nil
- "A Generic object based speedbar display keymap.")
-
-(defun ede-speedbar-make-map ()
- "Make the generic object based speedbar keymap."
- (setq ede-speedbar-key-map (speedbar-make-specialized-keymap))
-
- ;; General viewing things
- (define-key ede-speedbar-key-map "\C-m" #'speedbar-edit-line)
- (define-key ede-speedbar-key-map "+" #'speedbar-expand-line)
- (define-key ede-speedbar-key-map "=" #'speedbar-expand-line)
- (define-key ede-speedbar-key-map "-" #'speedbar-contract-line)
- (define-key ede-speedbar-key-map " " #'speedbar-toggle-line-expansion)
-
- ;; Some object based things
- (define-key ede-speedbar-key-map "C" #'eieio-speedbar-customize-line)
-
- ;; Some project based things
- (define-key ede-speedbar-key-map "R" #'ede-speedbar-remove-file-from-target)
- (define-key ede-speedbar-key-map "b" #'ede-speedbar-compile-line)
- (define-key ede-speedbar-key-map "B" #'ede-speedbar-compile-project)
- (define-key ede-speedbar-key-map "D" #'ede-speedbar-make-distribution)
- (define-key ede-speedbar-key-map "E" #'ede-speedbar-edit-projectfile)
- )
-
-(defvar ede-speedbar-menu
- '([ "Compile" ede-speedbar-compile-line t]
- [ "Compile Project" ede-speedbar-compile-project
- (cl-typep (speedbar-line-token) 'ede-project) ]
- "---"
- [ "Edit File/Tag" speedbar-edit-line
- (not (eieio-object-p (speedbar-line-token)))]
- [ "Expand" speedbar-expand-line
- (save-excursion (beginning-of-line)
- (looking-at "[0-9]+: *.\\+. "))]
- [ "Contract" speedbar-contract-line
- (save-excursion (beginning-of-line)
- (looking-at "[0-9]+: *.-. "))]
- "---"
- [ "Remove File from Target" ede-speedbar-remove-file-from-target
- (stringp (speedbar-line-token)) ]
- [ "Customize Project/Target" eieio-speedbar-customize-line
- (eieio-object-p (speedbar-line-token)) ]
- [ "Edit Project File" ede-speedbar-edit-projectfile t]
- [ "Make Distribution" ede-speedbar-make-distribution
- (cl-typep (speedbar-line-token) 'ede-project) ]
- )
- "Menu part in easymenu format used in speedbar while browsing objects.")
-
-(eieio-speedbar-create 'ede-speedbar-make-map
- 'ede-speedbar-key-map
- 'ede-speedbar-menu
- "Project"
- 'ede-speedbar-toplevel-buttons)
-
-
-(defun ede-speedbar ()
- "EDE development environment project browser for speedbar."
- (interactive)
- (speedbar-frame-mode 1)
- (speedbar-change-initial-expansion-list "Project")
- (speedbar-get-focus)
- )
-
-(defun ede-speedbar-toplevel-buttons (_dir)
- "Return a list of objects to display in speedbar.
-Argument DIR is the directory from which to derive the list of objects."
- ede-projects
- )
-
-;;; Some special commands useful in EDE
-;;
-(defun ede-speedbar-remove-file-from-target ()
- "Remove the file at point from its target."
- (interactive)
- (if (stringp (speedbar-line-token))
- (progn
- (speedbar-edit-line)
- (ede-remove-file))))
-
-(defun ede-speedbar-compile-line ()
- "Compile/Build the project or target on this line."
- (interactive)
- (let ((obj (eieio-speedbar-find-nearest-object)))
- (if (not (eieio-object-p obj))
- nil
- (cond ((obj-of-class-p obj 'ede-project)
- (project-compile-project obj))
- ((obj-of-class-p obj 'ede-target)
- (project-compile-target obj))
- (t (error "Error in speedbar structure"))))))
-
-(defun ede-speedbar-get-top-project-for-line ()
- "Return a project object for this line."
- (interactive)
- (let ((obj (eieio-speedbar-find-nearest-object)))
- (if (not (eieio-object-p obj))
- (error "Error in speedbar or ede structure")
- (if (obj-of-class-p obj 'ede-target)
- (setq obj (ede-target-parent obj)))
- (if (obj-of-class-p obj 'ede-project)
- obj
- (error "Error in speedbar or ede structure")))))
-
-(defun ede-speedbar-compile-project ()
- "Compile/Build the project which owns this line."
- (interactive)
- (project-compile-project (ede-speedbar-get-top-project-for-line)))
-
-(defun ede-speedbar-compile-file-project ()
- "Compile/Build the target which the current file belongs to."
- (interactive)
- (let* ((file (speedbar-line-file))
- (buf (find-file-noselect file))
- (bwin (get-buffer-window buf 0)))
- (if bwin
- (progn
- (select-window bwin)
- (raise-frame (window-frame bwin)))
- (dframe-select-attached-frame speedbar-frame)
- (set-buffer buf)
- (ede-compile-target))))
-
-(defun ede-speedbar-make-distribution ()
- "Edit the project file based on this line."
- (interactive)
- (project-make-dist (ede-speedbar-get-top-project-for-line)))
-
-(defun ede-speedbar-edit-projectfile ()
- "Edit the project file based on this line."
- (interactive)
- (project-edit-file-target (ede-speedbar-get-top-project-for-line)))
-
-;;; Speedbar Project Methods
-;;
-(defun ede-find-nearest-file-line ()
- "Go backwards until we find a file."
- (save-excursion
- (beginning-of-line)
- (looking-at "^\\([0-9]+\\):")
- (let ((depth (string-to-number (match-string 1))))
- (while (not (re-search-forward "[]] [^ ]" (line-end-position) t))
- (re-search-backward (format "^%d:" (1- depth)))
- (setq depth (1- depth)))
- (speedbar-line-token))))
-
-(cl-defmethod eieio-speedbar-derive-line-path ((obj ede-project) &optional _depth)
- "Return the path to OBJ.
-Optional DEPTH is the depth we start at."
- (file-name-directory (oref obj file))
- )
-
-(cl-defmethod eieio-speedbar-derive-line-path ((obj ede-target) &optional _depth)
- "Return the path to OBJ.
-Optional DEPTH is the depth we start at."
- (let ((proj (ede-target-parent obj)))
- ;; Check the type of line we are currently on.
- ;; If we are on a child, we need a file name too.
- (save-excursion
- (let ((lt (speedbar-line-token)))
- (if (or (eieio-object-p lt) (stringp lt))
- (eieio-speedbar-derive-line-path proj)
- ;; a child element is a token. Do some work to get a filename too.
- (concat (eieio-speedbar-derive-line-path proj)
- (ede-find-nearest-file-line)))))))
-
-(cl-defmethod eieio-speedbar-description ((obj ede-project))
- "Provide a speedbar description for OBJ."
- (ede-description obj))
-
-(cl-defmethod eieio-speedbar-description ((obj ede-target))
- "Provide a speedbar description for OBJ."
- (ede-description obj))
-
-(cl-defmethod eieio-speedbar-child-description ((_obj ede-target))
- "Provide a speedbar description for a plain-child of OBJ.
-A plain child is a child element which is not an EIEIO object."
- (or (speedbar-item-info-file-helper)
- (speedbar-item-info-tag-helper)))
-
-(cl-defmethod eieio-speedbar-object-buttonname ((object ede-project))
- "Return a string to use as a speedbar button for OBJECT."
- (if (ede-parent-project object)
- (ede-name object)
- (concat (ede-name object) " " (oref object version))))
-
-(cl-defmethod eieio-speedbar-object-buttonname ((object ede-target))
- "Return a string to use as a speedbar button for OBJECT."
- (ede-name object))
-
-(cl-defmethod eieio-speedbar-object-children ((this ede-project))
- "Return the list of speedbar display children for THIS."
- (condition-case nil
- (with-slots (subproj targets) this
- (append subproj targets))
- (error nil)))
-
-(cl-defmethod eieio-speedbar-object-children ((this ede-target))
- "Return the list of speedbar display children for THIS."
- (oref this source))
-
-(cl-defmethod eieio-speedbar-child-make-tag-lines ((this ede-target) depth)
- "Create a speedbar tag line for a child of THIS.
-It has depth DEPTH."
- (with-slots (source) this
- (mapcar (lambda (car)
- (speedbar-make-tag-line 'bracket ?+
- 'speedbar-tag-file
- car
- car
- 'ede-file-find
- car
- 'speedbar-file-face depth))
- source)))
-
-;;; Generic file management for TARGETS
-;;
-(defun ede-file-find (_text token indent)
- "Find the file TEXT at path TOKEN.
-INDENT is the current indentation level."
- (speedbar-find-file-in-frame
- (expand-file-name token (speedbar-line-directory indent)))
- (dframe-maybee-jump-to-attached-frame))
-
-(defun ede-create-tag-buttons (filename indent)
- "Create the tag buttons associated with FILENAME at INDENT."
- (let* ((lst (speedbar-fetch-dynamic-tags filename)))
- ;; if no list, then remove expando button
- (if (not lst)
- (speedbar-change-expand-button-char ??)
- (speedbar-with-writable
- ;; We must do 1- because indent was already incremented.
- (speedbar-insert-generic-list (1- indent)
- lst
- 'ede-tag-expand
- 'ede-tag-find)))))
-
-(defun ede-tag-expand (text token indent)
- "Expand a tag sublist. Imenu will return sub-lists of specialized tag types.
-Etags does not support this feature. TEXT will be the button
-string. TOKEN will be the list, and INDENT is the current indentation
-level."
- (cond ((string-search "+" text) ;we have to expand this file
- (speedbar-change-expand-button-char ?-)
- (speedbar-with-writable
- (save-excursion
- (end-of-line) (forward-char 1)
- (speedbar-insert-generic-list indent token
- 'ede-tag-expand
- 'ede-tag-find))))
- ((string-search "-" text) ;we have to contract this node
- (speedbar-change-expand-button-char ?+)
- (speedbar-delete-subblock indent))
- (t (error "Ooops... not sure what to do")))
- (speedbar-center-buffer-smartly))
-
-(defun ede-tag-find (_text token _indent)
- "For the tag TEXT in a file TOKEN, goto that position.
-INDENT is the current indentation level."
- (let ((file (ede-find-nearest-file-line)))
- (speedbar-find-file-in-frame file)
- (save-excursion (speedbar-stealthy-updates))
- ;; Reset the timer with a new timeout when clicking a file
- ;; in case the user was navigating directories, we can cancel
- ;; that other timer.
-; (speedbar-set-timer speedbar-update-speed)
- (goto-char token)
- (run-hooks 'speedbar-visiting-tag-hook)
- ;;(recenter)
- (dframe-maybee-jump-to-attached-frame)
- ))
-
-;;; EDE and the speedbar FILE display
-;;
-;; This will add a couple keybindings and menu items into the
-;; FILE display for speedbar.
-
-(defvar ede-speedbar-file-menu-additions
- '("----"
- ["Create EDE Target" ede-new-target (ede-current-project) ]
- ;; ["Add to project" ede-speedbar-file-add-to-project (ede-current-project) ]
- ["Compile project" ede-speedbar-compile-project (ede-current-project) ]
- ;; ["Compile file target" ede-speedbar-compile-file-target (ede-current-project) ]
- ["Make distribution" ede-make-dist (ede-current-project) ]
- )
- "Set of menu items to splice into the speedbar menu.")
-
-(defvar ede-speedbar-file-keymap
- (let ((km (make-sparse-keymap)))
- ;; (define-key km "a" #'ede-speedbar-file-add-to-project)
- (define-key km "t" #'ede-new-target)
- (define-key km "s" #'ede-speedbar)
- (define-key km "C" #'ede-speedbar-compile-project)
- ;; (define-key km "c" #'ede-speedbar-compile-file-target)
- (define-key km "d" #'ede-make-dist)
- km)
- "Keymap spliced into the speedbar keymap.")
-
-;;;###autoload
-(defun ede-speedbar-file-setup ()
- "Setup some keybindings in the Speedbar File display."
- (setq speedbar-easymenu-definition-special
- (append speedbar-easymenu-definition-special
- ede-speedbar-file-menu-additions
- ))
- (define-key speedbar-file-key-map "." ede-speedbar-file-keymap)
- ;; Finally, if the FILES mode is loaded, force a refresh
- ;; of the menus and such.
- (when (and (string= speedbar-initial-expansion-list-name "files")
- (buffer-live-p speedbar-buffer)
- )
- (speedbar-change-initial-expansion-list "files")))
-
-(provide 'ede/speedbar)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/speedbar"
-;; End:
-
-;;; ede/speedbar.el ends here
+++ /dev/null
-;;; ede/srecode.el --- EDE utilities on top of SRecoder -*- lexical-binding: t -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; EDE utilities for using SRecode to generate project files, such as
-;; Makefiles.
-
-(require 'srecode)
-
-(declare-function srecode-create-dictionary "srecode/dictionary")
-(declare-function srecode-dictionary-set-value "srecode/dictionary")
-(declare-function srecode-load-tables-for-mode "srecode/find")
-(declare-function srecode-table "srecode/find")
-(declare-function srecode-template-get-table "srecode/find")
-(declare-function srecode-insert-fcn "srecode/insert")
-(declare-function srecode-resolve-arguments "srecode/insert")
-(declare-function srecode-map-update-map "srecode/map")
-
-;;; Code:
-(defun ede-srecode-setup ()
- "Initialize Srecode for EDE."
- (require 'srecode/map)
- (require 'srecode/find)
- (srecode-map-update-map t)
- ;; We don't call this unless we need it. Load in the templates.
- (srecode-load-tables-for-mode 'makefile-mode)
- (srecode-load-tables-for-mode 'makefile-mode 'ede)
- (srecode-load-tables-for-mode 'autoconf-mode)
- (srecode-load-tables-for-mode 'autoconf-mode 'ede))
-
-(defmacro ede-srecode-insert-with-dictionary (template &rest forms)
- "Insert TEMPLATE after executing FORMS with a dictionary.
-TEMPLATE should specify a context by using a string format of:
- context:templatename
-Locally binds the variable DICT to a dictionary which can be
-updated in FORMS."
- `(let* ((dict (srecode-create-dictionary))
- (temp (srecode-template-get-table (srecode-table)
- ,template
- nil
- 'ede))
- )
- (when (not temp)
- (error "EDE template %s for %s not found!"
- ,template major-mode))
- (srecode-resolve-arguments temp dict)
-
- ;; Now execute forms for updating DICT.
- (progn ,@forms)
-
- (srecode-insert-fcn temp dict)
- ))
-
-(defun ede-srecode-insert (template &rest dictionary-entries)
- "Insert at the current point TEMPLATE.
-TEMPLATE should specify a context by using a string format of:
- context:templatename
-Add DICTIONARY-ENTRIES into the dictionary before insertion.
-Note: Just like `srecode-insert', but templates found in `ede' app."
- (require 'srecode/insert)
- (ede-srecode-insert-with-dictionary template
-
- ;; Add in optional dictionary entries.
- (while dictionary-entries
- (srecode-dictionary-set-value dict
- (car dictionary-entries)
- (car (cdr dictionary-entries)))
- (setq dictionary-entries
- (cdr (cdr dictionary-entries))))
- ))
-
-(provide 'ede/srecode)
-
-;;; ede/srecode.el ends here
+++ /dev/null
-;;; ede-system.el --- EDE working with the system (VC, FTP, ETC) -*- lexical-binding: t -*-
-
-;; Copyright (C) 2001-2003, 2009-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make, vc
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; EDE system contains some routines to work with EDE projects saved in
-;; CVS repositories, and services such as sourceforge which lets you
-;; perform releases via FTP.
-
-(require 'ede)
-
-;;; Code:
-
-;;; Web/FTP site node.
-
-;;;###autoload
-(defun ede-web-browse-home ()
- "Browse the website of the current project."
- (interactive)
- (if (not (ede-toplevel))
- (error "No project"))
- (let ((home (oref (ede-toplevel) web-site-url)))
- (if (string= "" home)
- (error "Now URL is stored in this project"))
- (require 'browse-url)
- (browse-url home)
- ))
-
-;;;###autoload
-(defun ede-edit-web-page ()
- "Edit the web site for this project."
- (interactive)
- (let* ((toplevel (ede-toplevel))
- (dir (oref toplevel web-site-directory))
- (file (oref toplevel web-site-file))
- (endfile (concat (file-name-as-directory dir) file)))
- (if (string-match "^/r[:@]" endfile)
- (require 'tramp))
- (when (not (file-exists-p endfile))
- (setq endfile file)
- (if (string-match "^/r[:@]" endfile)
- (require 'tramp))
- (if (not (file-exists-p endfile))
- (error "No project file found")))
- (find-file endfile)))
-
-;;;###autoload
-(defun ede-upload-distribution ()
- "Upload the current distribution to the correct location.
-Use /user@ftp.site.com: file names for FTP sites.
-Download tramp, and use /r:machine: for names on remote sites w/out FTP access."
- (interactive)
- (let* ((files (project-dist-files (ede-toplevel)))
- (upload (if (string= (oref (ede-toplevel) ftp-upload-site) "")
- (oref (ede-toplevel) ftp-site)
- (oref (ede-toplevel) ftp-upload-site))))
- (when (or (string= upload "")
- (not (file-exists-p upload)))
- (error "Upload directory %S does not exist" upload))
- (while files
- (let ((localfile (concat (file-name-directory (oref (ede-toplevel) file))
- (car files))))
- (if (not (file-exists-p localfile))
- (progn
- (message "File %s does not exist yet. Building a distribution"
- localfile)
- (ede-make-dist)
- (error "File %s does not exist yet. Building a distribution"
- localfile)
- ))
- (setq upload
- (concat (directory-file-name upload)
- "/"
- (file-name-nondirectory localfile)))
- (copy-file localfile upload)
- (setq files (cdr files)))))
- (message "Done uploading files...")
- )
-
-;;;###autoload
-(defun ede-upload-html-documentation ()
- "Upload the current distributions documentation as HTML.
-Use /user@ftp.site.com: file names for FTP sites.
-Download tramp, and use /r:machine: for names on remote sites w/out FTP access."
- (interactive)
- (let* ((files nil) ;(ede-html-doc-files (ede-toplevel)))
- (upload (if (string= (oref (ede-toplevel) ftp-upload-site) "")
- (oref (ede-toplevel) ftp-site)
- (oref (ede-toplevel) ftp-upload-site))))
- (when (or (string= upload "")
- (not (file-exists-p upload)))
- (error "Upload directory %S does not exist" upload))
- (while files
- (let ((localfile (concat (file-name-directory (oref (ede-toplevel) file))
- (car files))))
- (if (not (file-exists-p localfile))
- (progn
- (message "File %s does not exist yet. Building a distribution"
- localfile)
- ;;(project-compile-target ... )
- (error "File %s does not exist yet. Building a distribution"
- localfile)
- ))
- (copy-file localfile upload)
- (setq files (cdr files)))))
- (message "Done uploading files...")
- )
-
-;;; Version Control
-;;
-;; Do a few nice things with Version control systems.
-
-;;;###autoload
-(defun ede-vc-project-directory ()
- "Run `vc-dir' on the current project."
- (interactive)
- (let ((top (ede-toplevel-project default-directory)))
- (vc-dir top nil)))
-
-(provide 'ede/system)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/system"
-;; End:
-
-;;; ede/system.el ends here
+++ /dev/null
-;;; ede/util.el --- EDE utilities -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000, 2005, 2009-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Utilities that may not require project specific help, and operate
-;; on generic EDE structures. Provide user level commands for activities
-;; not directly related to source code organization or makefile generation.
-
-(require 'ede)
-
-;;; Code:
-
-;;; Updating the version of a project.
-;;;###autoload
-(defun ede-update-version (newversion)
- "Update the current projects main version number.
-Argument NEWVERSION is the version number to use in the current project."
- (interactive (list (let* ((o (ede-toplevel))
- (v (oref o version)))
- (read-string (format "Update Version (was %s): " v)
- v nil v))))
- (let ((ede-object (ede-toplevel)))
- ;; Don't update anything if there was no change.
- (unless (string= (oref ede-object version) newversion)
- (oset ede-object version newversion)
- (project-update-version ede-object)
- (ede-update-version-in-source ede-object newversion))))
-
-(cl-defmethod project-update-version ((ot ede-project))
- "The :version of the project OT has been updated.
-Handle saving, or other detail."
- (error "project-update-version not supported by %s" (eieio-object-name ot)))
-
-(cl-defmethod ede-update-version-in-source ((this ede-project) version)
- "Change occurrences of a version string in sources.
-In project THIS, cycle over all targets to give them a chance to set
-their sources to VERSION."
- (ede-map-targets this (lambda (targ)
- (ede-update-version-in-source targ version))))
-
-(cl-defmethod ede-update-version-in-source ((this ede-target) version)
- "In sources for THIS, change version numbers to VERSION."
- (if (and (slot-boundp this 'versionsource)
- (oref this versionsource))
- (let ((vs (oref this versionsource)))
- (while vs
- (with-current-buffer (find-file-noselect
- (ede-expand-filename this (car vs)))
- (goto-char (point-min))
- (let ((case-fold-search t))
- (if (re-search-forward "version:\\s-*\\([^ \t\n]+\\)" nil t)
- (progn
- (save-match-data
- (ede-make-buffer-writable))
- (delete-region (match-beginning 1)
- (match-end 1))
- (goto-char (match-beginning 1))
- (insert version)))))
- (setq vs (cdr vs))))))
-
-;;; Writable files
-;;
-;; Utils for EDE when it needs to write a file that could be covered by a
-;; version control system.
-(defun ede-make-buffer-writable (&optional buffer)
- "Make sure that BUFFER is writable.
-If BUFFER isn't specified, use the current buffer."
- (save-excursion
- (if buffer (set-buffer buffer))
- (setq buffer-read-only nil)))
-
-(provide 'ede/util)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "ede/util"
-;; End:
-
-;;; ede/util.el ends here
+++ /dev/null
-;;; mode-local.el --- Support for mode local facilities -*- lexical-binding:t -*-
-;;
-;; Copyright (C) 2004-2005, 2007-2024 Free Software Foundation, Inc.
-;;
-;; Author: David Ponce <david@dponce.com>
-;; Created: 27 Apr 2004
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Each major mode will want to support a specific set of behaviors.
-;; Usually generic behaviors that need just a little bit of local
-;; specifics.
-;;
-;; This library permits the setting of override functions for tasks of
-;; that nature, and also provides reasonable defaults.
-;;
-;; There are buffer local variables (and there were frame local variables).
-;; This library gives the illusion of mode specific variables.
-;;
-;; You should use a mode-local variable or override to allow extension
-;; only if you expect a mode author to provide that extension. If a
-;; user might wish to customize a given variable or function then
-;; the existing customization mechanism should be used.
-
-;; To Do:
-;; Allow customization of a variable for a specific mode?
-;;
-;; Add macro for defining the '-default' functionality.
-
-;;; Code:
-
-(require 'find-func)
-;; For find-function-regexp-alist. It is tempting to replace this
-;; ‘require’ by (defvar find-function-regexp-alist) and
-;; with-eval-after-load, but model-local.el is typically loaded when a
-;; semantic autoload is invoked, and something in semantic loads
-;; find-func.el before mode-local.el, so the eval-after-load is lost.
-
-;;; Misc utilities
-;;
-(defun mode-local-map-file-buffers (function &optional predicate buffers)
- "Run FUNCTION on every file buffer found.
-FUNCTION does not have arguments; when it is entered `current-buffer'
-is the currently selected file buffer.
-If optional argument PREDICATE is non-nil, only select file buffers
-for which the function PREDICATE returns non-nil.
-If optional argument BUFFERS is non-nil, it is a list of buffers to
-walk through. It defaults to `buffer-list'."
- (dolist (b (or buffers (buffer-list)))
- (and (buffer-live-p b) (buffer-file-name b)
- (with-current-buffer b
- (when (or (not predicate) (funcall predicate))
- (funcall function))))))
-
-(defun get-mode-local-parent (mode)
- "Return the mode parent of the major mode MODE.
-Return nil if MODE has no parent."
- (declare (obsolete derived-mode-all-parents "30.1"))
- (or (get mode 'mode-local-parent)
- (get mode 'derived-mode-parent)))
-
-(define-obsolete-function-alias 'mode-local-equivalent-mode-p
- #'derived-mode-all-parents "30.1")
-
-(defun mode-local-map-mode-buffers (function modes)
- "Run FUNCTION on every file buffer with major mode in MODES.
-MODES can be a symbol or a list of symbols.
-FUNCTION does not have arguments."
- (setq modes (ensure-list modes))
- (mode-local-map-file-buffers
- function (lambda () (apply #'derived-mode-p modes))))
-\f
-;;; Hook machinery
-;;
-(defvar mode-local-init-hook nil
- "Hook run after a new file buffer is created.
-The current buffer is the newly created file buffer.")
-
-(defvar mode-local-changed-mode-buffers nil
- "List of buffers whose `major-mode' has changed recently.")
-
-(defvar mode-local--init-mode nil)
-
-(defsubst mode-local-initialized-p ()
- "Return non-nil if mode local is initialized in current buffer.
-That is, if the current `major-mode' is equal to the major mode for
-which mode local bindings have been activated."
- (eq mode-local--init-mode major-mode))
-
-(defun mode-local-post-major-mode-change ()
- "Initialize mode-local facilities.
-This is run from `find-file-hook', and from `post-command-hook'
-after changing the major mode."
- (remove-hook 'post-command-hook #'mode-local-post-major-mode-change nil)
- (let ((buffers mode-local-changed-mode-buffers))
- (setq mode-local-changed-mode-buffers nil)
- (mode-local-map-file-buffers
- (lambda ()
- ;; Make sure variables are set up for this mode.
- (mode-local--activate-bindings)
- (run-hooks 'mode-local-init-hook))
- (lambda ()
- (not (mode-local-initialized-p)))
- buffers)))
-
-(defun mode-local-on-major-mode-change ()
- "Function called in `change-major-mode-hook'."
- (add-to-list 'mode-local-changed-mode-buffers (current-buffer))
- (add-hook 'post-command-hook #'mode-local-post-major-mode-change t nil))
-\f
-;;; Mode lineage
-;;
-(define-obsolete-function-alias 'set-mode-local-parent
- #'mode-local--set-parent "27.1")
-(defsubst mode-local--set-parent (mode parent)
- "Set parent of major mode MODE to PARENT mode.
-To work properly, this function should be called after PARENT mode
-local variables have been defined."
- (declare (obsolete derived-mode-add-parents "30.1"))
- (derived-mode-add-parents mode (list parent))
- ;; Refresh mode bindings to get mode local variables inherited from
- ;; PARENT. To work properly, the following should be called after
- ;; PARENT mode local variables have been defined.
- (mode-local-map-mode-buffers #'mode-local--activate-bindings mode))
-
-(defmacro define-child-mode (mode parent &optional _docstring)
- "Make major mode MODE inherit behavior from PARENT mode.
-DOCSTRING is optional and not used.
-To work properly, this should be put after PARENT mode local variables
-definition."
- (declare (obsolete define-derived-mode "27.1") (indent 2))
- `(mode-local--set-parent ',mode ',parent))
-
-(define-obsolete-function-alias 'mode-local-use-bindings-p
- #'provided-mode-derived-p "30.1")
-
-\f
-;;; Core bindings API
-;;
-(defvar-local mode-local-symbol-table nil
- "Buffer local mode bindings.
-These symbols provide a hook for a `major-mode' to specify specific
-behaviors. Use the function `mode-local-bind' to define new bindings.")
-
-(defvar mode-local-active-mode nil
- "Major mode in which bindings are active.")
-
-(define-obsolete-function-alias 'new-mode-local-bindings
- #'mode-local--new-bindings "27.1")
-(defsubst mode-local--new-bindings ()
- "Return a new empty mode bindings symbol table."
- (obarray-make 13))
-
-(defun mode-local-bind (bindings &optional plist mode)
- "Define BINDINGS in the specified environment.
-BINDINGS is a list of (VARIABLE . VALUE).
-Optional argument PLIST is a property list each VARIABLE symbol will
-be set to. The following properties have special meaning:
-
-- `constant-flag' if non-nil, prevent rebinding variables.
-- `mode-variable-flag' if non-nil, define mode variables.
-- `override-flag' if non-nil, define override functions.
-
-The `override-flag' and `mode-variable-flag' properties are mutually
-exclusive.
-
-If optional argument MODE is non-nil, it must be a major mode symbol.
-BINDINGS will be defined globally for this major mode. If MODE is
-nil, BINDINGS will be defined locally in the current buffer, in
-variable `mode-local-symbol-table'. The later should be done in MODE
-hook."
- ;; Check plist consistency
- (and (plist-get plist 'mode-variable-flag)
- (plist-get plist 'override-flag)
- (error "Bindings can't be both overrides and mode variables"))
- (let (table variable varname value binding)
- (if mode
- (progn
- ;; Install in given MODE symbol table. Create a new one if
- ;; needed.
- (setq table (or (get mode 'mode-local-symbol-table)
- (mode-local--new-bindings)))
- (put mode 'mode-local-symbol-table table))
- ;; Fail if trying to bind mode variables in local context!
- (if (plist-get plist 'mode-variable-flag)
- (error "Mode required to bind mode variables"))
- ;; Install in buffer local symbol table. Create a new one if
- ;; needed.
- (setq table (or mode-local-symbol-table
- (setq mode-local-symbol-table
- (mode-local--new-bindings)))))
- (while bindings
- (setq binding (car bindings)
- bindings (cdr bindings)
- varname (symbol-name (car binding))
- value (cdr binding))
- (if (setq variable (intern-soft varname table))
- ;; Binding already exists
- ;; Check rebind consistency
- (cond
- ((equal (symbol-value variable) value)
- ;; Just ignore rebind with the same value.
- )
- ((get variable 'constant-flag)
- (error "Can't change the value of constant `%s'"
- variable))
- ((and (get variable 'mode-variable-flag)
- (plist-get plist 'override-flag))
- (error "Can't rebind override `%s' as a mode variable"
- variable))
- ((and (get variable 'override-flag)
- (plist-get plist 'mode-variable-flag))
- (error "Can't rebind mode variable `%s' as an override"
- variable))
- (t
- ;; Merge plist and assign new value
- (setplist variable (append plist (symbol-plist variable)))
- (set variable value)))
- ;; New binding
- (setq variable (intern varname table))
- ;; Set new plist and assign initial value
- (setplist variable plist)
- (set variable value)))
- ;; Return the symbol table used
- table))
-
-(defsubst mode-local-symbol (symbol &optional mode)
- "Return the mode local symbol bound with SYMBOL's name.
-Return nil if the mode local symbol doesn't exist.
-If optional argument MODE is nil, lookup first into locally bound
-symbols, then in those bound in current `major-mode' and its parents.
-If MODE is non-nil, lookup into symbols bound in that major mode and
-its parents."
- (let ((name (symbol-name symbol)) bind)
- (or mode
- (setq mode mode-local-active-mode)
- (setq mode major-mode
- bind (and mode-local-symbol-table
- (intern-soft name mode-local-symbol-table))))
- (let ((parents (derived-mode-all-parents mode)))
- (while (and parents (not bind))
- (or (and (get (car parents) 'mode-local-symbol-table)
- (setq bind (intern-soft
- name (get (car parents)
- 'mode-local-symbol-table))))
- (setq parents (cdr parents)))))
- bind))
-
-(defsubst mode-local-symbol-value (symbol &optional mode property)
- "Return the value of the mode local symbol bound with SYMBOL's name.
-If optional argument MODE is non-nil, restrict lookup to that mode and
-its parents (see the function `mode-local-symbol' for more details).
-If optional argument PROPERTY is non-nil the mode local symbol must
-have that property set. Return nil if the symbol doesn't exist, or
-doesn't have PROPERTY set."
- (and (setq symbol (mode-local-symbol symbol mode))
- (or (not property) (get symbol property))
- (symbol-value symbol)))
-\f
-;;; Mode local variables
-;;
-(define-obsolete-function-alias 'activate-mode-local-bindings
- #'mode-local--activate-bindings "27.1")
-(defun mode-local--activate-bindings (&optional mode)
- "Activate variables defined locally in MODE and its parents.
-That is, copy mode local bindings into corresponding buffer local
-variables.
-If MODE is not specified it defaults to current `major-mode'.
-Return the alist of buffer-local variables that have been changed.
-Elements are (SYMBOL . PREVIOUS-VALUE), describing one variable."
- ;; Hack -
- ;; do not do this if we are inside set-auto-mode as we may be in
- ;; an initialization race condition.
- (if (boundp 'keep-mode-if-same)
- ;; We are inside set-auto-mode, as this is an argument that is
- ;; vaguely unique.
-
- ;; This will make sure that when everything is over, this will get
- ;; called and we won't be under set-auto-mode anymore.
- (mode-local-on-major-mode-change)
-
- ;; Do the normal thing.
- (let (table old-locals)
- (unless mode
- (setq-local mode-local--init-mode major-mode)
- (setq mode major-mode))
- ;; Activate mode bindings following parent modes order.
- (dolist (mode (derived-mode-all-parents mode))
- (when (setq table (get mode 'mode-local-symbol-table))
- (mapatoms
- (lambda (var)
- (when (get var 'mode-variable-flag)
- (let ((v (intern (symbol-name var))))
- ;; Save the current buffer-local value of the
- ;; mode-local variable.
- (and (local-variable-p v (current-buffer))
- (push (cons v (symbol-value v)) old-locals))
- (set (make-local-variable v) (symbol-value var)))))
- table)))
- old-locals)))
-
-(define-obsolete-function-alias 'deactivate-mode-local-bindings
- #'mode-local--deactivate-bindings "27.1")
-(defun mode-local--deactivate-bindings (&optional mode)
- "Deactivate variables defined locally in MODE and its parents.
-That is, kill buffer local variables set from the corresponding mode
-local bindings.
-If MODE is not specified it defaults to current `major-mode'."
- (unless mode
- (kill-local-variable 'mode-local--init-mode)
- (setq mode major-mode))
- (let (table)
- (dolist (mode (derived-mode-all-parents mode))
- (when (setq table (get mode 'mode-local-symbol-table))
- (mapatoms
- (lambda (var)
- (when (get var 'mode-variable-flag)
- (kill-local-variable (intern (symbol-name var)))))
- table)))))
-
-(defmacro with-mode-local-symbol (mode &rest body)
- "With the local bindings of MODE symbol, evaluate BODY.
-The current mode bindings are saved, BODY is evaluated, and the saved
-bindings are restored, even in case of an abnormal exit.
-Value is what BODY returns.
-This is like `with-mode-local', except that MODE's value is used.
-To use the symbol MODE (quoted), use `with-mode-local'."
- (declare (indent 1))
- (let ((old-mode (make-symbol "mode"))
- (old-locals (make-symbol "old-locals"))
- (new-mode (make-symbol "new-mode"))
- (local (make-symbol "local")))
- `(let ((,old-mode mode-local-active-mode)
- (,old-locals nil)
- (,new-mode ,mode)
- )
- (unwind-protect
- (progn
- (mode-local--deactivate-bindings ,old-mode)
- (setq mode-local-active-mode ,new-mode)
- ;; Save the previous value of buffer-local variables
- ;; changed by `mode-local--activate-bindings'.
- (setq ,old-locals (mode-local--activate-bindings ,new-mode))
- ,@body)
- (mode-local--deactivate-bindings ,new-mode)
- ;; Restore the previous value of buffer-local variables.
- (dolist (,local ,old-locals)
- (set (car ,local) (cdr ,local)))
- ;; Restore the mode local variables.
- (setq mode-local-active-mode ,old-mode)
- (mode-local--activate-bindings ,old-mode)))))
-
-(defmacro with-mode-local (mode &rest body)
- "With the local bindings of MODE, evaluate BODY.
-The current mode bindings are saved, BODY is evaluated, and the saved
-bindings are restored, even in case of an abnormal exit.
-Value is what BODY returns.
-This is like `with-mode-local-symbol', except that MODE is quoted
-and is not evaluated."
- (declare (indent 1))
- `(with-mode-local-symbol ',mode ,@body))
-
-
-(defsubst mode-local-value (mode sym)
- "Return the value of the MODE local variable SYM."
- (or mode (error "Missing major mode symbol"))
- (mode-local-symbol-value sym mode 'mode-variable-flag))
-
-(defmacro setq-mode-local (mode &rest args)
- "Assign new values to variables local in MODE.
-MODE must be a major mode symbol.
-ARGS is a list (SYM VAL SYM VAL ...).
-The symbols SYM are variables; they are literal (not evaluated).
-The values VAL are expressions; they are evaluated.
-Set each SYM to the value of its VAL, locally in buffers already in
-MODE, or in buffers switched to that mode.
-Return the value of the last VAL."
- (declare (debug (symbolp &rest symbolp form)))
- (when args
- (let (i ll bl sl tmp sym val)
- (setq i 0)
- (while args
- (setq tmp (make-symbol (format "tmp%d" i))
- i (1+ i)
- sym (car args)
- val (cadr args)
- ll (cons (list tmp val) ll)
- bl (cons `(cons ',sym ,tmp) bl)
- sl (cons `(set (make-local-variable ',sym) ,tmp) sl)
- args (cddr args)))
- `(let* ,(nreverse ll)
- ;; Save mode bindings
- (mode-local-bind (list ,@bl) '(mode-variable-flag t) ',mode)
- ;; Assign to local variables in all existing buffers in MODE
- (mode-local-map-mode-buffers (lambda () ,@sl) ',mode)
- ;; Return the last value
- ,tmp)
- )))
-
-(defmacro defvar-mode-local (mode sym val &optional docstring)
- "Define MODE local variable SYM with value VAL.
-DOCSTRING is optional."
- (declare (indent defun)
- (debug (&define symbolp name def-form [ &optional stringp ] )))
- `(progn
- (setq-mode-local ,mode ,sym ,val)
- (put (mode-local-symbol ',sym ',mode)
- 'variable-documentation ,docstring)
- ',sym))
-
-(defmacro defconst-mode-local (mode sym val &optional docstring)
- "Define MODE local constant SYM with value VAL.
-DOCSTRING is optional."
- (declare (indent defun) (debug defvar-mode-local))
- (let ((tmp (make-symbol "tmp")))
- `(let (,tmp)
- (setq-mode-local ,mode ,sym ,val)
- (setq ,tmp (mode-local-symbol ',sym ',mode))
- (put ,tmp 'constant-flag t)
- (put ,tmp 'variable-documentation ,docstring)
- ',sym)))
-\f
-;;; Function overloading
-;;
-(defun make-obsolete-overload (old new when)
- "Mark OLD overload as obsoleted by NEW overload.
-WHEN is a string describing the first release where it was made obsolete."
- (put old 'mode-local--overload-obsoleted-by new)
- (put old 'mode-local--overload-obsoleted-since when)
- (put old 'mode-local-overload t)
- (put new 'mode-local--overload-obsolete old))
-
-(define-obsolete-function-alias 'overload-obsoleted-by
- #'mode-local--overload-obsoleted-by "27.1")
-(defsubst mode-local--overload-obsoleted-by (overload)
- "Get the overload symbol obsoleted by OVERLOAD.
-Return the obsolete symbol or nil if not found."
- (get overload 'mode-local--overload-obsolete))
-
-(define-obsolete-function-alias 'overload-that-obsolete
- #'mode-local--overload-that-obsolete "27.1")
-(defsubst mode-local--overload-that-obsolete (overload)
- "Return the overload symbol that obsoletes OVERLOAD.
-Return the symbol found or nil if OVERLOAD is not obsolete."
- (get overload 'mode-local--overload-obsoleted-by))
-
-(defsubst fetch-overload (overload)
- "Return the current OVERLOAD function, or nil if not found.
-First, lookup for OVERLOAD into locally bound mode local symbols, then
-in those bound in current `major-mode' and its parents."
- (or (mode-local-symbol-value overload nil 'override-flag)
- ;; If an obsolete overload symbol exists, try it.
- (and (mode-local--overload-obsoleted-by overload)
- (mode-local-symbol-value
- (mode-local--overload-obsoleted-by overload) nil 'override-flag))))
-
-(defun mode-local--override (name args body)
- "Return the form that handles overloading of function NAME.
-ARGS are the arguments to the function.
-BODY is code that would be run when there is no override defined. The
-default is to call the function `NAME-default' with the appropriate
-arguments.
-See also the function `define-overload'."
- (let* ((default (intern (format "%s-default" name)))
- (overargs (delq '&rest (delq '&optional (copy-sequence args))))
- (override (make-symbol "override")))
- `(let ((,override (fetch-overload ',name)))
- (if ,override
- (funcall ,override ,@overargs)
- ,@(or body `((,default ,@overargs)))))
- ))
-
-(defun mode-local--expand-overrides (name args body)
- "Expand override forms that overload function NAME.
-ARGS are the arguments to the function NAME.
-BODY is code where override forms are searched for expansion.
-Return result of expansion, or BODY if no expansion occurred.
-See also the function `define-overload'."
- (let ((forms body)
- (ditto t)
- form xbody)
- (while forms
- (setq form (car forms))
- (cond
- ((atom form))
- ((eq (car form) :override)
- (setq form (mode-local--override name args (cdr form))))
- ((eq (car form) :override-with-args)
- (setq form (mode-local--override name (cadr form) (cddr form))))
- ((setq form (mode-local--expand-overrides name args form))))
- (setq ditto (and ditto (eq (car forms) form))
- xbody (cons form xbody)
- forms (cdr forms)))
- (if ditto body (nreverse xbody))))
-
-(defun mode-local--overload-body (name args body)
- "Return the code that implements overloading of function NAME.
-ARGS are the arguments to the function NAME.
-BODY specifies the overload code.
-See also the function `define-overload'."
- (let ((result (mode-local--expand-overrides name args body)))
- (if (eq body result)
- (list (mode-local--override name args body))
- result)))
-
-;;;###autoload
-(put 'define-overloadable-function 'doc-string-elt 3)
-
-(defmacro define-overloadable-function (name args docstring &rest body)
- "Define a new function, as with `defun', which can be overloaded.
-NAME is the name of the function to create.
-ARGS are the arguments to the function.
-DOCSTRING is a documentation string to describe the function. The
-docstring will automatically have details about its overload symbol
-appended to the end.
-BODY is code that would be run when there is no override defined. The
-default is to call the function `NAME-default' with the appropriate
-arguments.
-
-BODY can also include an override form that specifies which part of
-BODY is specifically overridden. This permits specifying common code
-run for both default and overridden implementations.
-An override form is one of:
-
- 1. (:override [OVERBODY])
- 2. (:override-with-args OVERARGS [OVERBODY])
-
-OVERBODY is the code that would be run when there is no override
-defined. The default is to call the function `NAME-default' with the
-appropriate arguments deduced from ARGS.
-OVERARGS is a list of arguments passed to the override and
-`NAME-default' function, in place of those deduced from ARGS."
- (declare (doc-string 3)
- (indent defun)
- (debug (&define name lambda-list stringp def-body)))
- `(eval-and-compile
- (defun ,name ,args
- ,docstring
- ,@(mode-local--overload-body name args body))
- (put ',name 'mode-local-overload t)))
-(put :override-with-args 'lisp-indent-function 1)
-
-(define-obsolete-function-alias 'define-overload
- #'define-overloadable-function "27.1")
-
-(define-obsolete-function-alias 'function-overload-p
- #'mode-local--function-overload-p "27.1")
-(defsubst mode-local--function-overload-p (symbol)
- "Return non-nil if SYMBOL is a function which can be overloaded."
- (and symbol (symbolp symbol) (get symbol 'mode-local-overload)))
-
-(defmacro define-mode-local-override
- (name mode args docstring &rest body)
- "Define a mode specific override of the function overload NAME.
-Has meaning only if NAME has been created with `define-overloadable-function'.
-MODE is the major mode this override is being defined for.
-ARGS are the function arguments, which should match those of the same
-named function created with `define-overload'.
-DOCSTRING is the documentation string.
-BODY is the implementation of this function."
- ;; FIXME: Make this obsolete and use cl-defmethod with &context instead.
- (declare (doc-string 4)
- (indent defun)
- (debug (&define name symbolp lambda-list stringp def-body)))
- (let ((newname (intern (format "%s-%s" name mode))))
- `(progn
- (eval-and-compile
- (defun ,newname ,args
- ,(concat docstring "\n"
- (internal--format-docstring-line
- "Override `%s' in `%s' buffers."
- name mode))
- ;; The body for this implementation
- ,@body)
- ;; For find-func to locate the definition of NEWNAME.
- (put ',newname 'definition-name ',name))
- (mode-local-bind '((,name . ,newname))
- '(override-flag t)
- ',mode))))
-\f
-;;; Read/Query Support
-(defun mode-local-read-function (prompt &optional initial hist default)
- "Interactively read in the name of a mode-local function.
-PROMPT, INITIAL, HIST, and DEFAULT are the same as for `completing-read'."
- (declare (obsolete nil "27.1"))
- (completing-read prompt obarray #'mode-local--function-overload-p t initial hist default))
-\f
-;;; Help support
-;;
-(define-obsolete-function-alias 'overload-docstring-extension
- #'mode-local--overload-docstring-extension "27.1")
-(defun mode-local--overload-docstring-extension (overload)
- "Return the doc string that augments the description of OVERLOAD."
- (let ((doc "\nThis function can be overloaded\
- with `define-mode-local-override'.")
- (sym (mode-local--overload-obsoleted-by overload)))
- (when sym
- (setq doc (format "%s\nIt has made the overload `%s' obsolete since %s."
- doc sym
- (get sym 'mode-local--overload-obsoleted-since))))
- (setq sym (mode-local--overload-that-obsolete overload))
- (when sym
- (setq doc (format
- "%s\nThis overload is obsolete since %s;\nUse `%s' instead."
- doc (get overload 'mode-local--overload-obsoleted-since) sym)))
- doc))
-
-(defun mode-local-augment-function-help (symbol)
- "Augment the *Help* buffer for SYMBOL.
-SYMBOL is a function that can be overridden."
- (with-current-buffer "*Help*"
- (pop-to-buffer (current-buffer))
- (goto-char (point-min))
- (unless (re-search-forward "^$" nil t)
- (goto-char (point-max))
- (beginning-of-line)
- (forward-line -1))
- (let ((inhibit-read-only t))
- (insert (substitute-command-keys (mode-local--overload-docstring-extension symbol))
- "\n")
- ;; NOTE TO SELF:
- ;; LIST ALL LOADED OVERRIDES FOR SYMBOL HERE
- )))
-
-;; We are called from describe-function in help-fns.el, where this is defined.
-(defvar describe-function-orig-buffer)
-
-(defun mode-local--describe-overload (symbol)
- "For `help-fns-describe-function-functions'; add overloads for SYMBOL."
- (when (mode-local--function-overload-p symbol)
- (let ((default (or (intern-soft (format "%s-default" (symbol-name symbol)))
- symbol))
- (override (with-current-buffer describe-function-orig-buffer
- (fetch-overload symbol)))
- modes)
-
- (insert (substitute-command-keys (mode-local--overload-docstring-extension symbol))
- "\n\n")
- (insert (format-message "default function: `%s'\n" default))
- (if override
- (insert (format-message "\noverride in buffer `%s': `%s'\n"
- describe-function-orig-buffer override))
- (insert (format-message "\nno override in buffer `%s'\n"
- describe-function-orig-buffer)))
-
- (mapatoms
- (lambda (sym) (when (get sym 'mode-local-symbol-table) (push sym modes)))
- obarray)
-
- (dolist (mode modes)
- (let* ((major-mode mode)
- (override (fetch-overload symbol)))
-
- (when override
- (insert (format-message "\noverride in mode `%s': `%s'\n"
- major-mode override))
- )))
- )))
-
-(add-hook 'help-fns-describe-function-functions #'mode-local--describe-overload)
-
-(declare-function xref-item-location "xref" (xref) t)
-
-(defun xref-mode-local--override-present (sym xrefs)
- "Return non-nil if SYM is in XREFS."
- (let (result)
- (while (and (null result)
- xrefs)
- (when (equal sym (car (xref-elisp-location-symbol (xref-item-location (pop xrefs)))))
- (setq result t)))
- result))
-
-(defun xref-mode-local-overload (symbol)
- "For `elisp-xref-find-def-functions'; add overloads for SYMBOL."
- ;; Current buffer is the buffer where xref-find-definitions was invoked.
- (when (mode-local--function-overload-p symbol)
- (let* ((symbol-file (find-lisp-object-file-name
- symbol (symbol-function symbol)))
- (default (intern-soft (format "%s-default" (symbol-name symbol))))
- (default-file (when default (find-lisp-object-file-name
- default (symbol-function default))))
- modes
- xrefs)
-
- (mapatoms
- (lambda (sym) (when (get sym 'mode-local-symbol-table) (push sym modes)))
- obarray)
-
- ;; mode-local-overrides are inherited from parent modes; we
- ;; don't want to list the same function twice. So order ‘modes’
- ;; with parents first, and check for duplicates.
-
- (setq modes
- (sort modes
- (lambda (a b)
- ;; a is not a child, or not a child of b
- (not (equal b (get a 'mode-local-parent))))))
-
- (dolist (mode modes)
- (let* ((major-mode mode)
- (override (fetch-overload symbol))
- (override-file (when override
- (find-lisp-object-file-name
- override (symbol-function override)))))
-
- (when (and override override-file)
- (let ((meta-name (cons override major-mode))
- ;; For the declaration:
- ;;
- ;;(define-mode-local-override xref-elisp-foo c-mode
- ;;
- ;; The override symbol name is
- ;; "xref-elisp-foo-c-mode". The summary should match
- ;; the declaration, so strip the mode from the
- ;; symbol name.
- (summary (format elisp--xref-format-extra
- 'define-mode-local-override
- (substring (symbol-name override) 0 (- (1+ (length (symbol-name major-mode)))))
- major-mode)))
-
- (unless (xref-mode-local--override-present override xrefs)
- (push (elisp--xref-make-xref
- 'define-mode-local-override meta-name override-file summary)
- xrefs))))))
-
- ;; %s-default is interned whether it is a separate function or
- ;; not, so we have to check that here.
- (when (and (functionp default) default-file)
- (push (elisp--xref-make-xref nil default default-file) xrefs))
-
- (when symbol-file
- (push (elisp--xref-make-xref 'define-overloadable-function
- symbol symbol-file)
- xrefs))
-
- xrefs)))
-
-(add-hook 'elisp-xref-find-def-functions #'xref-mode-local-overload)
-
-(defconst xref-mode-local-find-overloadable-regexp
- "(define-overload\\(able-function\\)? +%s"
- "Regexp used by `xref-find-definitions' when searching for a
-mode-local overloadable function definition.")
-
-(defun xref-mode-local-find-override (meta-name)
- "Function used by `xref-find-definitions' when searching for an
-override of a mode-local overloadable function.
-META-NAME is a cons (OVERLOADABLE-SYMBOL . MAJOR-MODE)."
- (let* ((override (car meta-name))
- (mode (cdr meta-name))
- (regexp (format "(define-mode-local-override +%s +%s"
- (substring (symbol-name override) 0 (- (1+ (length (symbol-name mode)))))
- mode)))
- (re-search-forward regexp nil t)
- ))
-
-(add-to-list 'find-function-regexp-alist
- '(define-overloadable-function
- . xref-mode-local-find-overloadable-regexp))
-(add-to-list 'find-function-regexp-alist
- (cons 'define-mode-local-override
- #'xref-mode-local-find-override))
-
-;; Help for mode-local bindings.
-(defun mode-local-print-binding (symbol)
- "Print the SYMBOL binding."
- (let ((value (symbol-value symbol)))
- (princ (format-message "\n `%s' value is\n " symbol))
- (if (and value (symbolp value))
- (princ (format-message "`%s'" value))
- (let ((pt (point)))
- (pp value)
- (save-excursion
- (goto-char pt)
- (indent-sexp))))
- (or (bolp) (princ "\n"))))
-
-(defun mode-local-print-bindings (table)
- "Print bindings in TABLE."
- (let (us ;; List of unspecified symbols
- mc ;; List of mode local constants
- mv ;; List of mode local variables
- ov ;; List of overloaded functions
- fo ;; List of final overloaded functions
- )
- ;; Order symbols by type
- (mapatoms
- (lambda (s) (push s (cond
- ((get s 'mode-variable-flag)
- (if (get s 'constant-flag) mc mv))
- ((get s 'override-flag)
- (if (get s 'constant-flag) fo ov))
- (t us))))
- table)
- ;; Print symbols by type
- (when us
- (princ "\n !! Unspecified symbols\n")
- (mapc #'mode-local-print-binding us))
- (when mc
- (princ "\n ** Mode local constants\n")
- (mapc #'mode-local-print-binding mc))
- (when mv
- (princ "\n ** Mode local variables\n")
- (mapc #'mode-local-print-binding mv))
- (when fo
- (princ "\n ** Final overloaded functions\n")
- (mapc #'mode-local-print-binding fo))
- (when ov
- (princ "\n ** Overloaded functions\n")
- (mapc #'mode-local-print-binding ov))
- ))
-
-(defun mode-local-describe-bindings-2 (buffer-or-mode)
- "Display mode local bindings active in BUFFER-OR-MODE."
- (let (table mode)
- (princ "Mode local bindings active in ")
- (cond
- ((bufferp buffer-or-mode)
- (with-current-buffer buffer-or-mode
- (setq table mode-local-symbol-table
- mode major-mode))
- (princ (format "%S\n" buffer-or-mode))
- )
- ((symbolp buffer-or-mode)
- (setq mode buffer-or-mode)
- (princ (format-message "`%s'\n" buffer-or-mode))
- )
- ((signal 'wrong-type-argument
- (list 'buffer-or-mode buffer-or-mode))))
- (when table
- (princ "\n- Buffer local\n")
- (mode-local-print-bindings table))
- (dolist (mode (derived-mode-all-parents mode))
- (setq table (get mode 'mode-local-symbol-table))
- (when table
- (princ (format-message "\n- From `%s'\n" mode))
- (mode-local-print-bindings table)))))
-
-(defun mode-local-describe-bindings-1 (buffer-or-mode &optional interactive-p)
- "Display mode local bindings active in BUFFER-OR-MODE.
-Optional argument INTERACTIVE-P is non-nil if the calling command was
-invoked interactively."
- (help-setup-xref
- (list 'mode-local-describe-bindings-1 buffer-or-mode)
- interactive-p)
- (with-output-to-temp-buffer (help-buffer) ; "*Help*"
- (with-current-buffer standard-output
- (mode-local-describe-bindings-2 buffer-or-mode))))
-
-(defun describe-mode-local-bindings (buffer)
- "Display mode local bindings active in BUFFER."
- (interactive "b")
- (when (setq buffer (get-buffer buffer))
- (mode-local-describe-bindings-1 buffer (called-interactively-p 'any))))
-
-(defun describe-mode-local-bindings-in-mode (mode)
- "Display mode local bindings active in MODE hierarchy."
- (interactive
- (list (completing-read
- "Mode: " obarray
- (lambda (s) (get s 'mode-local-symbol-table))
- t (symbol-name major-mode))))
- (when (setq mode (intern-soft mode))
- (mode-local-describe-bindings-1 mode (called-interactively-p 'any))))
-\f
-(add-hook 'find-file-hook #'mode-local-post-major-mode-change)
-(add-hook 'change-major-mode-hook #'mode-local-on-major-mode-change)
-
-(provide 'mode-local)
-
-;;; mode-local.el ends here
+++ /dev/null
-;;; semantic.el --- Semantic buffer evaluator. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax tools
-;; Version: 2.2
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; API for providing the semantic content of a buffer.
-;;
-;; The Semantic API provides an interface to a series of different parser
-;; implementations. Each parser outputs a parse tree in a similar format
-;; designed to handle typical functional and object oriented languages.
-;;
-;; To enable Semantic, turn on `semantic-mode', a global minor mode
-;; (M-x semantic-mode RET, or "Source Code Parsers" from the Tools
-;; menu). To enable it at startup, put (semantic-mode 1) in your init
-;; file.
-
-;;; Code:
-
-(require 'cedet)
-(require 'semantic/tag)
-(require 'semantic/lex)
-(require 'cl-lib)
-
-(defvar semantic-version "2.2"
- "Current version of Semantic.")
-(make-obsolete-variable 'semantic-version 'emacs-version "29.1")
-
-(declare-function inversion-test "inversion")
-
-(defun semantic-require-version (major minor &optional beta)
- "Non-nil if this version of Semantic does not satisfy a specific version.
-Arguments can be:
-
- (MAJOR MINOR &optional BETA)
-
- Values MAJOR and MINOR must be integers. BETA can be an integer, or
-excluded if a released version is required.
-
-It is assumed that if the current version is newer than that specified,
-everything passes. Exceptions occur when known incompatibilities are
-introduced."
- (declare (obsolete emacs-version "28.1"))
- (require 'inversion)
- (inversion-test 'semantic
- (concat major "." minor
- (when beta (concat "beta" beta)))))
-
-(defgroup semantic nil
- "Parser Generator and parser framework."
- :group 'tools)
-
-(defgroup semantic-faces nil
- "Faces used for Semantic enabled tools."
- :group 'semantic)
-
-(require 'semantic/fw)
-
-;;; Variables and Configuration
-;;
-(defvar-local semantic--parse-table nil
- "Variable that defines how to parse top level items in a buffer.
-This variable is for internal use only, and its content depends on the
-external parser used.")
-
-(defvar-local semantic-symbol->name-assoc-list
- '((type . "Types")
- (variable . "Variables")
- (function . "Functions")
- (include . "Dependencies")
- (package . "Provides"))
- "Association between symbols returned, and a string.
-The string is used to represent a group of objects of the given type.
-It is sometimes useful for a language to use a different string
-in place of the default, even though that language will still
-return a symbol. For example, Java return's includes, but the
-string can be replaced with `Imports'.")
-
-(defvar-local semantic-symbol->name-assoc-list-for-type-parts nil
- "Like `semantic-symbol->name-assoc-list' for type parts.
-Some tags that have children (see `semantic-tag-children-compatibility')
-will want to define the names of classes of tags differently than at
-the top level. For example, in C++, a Function may be called a
-Method. In addition, there may be new types of tags that exist only
-in classes, such as protection labels.")
-
-(defvar-local semantic-case-fold nil
- "Value for `case-fold-search' when parsing.")
-
-(defvar-local semantic--buffer-cache nil
- "A cache of the fully parsed buffer.
-If no significant changes have been made (based on the state) then
-this is returned instead of re-parsing the buffer.
-
- DO NOT USE THIS VARIABLE IN PROGRAMS.
-
-If you need a tag list, use `semantic-fetch-tags'. If you need the
-cached values for some reason, chances are you can add a hook to
-`semantic-after-toplevel-cache-change-hook'.")
-
-(defvar-local semantic-unmatched-syntax-cache nil
- "A cached copy of unmatched syntax tokens.")
-
-(defvar-local semantic-unmatched-syntax-cache-check nil
- "Non-nil if the unmatched syntax cache is out of date.
-This is tracked with `semantic-change-function'.")
-
-(defvar semantic-edits-are-safe nil
- "When non-nil, modifications do not require a reparse.
-This prevents tags from being marked dirty, and it prevents top level
-edits from causing a cache check.
-Use this when writing programs that could cause a full reparse, but
-will not change the tag structure, such as adding or updating
-`top-level' comments.")
-
-(defvar semantic-unmatched-syntax-hook nil
- "Hooks run when Semantic detects syntax not matched in a grammar.
-Each individual piece of syntax (such as a symbol or punctuation
-character) is called with this hook when it doesn't match in the
-grammar, and multiple unmatched syntax elements are not grouped
-together. Each hook is called with one argument, which is a list
-of syntax tokens created by the semantic lexer. Use the functions
-`semantic-lex-token-start', `semantic-lex-token-end' and
-`semantic-lex-token-text' to get information about these tokens.
-The current buffer is the buffer these tokens are derived from.")
-
-(defvar semantic--before-fetch-tags-hook nil
- "Hooks run before a buffer is parsed for tags.
-It is called before any request for tags is made via the function
-`semantic-fetch-tags' by an application.
-If any hook returns a nil value, the cached value is returned
-immediately, even if it is empty.")
-
-(defvar semantic-after-toplevel-cache-change-hook nil
- "Hooks run after the buffer tag list has changed.
-This list will change when a buffer is reparsed, or when the tag list
-in a buffer is cleared. It is *NOT* called if the current tag list is
-partially reparsed.
-
-Hook functions must take one argument, which is the new list of tags
-associated with this buffer.
-
-For language specific hooks, make sure you define this as a local hook.")
-
-(defvar semantic-before-toplevel-cache-flush-hook nil
- "Hooks run before the toplevel tag cache is flushed.
-For language specific hooks, make sure you define this as a local
-hook. This hook is called before a corresponding
-`semantic-after-toplevel-cache-change-hook' which is also called
-during a flush when the cache is given a new value of nil.")
-
-(defcustom semantic-dump-parse nil
- "When non-nil, dump parsing information."
- :group 'semantic
- :type 'boolean)
-
-(defvar-local semantic-parser-name "LL"
- "Optional name of the parser used to parse input stream.")
-
-(defvar-local semantic--completion-cache nil
- "Internal variable used by `semantic-complete-symbol'.")
-\f
-;;; Parse tree state management API
-;;
-(defvar-local semantic-parse-tree-state 'needs-rebuild
- "State of the current parse tree.")
-
-(defmacro semantic-parse-tree-unparseable ()
- "Indicate that the current buffer is unparsable.
-It is also true that the parse tree will need either updating or
-a rebuild. This state will be changed when the user edits the buffer."
- '(setq semantic-parse-tree-state 'unparseable))
-
-(defmacro semantic-parse-tree-unparseable-p ()
- "Return non-nil if the current buffer has been marked unparsable."
- '(eq semantic-parse-tree-state 'unparseable))
-
-(defmacro semantic-parse-tree-set-needs-update ()
- "Indicate that the current parse tree needs to be updated.
-The parse tree can be updated by `semantic-parse-changes'."
- '(setq semantic-parse-tree-state 'needs-update))
-
-(defmacro semantic-parse-tree-needs-update-p ()
- "Return non-nil if the current parse tree needs to be updated."
- '(eq semantic-parse-tree-state 'needs-update))
-
-(defmacro semantic-parse-tree-set-needs-rebuild ()
- "Indicate that the current parse tree needs to be rebuilt.
-The parse tree must be rebuilt by `semantic-parse-region'."
- '(setq semantic-parse-tree-state 'needs-rebuild))
-
-(defmacro semantic-parse-tree-needs-rebuild-p ()
- "Return non-nil if the current parse tree needs to be rebuilt."
- '(eq semantic-parse-tree-state 'needs-rebuild))
-
-(defmacro semantic-parse-tree-set-up-to-date ()
- "Indicate that the current parse tree is up to date."
- '(setq semantic-parse-tree-state nil))
-
-(defmacro semantic-parse-tree-up-to-date-p ()
- "Return non-nil if the current parse tree is up to date."
- '(null semantic-parse-tree-state))
-
-;;; Interfacing with the system
-;;
-(defcustom semantic-inhibit-functions nil
- "List of functions to call with no arguments before Semantic is setup.
-If any of these functions returns non-nil, the current buffer is not
-setup to use Semantic."
- :group 'semantic
- :type 'hook)
-
-(defcustom semantic-new-buffer-setup-functions
- '((c-mode . semantic-default-c-setup)
- (c++-mode . semantic-default-c-setup)
- (html-mode . semantic-default-html-setup)
- (java-mode . wisent-java-default-setup)
- (js-mode . wisent-javascript-setup-parser)
- (python-mode . wisent-python-default-setup)
- (scheme-mode . semantic-default-scheme-setup)
- (srecode-template-mode . srecode-template-setup-parser)
- (texinfo-mode . semantic-default-texi-setup)
- (makefile-automake-mode . semantic-default-make-setup)
- (makefile-gmake-mode . semantic-default-make-setup)
- (makefile-makepp-mode . semantic-default-make-setup)
- (makefile-bsdmake-mode . semantic-default-make-setup)
- (makefile-imake-mode . semantic-default-make-setup)
- (makefile-mode . semantic-default-make-setup))
- "Alist of functions to call to set up Semantic parsing in the buffer.
-Each element has the form (MODE . FN), where MODE is a value of
-`major-mode' for the buffer and FN is the corresponding function
-to call, with no arguments, to set up the parser.
-
-These functions are called by `semantic-new-buffer-fcn', before
-`semantic-inhibit-functions'."
- :group 'semantic
- :type '(alist :key-type symbol :value-type function))
-
-(defvar semantic-init-hook nil
- "Hook run when a buffer is initialized with a parsing table.")
-
-(defvar-local semantic-init-mode-hook nil
- "Hook run when a buffer of a particular mode is initialized.")
-
-(defvar semantic-init-db-hook nil
- "Hook run when a buffer is initialized with a parsing table for DBs.
-This hook is for database functions which intend to swap in a tag table.
-This guarantees that the DB will go before other modes that require
-a parse of the buffer.")
-
-(defsubst semantic-error-if-unparsed ()
- "Raise an error if current buffer was not parsed by Semantic."
- (unless semantic-new-buffer-fcn-was-run
- (error "Buffer was not parsed by Semantic")))
-
-(defsubst semantic--umatched-syntax-needs-refresh-p ()
- "Return non-nil if the unmatched syntax cache needs a refresh.
-That is, if it is dirty or if the current parse tree isn't up to date."
- (or semantic-unmatched-syntax-cache-check
- (not (semantic-parse-tree-up-to-date-p))))
-
-(defun semantic-new-buffer-fcn ()
- "Setup the current buffer to use Semantic.
-If the major mode is ready for Semantic, and no
-`semantic-inhibit-functions' disabled it, the current buffer is setup
-to use Semantic, and `semantic-init-hook' is run."
- ;; In upstream Semantic, the parser setup functions are called from
- ;; mode hooks. In the version bundled with Emacs, we do it here.
- (let ((entry (cl-assoc-if #'derived-mode-p semantic-new-buffer-setup-functions)))
- (when entry
- (funcall (cdr entry))))
- ;; Do stuff if semantic was activated by a mode hook in this buffer,
- ;; and not afterwards disabled.
- (when (and semantic--parse-table
- (not (semantic-active-p))
- (not (run-hook-with-args-until-success
- 'semantic-inhibit-functions)))
- ;; Make sure that if this buffer is cloned, our tags and overlays
- ;; don't go along for the ride.
- (add-hook 'clone-indirect-buffer-hook #'semantic-clear-toplevel-cache
- nil t)
- ;; Specify that this function has done its work. At this point
- ;; we can consider that semantic is active in this buffer.
- (setq semantic-new-buffer-fcn-was-run t)
- ;; Here are some buffer local variables we can initialize ourselves
- ;; of a mode does not choose to do so.
- (semantic-lex-init)
- ;; Force this buffer to have its cache refreshed.
- (semantic-clear-toplevel-cache)
- ;; Call DB hooks before regular init hooks
- (run-hooks 'semantic-init-db-hook)
- ;; Set up semantic modes
- (run-hooks 'semantic-init-hook)
- ;; Set up major-mode specific semantic modes
- (run-hooks 'semantic-init-mode-hook)))
-
-(defun semantic-fetch-tags-fast ()
- "For use in a hook. When only a partial reparse is needed, reparse."
- (condition-case nil
- (if (semantic-parse-tree-needs-update-p)
- (semantic-fetch-tags))
- (error nil))
- semantic--buffer-cache)
-\f
-;;; Parsing Commands
-;;
-(require 'pp)
-
-(defvar semantic-edebug nil
- "When non-nil, activate the interactive parsing debugger.
-Do not set this yourself. Call `semantic-debug'.")
-
-(defsubst semantic-elapsed-time (start end)
- "Copied from elp.el. Was `elp-elapsed-time'.
-Arguments START and END bound the time being calculated."
- (float-time (time-subtract end start)))
-
-(defun bovinate (&optional clear)
- "Parse the current buffer. Show output in a temp buffer.
-Optional argument CLEAR will clear the cache before parsing.
-If CLEAR is negative, it will do a full reparse, and also display
-the output buffer."
- (interactive "P")
- (if clear (semantic-clear-toplevel-cache))
- (if (eq clear '-) (setq clear -1))
- (let* ((start (current-time))
- (out (semantic-fetch-tags)))
- (message "Retrieving tags took %.2f seconds."
- (semantic-elapsed-time start nil))
- (when (or (null clear) (not (listp clear))
- (and (numberp clear) (< 0 clear)))
- (pop-to-buffer "*Parser Output*")
- (require 'pp)
- (erase-buffer)
- (insert (pp-to-string out))
- (goto-char (point-min)))))
-\f
-;;; Functions of the parser plug-in API
-;;
-;; Overload these functions to create new types of parsers.
-;;
-(define-overloadable-function semantic-parse-stream (stream nonterminal)
- "Parse STREAM, starting at the first NONTERMINAL rule.
-For bovine and wisent based parsers, STREAM is from the output of
-`semantic-lex', and NONTERMINAL is a rule in the appropriate language
-specific rules file.
-The default parser table used for bovine or wisent based parsers is
-`semantic--parse-table'.
-
-Must return a list: (STREAM TAGS) where STREAM is the unused elements
-from STREAM, and TAGS is the list of semantic tags found; usually only
-one tag is returned with the exception of compound statements.")
-
-(define-overloadable-function semantic-parse-changes ()
- "Reparse changes in the current buffer.
-The list of changes are tracked as a series of overlays in the buffer.
-When overloading this function, use `semantic-changes-in-region' to
-analyze.")
-
-(define-overloadable-function semantic-parse-region
- (start end &optional nonterminal depth returnonerror)
- "Parse the area between START and END, and return any tags found.
-If END needs to be extended due to a lexical token being too large, it
-will be silently ignored.
-
-Optional arguments:
-NONTERMINAL is the rule to start parsing at.
-DEPTH specifies the lexical depth to descend for parsers that use
-lexical analysis as their first step.
-RETURNONERROR specifies that parsing should stop on the first
-unmatched syntax encountered. When nil, parsing skips the syntax,
-adding it to the unmatched syntax cache.
-
-Must return a list of semantic tags which have been cooked
-\(repositioned properly) but which DO NOT HAVE OVERLAYS associated
-with them. When overloading this function, use `semantic--tag-expand'
-to cook raw tags.")
-
-(defun semantic-parse-region-default
- (start end &optional nonterminal depth returnonerror)
- "Parse the area between START and END, and return any tags found.
-If END needs to be extended due to a lexical token being too large,
-it will be silently ignored.
-Optional arguments:
-NONTERMINAL is the rule to start parsing at if it is known.
-DEPTH specifies the lexical depth to scan.
-RETURNONERROR specifies that parsing should end when encountering
-unterminated syntax."
- (when (or (null semantic--parse-table) (eq semantic--parse-table t))
- ;; If there is no table, or it was set to t, then we are here by
- ;; some other mistake. Do not throw an error deep in the parser.
- (error "No support found to parse buffer %S" (buffer-name)))
- (save-restriction
- (widen)
- (when (or (< end start) (> end (point-max)))
- (error "Invalid parse region bounds %S, %S" start end))
- (semantic-repeat-parse-whole-stream
- (or (cdr (assq start semantic-lex-block-streams))
- (semantic-lex start end depth))
- nonterminal returnonerror)))
-\f
-;;; Parsing functions
-;;
-(defun semantic-set-unmatched-syntax-cache (unmatched-syntax)
- "Set the unmatched syntax cache.
-Argument UNMATCHED-SYNTAX is the syntax to set into the cache."
- ;; This function is not actually called by the main parse loop.
- ;; This is intended for use by semanticdb.
- (setq semantic-unmatched-syntax-cache unmatched-syntax
- semantic-unmatched-syntax-cache-check nil)
- ;; Refresh the display of unmatched syntax tokens if enabled
- (run-hook-with-args 'semantic-unmatched-syntax-hook
- semantic-unmatched-syntax-cache))
-
-(defun semantic-clear-unmatched-syntax-cache ()
- "Clear the cache of unmatched syntax tokens."
- (setq semantic-unmatched-syntax-cache nil
- semantic-unmatched-syntax-cache-check t))
-
-(defun semantic-unmatched-syntax-tokens ()
- "Return the list of unmatched syntax tokens."
- ;; If the cache need refresh then do a full re-parse.
- (if (semantic--umatched-syntax-needs-refresh-p)
- ;; To avoid a recursive call, temporarily disable
- ;; `semantic-unmatched-syntax-hook'.
- (let (semantic-unmatched-syntax-hook)
- (condition-case nil
- (progn
- (semantic-clear-toplevel-cache)
- (semantic-fetch-tags))
- (quit
- (message "semantic-unmatched-syntax-tokens:\
- parsing of buffer canceled"))
- )))
- semantic-unmatched-syntax-cache)
-
-(defun semantic-clear-toplevel-cache ()
- "Clear the toplevel tag cache for the current buffer.
-Clearing the cache will force a complete reparse next time a tag list
-is requested."
- (interactive)
- (run-hooks 'semantic-before-toplevel-cache-flush-hook)
- (setq semantic--buffer-cache nil)
- (semantic-clear-unmatched-syntax-cache)
- (semantic-clear-parser-warnings)
- ;; Nuke all semantic overlays. This is faster than deleting based
- ;; on our data structure.
- (let ((l (overlay-lists)))
- (mapc #'semantic-delete-overlay-maybe (car l))
- (mapc #'semantic-delete-overlay-maybe (cdr l))
- )
- (semantic-parse-tree-set-needs-rebuild)
- ;; Remove this hook which tracks if a buffer is up to date or not.
- (remove-hook 'after-change-functions #'semantic-change-function t)
-
- (run-hook-with-args 'semantic-after-toplevel-cache-change-hook
- semantic--buffer-cache)
-
- (setq semantic--completion-cache nil))
-
-(defvar semantic-bovinate-nonterminal-check-obarray)
-
-(defun semantic--set-buffer-cache (tagtable)
- "Set the toplevel tag cache to TAGTABLE."
- (setq semantic--buffer-cache tagtable
- semantic-unmatched-syntax-cache-check nil)
- ;; This is specific to the bovine parser.
- (setq-local semantic-bovinate-nonterminal-check-obarray nil)
- (semantic-parse-tree-set-up-to-date)
- (add-hook 'after-change-functions #'semantic-change-function nil t)
- (run-hook-with-args 'semantic-after-toplevel-cache-change-hook
- semantic--buffer-cache)
- (setq semantic--completion-cache nil)
- ;; Refresh the display of unmatched syntax tokens if enabled
- (run-hook-with-args 'semantic-unmatched-syntax-hook
- semantic-unmatched-syntax-cache))
-
-(defvar semantic-working-type 'percent
- "The type of working message to use when parsing.
-`percent' means we are doing a linear parse through the buffer.
-`dynamic' means we are reparsing specific tags.")
-
-(defvar semantic-minimum-working-buffer-size (* 1024 5)
- "The minimum size of a buffer before working messages are displayed.
-Buffers smaller than this will parse silently.
-Buffers larger than this will display the working progress bar.")
-
-(defsubst semantic-parser-working-message (&optional arg)
- "Return the message string displayed while parsing.
-If optional argument ARG is non-nil it is appended to the message
-string."
- (concat "Parsing"
- (if arg (format " %s" arg))
- (if semantic-parser-name (format " (%s)" semantic-parser-name))
- "..."))
-\f
-;;; Application Parser Entry Points
-;;
-;; The best way to call the parser from programs is via
-;; `semantic-fetch-tags'. This, in turn, uses other internal
-;; API functions which plug-in parsers can take advantage of.
-(defvar semantic-parser-warnings)
-
-(defun semantic-fetch-tags ()
- "Fetch semantic tags from the current buffer.
-If the buffer cache is up to date, return that.
-If the buffer cache is out of date, attempt an incremental reparse.
-If the buffer has not been parsed before, or if the incremental reparse
-fails, then parse the entire buffer.
-If a lexical error had been previously discovered and the buffer
-was marked unparsable, then do nothing, and return the cache."
- (and
- ;; Is this a semantic enabled buffer?
- (semantic-active-p)
- ;; Application hooks say the buffer is safe for parsing
- (run-hook-with-args-until-failure
- 'semantic--before-fetch-tags-hook)
- ;; If the buffer was previously marked unparsable,
- ;; then don't waste our time.
- (not (semantic-parse-tree-unparseable-p))
- ;; The parse tree actually needs to be refreshed
- (not (semantic-parse-tree-up-to-date-p))
- ;; So do it!
- (let* ((gc-cons-threshold (max gc-cons-threshold 10000000))
- (semantic-lex-block-streams nil)
- (res nil))
- (garbage-collect)
- (cond
-
- ;; Try the incremental parser to do a fast update.
- ((semantic-parse-tree-needs-update-p)
- (setq res (semantic-parse-changes))
- (if (semantic-parse-tree-needs-rebuild-p)
- ;; If the partial reparse fails, jump to a full reparse.
- (semantic-fetch-tags)
- ;; Clear the cache of unmatched syntax tokens
- ;;
- ;; NOTE TO SELF:
- ;;
- ;; Move this into the incremental parser. This is a bug.
- ;;
- (semantic-clear-unmatched-syntax-cache)
- (run-hook-with-args ;; Let hooks know the updated tags
- 'semantic-after-partial-cache-change-hook res))
- (setq semantic--completion-cache nil))
-
- ;; Parse the whole system.
- ((semantic-parse-tree-needs-rebuild-p)
- ;; Use Emacs's built-in progress-reporter (only interactive).
- (if noninteractive
- (setq res (semantic-parse-region (point-min) (point-max)))
- (let ((semantic--progress-reporter
- (and (>= (point-max) semantic-minimum-working-buffer-size)
- (eq semantic-working-type 'percent)
- (make-progress-reporter
- (semantic-parser-working-message (buffer-name))
- 0 100))))
- (setq res (semantic-parse-region (point-min) (point-max)))
- (if semantic--progress-reporter
- (progress-reporter-done semantic--progress-reporter))))
-
- ;; Clear the caches when we see there were no errors.
- ;; But preserve the unmatched syntax cache and warnings!
- (let (semantic-unmatched-syntax-cache
- semantic-unmatched-syntax-cache-check
- semantic-parser-warnings)
- (semantic-clear-toplevel-cache))
- ;; Set up the new overlays
- (semantic--tag-link-list-to-buffer res)
- ;; Set up the cache with the new results
- (semantic--set-buffer-cache res)
- ))))
-
- ;; Always return the current parse tree.
- semantic--buffer-cache)
-
-(defun semantic-refresh-tags-safe ()
- "Refresh the current buffer's tags safely.
-
-Return non-nil if the refresh was successful.
-Return nil if there is some sort of syntax error preventing a reparse.
-
-Does nothing if the current buffer doesn't need reparsing."
-
- ;; These checks actually occur in `semantic-fetch-tags', but if we
- ;; do them here, then all the bovination hooks are not run, and
- ;; we save lots of time.
- (cond
- ;; If the buffer was previously marked unparsable,
- ;; then don't waste our time.
- ((semantic-parse-tree-unparseable-p)
- nil)
- ;; The parse tree is already ok.
- ((semantic-parse-tree-up-to-date-p)
- t)
- (t
- (let* ((inhibit-quit nil)
- (lexically-safe t)
- )
-
- ;; Perform the parsing.
- (when (semantic-lex-catch-errors safe-refresh
- (save-excursion (semantic-fetch-tags))
- nil)
- ;; If we are here, it is because the lexical step failed,
- ;; probably due to unterminated lists or something like that.
-
- ;; We do nothing, and just wait for the next idle timer
- ;; to go off. In the meantime, remember this, and make sure
- ;; no other idle services can get executed.
- (setq lexically-safe nil))
-
- ;; Return if we are lexically safe
- lexically-safe))))
-
-;; Another approach is to let Emacs call the parser on idle time, when
-;; needed, use `semantic-fetch-available-tags' to only retrieve
-;; available tags, and setup the `semantic-after-*-hook' hooks to
-;; synchronize with new tags when they become available.
-
-(defsubst semantic-fetch-available-tags ()
- "Fetch available semantic tags from the current buffer.
-That is, return tags currently in the cache without parsing the
-current buffer.
-Parse operations happen asynchronously when needed on Emacs idle time.
-Use the `semantic-after-toplevel-cache-change-hook' and
-`semantic-after-partial-cache-change-hook' hooks to synchronize with
-new tags when they become available."
- semantic--buffer-cache)
-\f
-;;; Iterative parser helper function
-;;
-;; Iterative parsers are better than rule-based iterative functions
-;; in that they can handle obscure errors more cleanly.
-;;
-;; `semantic-repeat-parse-whole-stream' abstracts this action for
-;; other parser centric routines.
-;;
-(defun semantic-repeat-parse-whole-stream
- (stream nonterm &optional returnonerror)
- "Iteratively parse the entire stream STREAM starting with NONTERM.
-Optional argument RETURNONERROR indicates that the parser should exit
-with the current results on a parse error.
-This function returns semantic tags without overlays."
- (let ((result nil)
- (case-fold-search semantic-case-fold)
- nontermsym tag)
- (while stream
- (setq nontermsym (semantic-parse-stream stream nonterm)
- tag (car (cdr nontermsym)))
- (if (not nontermsym)
- (error "Parse error @ %d" (car (cdr (car stream)))))
- (if (eq (car nontermsym) stream)
- (error "Parser error: Infinite loop?"))
- (if tag
- (if (car tag)
- (setq tag (mapcar
- (lambda (tag)
- ;; Set the 'reparse-symbol property to
- ;; NONTERM unless it was already setup
- ;; by a tag expander
- (or (semantic--tag-get-property
- tag 'reparse-symbol)
- (semantic--tag-put-property
- tag 'reparse-symbol nonterm))
- tag)
- (semantic--tag-expand tag))
- result (append result tag))
- ;; No error in this case, a purposeful nil means don't
- ;; store anything.
- )
- (if returnonerror
- (setq stream nil)
- ;; The current item in the stream didn't match, so add it to
- ;; the list of syntax items which didn't match.
- (setq semantic-unmatched-syntax-cache
- (cons (car stream) semantic-unmatched-syntax-cache))
- ))
- ;; Designated to ignore.
- (setq stream (car nontermsym))
- (if stream
- ;; Use Emacs's built-in progress reporter:
- (and (boundp 'semantic--progress-reporter)
- semantic--progress-reporter
- (eq semantic-working-type 'percent)
- (progress-reporter-update
- semantic--progress-reporter
- (floor (* 100.0 (semantic-lex-token-start (car stream)))
- (point-max))))))
- result))
-\f
-;;; Parsing Warnings:
-;;
-;; Parsing a buffer may result in non-critical things that we should
-;; alert the user to without interrupting the normal flow.
-;;
-;; Any parser can use this API to provide a list of warnings during a
-;; parse which a user may want to investigate.
-(defvar-local semantic-parser-warnings nil
- "A list of parser warnings since the last full reparse.")
-
-(defun semantic-clear-parser-warnings ()
- "Clear the current list of parser warnings for this buffer."
- (setq semantic-parser-warnings nil))
-
-(defun semantic-push-parser-warning (warning start end)
- "Add a parser WARNING that covers text from START to END."
- (setq semantic-parser-warnings
- (cons (cons warning (cons start end))
- semantic-parser-warnings)))
-
-(defun semantic-dump-parser-warnings ()
- "Dump any parser warnings."
- (interactive)
- (if semantic-parser-warnings
- (let ((pw semantic-parser-warnings))
- (pop-to-buffer "*Parser Warnings*")
- (require 'pp)
- (erase-buffer)
- (insert (pp-to-string pw))
- (goto-char (point-min)))
- (message "No parser warnings.")))
-
-
-\f
-;;; Compatibility:
-;;
-;; Semantic 1.x parser action helper functions, used by some parsers.
-;; Please move away from these functions, and try using semantic 2.x
-;; interfaces instead.
-;;
-
-(defsubst semantic-bovinate-from-nonterminal
- (start end nonterm &optional depth length)
- "Bovinate from within a nonterminal lambda from START to END.
-Argument NONTERM is the nonterminal symbol to start with.
-Optional argument DEPTH is the depth of lists to dive into. When used
-in a `lambda' of a MATCH-LIST, there is no need to include a START and
-END part.
-Optional argument LENGTH specifies we are only interested in LENGTH
-tokens."
- (car-safe (cdr (semantic-parse-stream
- (semantic-lex start end (or depth 1) length)
- nonterm))))
-
-;;; User interface
-
-(defun semantic-force-refresh ()
- "Force a full refresh of the current buffer's tags.
-Throw away all the old tags, and recreate the tag database."
- (interactive)
- (semantic-clear-toplevel-cache)
- (semantic-fetch-tags)
- (message "Buffer reparsed."))
-
-(defvar semantic-mode-map
- (let ((map (make-sparse-keymap)))
- ;; Key bindings:
- ;; (define-key km "f" #'senator-search-set-tag-class-filter)
- ;; (define-key km "i" #'senator-isearch-toggle-semantic-mode)
- (define-key map "\C-c,j" #'semantic-complete-jump-local)
- (define-key map "\C-c,J" #'semantic-complete-jump)
- (define-key map "\C-c,m" #'semantic-complete-jump-local-members)
- (define-key map "\C-c,g" #'semantic-symref-symbol)
- (define-key map "\C-c,G" #'semantic-symref)
- (define-key map "\C-c,p" #'senator-previous-tag)
- (define-key map "\C-c,n" #'senator-next-tag)
- (define-key map "\C-c,u" #'senator-go-to-up-reference)
- (define-key map "\C-c, " #'semantic-complete-analyze-inline)
- (define-key map "\C-c,\C-w" #'senator-kill-tag)
- (define-key map "\C-c,\M-w" #'senator-copy-tag)
- (define-key map "\C-c,\C-y" #'senator-yank-tag)
- (define-key map "\C-c,r" #'senator-copy-tag-to-register)
- (define-key map "\C-c,," #'semantic-force-refresh)
- (define-key map [?\C-c ?, up] #'senator-transpose-tags-up)
- (define-key map [?\C-c ?, down] #'senator-transpose-tags-down)
- (define-key map "\C-c,l" #'semantic-analyze-possible-completions)
- ;; This hack avoids showing the CEDET menu twice if ede-minor-mode
- ;; and Semantic are both enabled. Is there a better way?
- (define-key map [menu-bar cedet-menu]
- (list 'menu-item "Development" cedet-menu-map
- :enable (quote (not (and menu-bar-mode
- (bound-and-true-p global-ede-mode))))))
- ;; (define-key km "-" 'senator-fold-tag)
- ;; (define-key km "+" 'senator-unfold-tag)
- map))
-
-;; Activate the Semantic items in cedet-menu-map
-(let ((navigate-menu (make-sparse-keymap "Navigate Tags"))
- (edit-menu (make-sparse-keymap "Edit Tags")))
-
- ;; Edit Tags submenu:
- (define-key edit-menu [semantic-analyze-possible-completions]
- '(menu-item "List Completions" semantic-analyze-possible-completions
- :enable (semantic-active-p)
- :help "Display a list of completions for the tag at point"))
- (define-key edit-menu [semantic-complete-analyze-inline]
- '(menu-item "Complete Tag Inline" semantic-complete-analyze-inline
- :enable (semantic-active-p)
- :help "Display inline completion for the tag at point"))
- (define-key edit-menu [semantic-completion-separator]
- '("--"))
- (define-key edit-menu [senator-transpose-tags-down]
- '(menu-item "Transpose Tags Down" senator-transpose-tags-down
- :enable (and (semantic-active-p)
- (semantic-current-tag))
- :help "Transpose the current tag and the next tag"))
- (define-key edit-menu [senator-transpose-tags-up]
- '(menu-item "Transpose Tags Up" senator-transpose-tags-up
- :enable (and (semantic-active-p)
- (semantic-current-tag))
- :help "Transpose the current tag and the previous tag"))
- (define-key edit-menu [semantic-edit-separator]
- '("--"))
- (define-key edit-menu [senator-yank-tag]
- '(menu-item "Yank Tag" senator-yank-tag
- :enable (and (boundp 'senator-tag-ring)
- (not (ring-empty-p senator-tag-ring)))
- :help "Yank the head of the tag ring into the buffer"))
- (define-key edit-menu [senator-copy-tag-to-register]
- '(menu-item "Copy Tag To Register" senator-copy-tag-to-register
- :enable (and (semantic-active-p)
- (semantic-current-tag))
- :help "Yank the head of the tag ring into the buffer"))
- (define-key edit-menu [senator-copy-tag]
- '(menu-item "Copy Tag" senator-copy-tag
- :enable (and (semantic-active-p)
- (semantic-current-tag))
- :help "Copy the current tag to the tag ring"))
- (define-key edit-menu [senator-kill-tag]
- '(menu-item "Kill Tag" senator-kill-tag
- :enable (and (semantic-active-p)
- (semantic-current-tag))
- :help "Kill the current tag, and copy it to the tag ring"))
-
- ;; Navigate Tags submenu:
- (define-key navigate-menu [senator-narrow-to-defun]
- '(menu-item "Narrow to Tag" senator-narrow-to-defun
- :enable (and (semantic-active-p)
- (semantic-current-tag))
- :help "Narrow the buffer to the bounds of the current tag"))
- (define-key navigate-menu [semantic-narrow-to-defun-separator]
- '("--"))
- (define-key navigate-menu [semantic-symref-symbol]
- '(menu-item "Find Tag References..." semantic-symref-symbol
- :enable (semantic-active-p)
- :help "Read a tag and list the references to it"))
- (define-key navigate-menu [semantic-complete-jump]
- '(menu-item "Find Tag Globally..." semantic-complete-jump
- :enable (semantic-active-p)
- :help "Read a tag name and find it in the current project"))
- (define-key navigate-menu [semantic-complete-jump-local-members]
- '(menu-item "Find Local Members ..." semantic-complete-jump-local-members
- :enable (semantic-active-p)
- :help "Read a tag name and find a local member with that name"))
- (define-key navigate-menu [semantic-complete-jump-local]
- '(menu-item "Find Tag in This Buffer..." semantic-complete-jump-local
- :enable (semantic-active-p)
- :help "Read a tag name and find it in this buffer"))
- (define-key navigate-menu [semantic-navigation-separator]
- '("--"))
- (define-key navigate-menu [senator-go-to-up-reference]
- '(menu-item "Parent Tag" senator-go-to-up-reference
- :enable (semantic-active-p)
- :help "Navigate up one reference by tag"))
- (define-key navigate-menu [senator-next-tag]
- '(menu-item "Next Tag" senator-next-tag
- :enable (semantic-active-p)
- :help "Go to the next tag"))
- (define-key navigate-menu [senator-previous-tag]
- '(menu-item "Previous Tag" senator-previous-tag
- :enable (semantic-active-p)
- :help "Go to the previous tag"))
-
- ;; Top level menu items:
- (define-key cedet-menu-map [semantic-force-refresh]
- '(menu-item "Reparse Buffer" semantic-force-refresh
- :help "Force a full reparse of the current buffer"
- :visible semantic-mode
- :enable (semantic-active-p)))
- (define-key cedet-menu-map [semantic-edit-menu]
- `(menu-item "Edit Tags" ,edit-menu
- :visible semantic-mode))
- (define-key cedet-menu-map [navigate-menu]
- `(menu-item "Navigate Tags" ,navigate-menu
- :visible semantic-mode))
- (define-key cedet-menu-map [semantic-options-separator]
- '("--"))
- (define-key cedet-menu-map [global-semantic-highlight-func-mode]
- '(menu-item "Highlight Current Function" global-semantic-highlight-func-mode
- :help "Highlight the tag at point"
- :visible semantic-mode
- :button (:toggle . global-semantic-highlight-func-mode)))
- (define-key cedet-menu-map [global-semantic-stickyfunc-mode]
- '(menu-item "Stick Top Tag to Headerline" global-semantic-stickyfunc-mode
- :help "Stick the tag scrolled off the top of the buffer into the header line"
- :visible semantic-mode
- :button (:toggle . (bound-and-true-p
- global-semantic-stickyfunc-mode))))
- (define-key cedet-menu-map [global-semantic-decoration-mode]
- '(menu-item "Decorate Tags" global-semantic-decoration-mode
- :help "Decorate tags based on tag attributes"
- :visible semantic-mode
- :button (:toggle . (bound-and-true-p
- global-semantic-decoration-mode))))
- (define-key cedet-menu-map [global-semantic-idle-completions-mode]
- '(menu-item "Show Tag Completions" global-semantic-idle-completions-mode
- :help "Show tag completions when idle"
- :visible semantic-mode
- :enable global-semantic-idle-scheduler-mode
- :button (:toggle . global-semantic-idle-completions-mode)))
- (define-key cedet-menu-map [global-semantic-idle-summary-mode]
- '(menu-item "Show Tag Summaries" global-semantic-idle-summary-mode
- :help "Show tag summaries when idle"
- :visible semantic-mode
- :enable global-semantic-idle-scheduler-mode
- :button (:toggle . global-semantic-idle-summary-mode)))
- (define-key cedet-menu-map [global-semantic-idle-scheduler-mode]
- '(menu-item "Reparse When Idle" global-semantic-idle-scheduler-mode
- :help "Keep a buffer's parse tree up to date when idle"
- :visible semantic-mode
- :button (:toggle . global-semantic-idle-scheduler-mode)))
- (define-key cedet-menu-map [global-semanticdb-minor-mode]
- '(menu-item "Semantic Database" global-semanticdb-minor-mode
- :help "Store tag information in a database"
- :visible semantic-mode
- :button (:toggle . global-semanticdb-minor-mode))))
-
-;; The `semantic-mode' command, in conjunction with the
-;; `semantic-default-submodes' variable, toggles Semantic's various
-;; auxiliary minor modes.
-
-(defvar semantic-load-system-cache-loaded nil
- "Non-nil when the Semantic system caches have been loaded.
-Prevent this load system from loading files in twice.")
-
-(defconst semantic-submode-list
- '(global-semantic-highlight-func-mode
- global-semantic-decoration-mode
- global-semantic-stickyfunc-mode
- global-semantic-idle-completions-mode
- global-semantic-idle-scheduler-mode
- global-semanticdb-minor-mode
- global-semantic-idle-summary-mode
- global-semantic-mru-bookmark-mode
- global-semantic-idle-local-symbol-highlight-mode
- global-semantic-highlight-edits-mode
- global-semantic-show-unmatched-syntax-mode
- global-semantic-show-parser-state-mode)
- "List of auxiliary minor modes in the Semantic package.")
-
-;;;###autoload
-(defcustom semantic-default-submodes
- '(global-semantic-idle-scheduler-mode global-semanticdb-minor-mode)
- "List of auxiliary Semantic minor modes enabled by `semantic-mode'.
-The possible elements of this list include the following:
-
- `global-semanticdb-minor-mode' - Maintain tag database.
- `global-semantic-idle-scheduler-mode' - Reparse buffer when idle.
- `global-semantic-idle-summary-mode' - Show summary of tag at point.
- `global-semantic-idle-completions-mode' - Show completions when idle.
- `global-semantic-decoration-mode' - Additional tag decorations.
- `global-semantic-highlight-func-mode' - Highlight the current tag.
- `global-semantic-stickyfunc-mode' - Show current fun in header line.
- `global-semantic-mru-bookmark-mode' - Provide `switch-to-buffer'-like
- keybinding for tag names.
- `global-semantic-idle-local-symbol-highlight-mode' - Highlight references
- of the symbol under point.
-The following modes are more targeted at people who want to see
- some internal information of the semantic parser in action:
- `global-semantic-highlight-edits-mode' - Visualize incremental parser by
- highlighting not-yet parsed changes.
- `global-semantic-show-unmatched-syntax-mode' - Highlight unmatched lexical
- syntax tokens.
- `global-semantic-show-parser-state-mode' - Display the parser cache state."
- :group 'semantic
- :type `(set ,@(mapcar (lambda (c) (list 'const c))
- semantic-submode-list)))
-
-;;;###autoload
-(define-minor-mode semantic-mode
- "Toggle parser features (Semantic mode).
-
-In Semantic mode, Emacs parses the buffers you visit for their
-semantic content. This information is used by a variety of
-auxiliary minor modes, listed in `semantic-default-submodes';
-all the minor modes in this list are also enabled when you enable
-Semantic mode.
-
-\\{semantic-mode-map}"
- :global t
- :group 'semantic
- (if semantic-mode
- ;; Turn on Semantic mode
- (progn
- ;; Enable all the global auxiliary minor modes in
- ;; `semantic-submode-list'.
- (dolist (mode semantic-submode-list)
- (and (memq mode semantic-default-submodes)
- (fboundp mode)
- (funcall mode 1)))
- (add-hook 'mode-local-init-hook #'semantic-new-buffer-fcn)
- ;; Add semantic-ia-complete-symbol to
- ;; completion-at-point-functions, so that it is run from
- ;; M-TAB.
- ;;
- ;; Note: The first entry added is the last entry run, so the
- ;; most specific entry should be last.
- (add-hook 'completion-at-point-functions
- #'semantic-analyze-nolongprefix-completion-at-point-function)
- (add-hook 'completion-at-point-functions
- #'semantic-analyze-notc-completion-at-point-function)
- (add-hook 'completion-at-point-functions
- #'semantic-analyze-completion-at-point-function)
-
- (if (bound-and-true-p global-ede-mode)
- (define-key cedet-menu-map [cedet-menu-separator] '("--")))
- (dolist (b (buffer-list))
- (with-current-buffer b
- (semantic-new-buffer-fcn))))
- ;; Disable Semantic features. Removing everything Semantic has
- ;; introduced in the buffer is pretty much futile, but we have to
- ;; clean the hooks and delete Semantic-related overlays, so that
- ;; Semantic can be re-activated cleanly.
- (remove-hook 'mode-local-init-hook #'semantic-new-buffer-fcn)
- (remove-hook 'completion-at-point-functions
- #'semantic-analyze-completion-at-point-function)
- (remove-hook 'completion-at-point-functions
- #'semantic-analyze-notc-completion-at-point-function)
- (remove-hook 'completion-at-point-functions
- #'semantic-analyze-nolongprefix-completion-at-point-function)
-
- (remove-hook 'after-change-functions
- #'semantic-change-function)
- (define-key cedet-menu-map [cedet-menu-separator] nil)
- (define-key cedet-menu-map [semantic-options-separator] nil)
- (dolist (mode semantic-submode-list)
- (if (and (boundp mode) (symbol-value mode))
- (funcall mode -1)))
- ;; Unlink buffer and clear cache
- (semantic--tag-unlink-cache-from-buffer)
- (setq semantic--buffer-cache nil)
- ;; Make sure we run the setup function if Semantic gets
- ;; re-activated.
- (setq semantic-new-buffer-fcn-was-run nil)))
-
-;;; Autoload some functions that are not in semantic/loaddefs
-
-(autoload 'global-semantic-idle-completions-mode "semantic/idle"
- "Toggle global use of `semantic-idle-completions-mode'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle." t nil)
-
-(autoload 'semantic-idle-completions-mode "semantic/idle"
- "Display a list of possible completions in a tooltip.
-
-This is a minor mode which performs actions during idle time.
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled." t nil)
-
-(autoload 'global-semantic-idle-summary-mode "semantic/idle"
- "Toggle global use of `semantic-idle-summary-mode'.
-If ARG is positive, enable, if it is negative, disable.
-If ARG is nil, then toggle." t nil)
-
-(autoload 'semantic-idle-summary-mode "semantic/idle"
- "Display a tag summary of the lexical token under the cursor.
-Call `semantic-idle-summary-current-symbol-info' for getting the
-current tag to display information.
-
-This is a minor mode which performs actions during idle time.
-With prefix argument ARG, turn on if positive, otherwise off. The
-minor mode can be turned on only if semantic feature is available and
-the current buffer was set up for parsing. Return non-nil if the
-minor mode is enabled." t nil)
-
-(autoload 'global-semantic-idle-local-symbol-highlight-mode "semantic/idle"
- "Highlight the tag and symbol references of the symbol under point.
-Call `semantic-analyze-current-context' to find the reference tag.
-Call `semantic-symref-hits-in-region' to identify local references." t nil)
-
-(autoload 'srecode-template-setup-parser "srecode/srecode-template"
- "Set up buffer for parsing SRecode template files." t nil)
-
-(autoload 'semantic-analyze-completion-at-point-function "semantic/analyze"
- "Return possible analysis completions at point.")
-
-(autoload 'semantic-analyze-notc-completion-at-point-function "semantic/analyze"
- "Return possible analysis completions at point.")
-
-(autoload 'semantic-analyze-nolongprefix-completion-at-point-function
- "semantic/analyze"
- "Return possible analysis completions at point.")
-
-(provide 'semantic)
-
-;; Semantic-util is a part of the semantic API. Include it last
-;; because it depends on semantic.
-(require 'semantic/util)
-
-;; (require 'semantic/load)
-
-;;; semantic.el ends here
+++ /dev/null
-;;; semantic/analyze.el --- Analyze semantic tags against local context -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000-2005, 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic, as a tool, provides a nice list of searchable tags.
-;; That information can provide some very accurate answers if the current
-;; context of a position is known.
-;;
-;; Semantic-ctxt provides ways of analyzing, and manipulating the
-;; semantic context of a language in code.
-;;
-;; This library provides routines for finding intelligent answers to
-;; tough problems, such as if an argument to a function has the correct
-;; return type, or all possible tags that fit in a given local context.
-;;
-
-;;; Vocabulary:
-;;
-;; Here are some words used to describe different things in the analyzer:
-;;
-;; tag - A single entity
-;; prefix - The beginning of a symbol, usually used to look up something
-;; incomplete.
-;; type - The name of a datatype in the language.
-;; metatype - If a type is named in a declaration like:
-;; struct moose somevariable;
-;; that name "moose" can be turned into a concrete type.
-;; tag sequence - In C code, a list of dereferences, such as:
-;; this.that.theother();
-;; parent - For a datatype in an OO language, another datatype
-;; inherited from. This excludes interfaces.
-;; scope - A list of tags that can be dereferenced that cannot
-;; be found from the global namespace.
-;; scopetypes - A list of tags which are datatype that contain
-;; the scope. The scopetypes need to have the scope extracted
-;; in a way that honors the type of inheritance.
-;; nest/nested - When one tag is contained entirely in another.
-;;
-;; context - A semantic datatype representing a point in a buffer.
-;;
-;; constraint - If a context specifies a specific datatype is needed,
-;; that is a constraint.
-;; constants - Some datatypes define elements of themselves as a
-;; constant. These need to be returned as there would be no
-;; other possible completions.
-
-(require 'semantic)
-(require 'semantic/format)
-(require 'semantic/ctxt)
-(require 'semantic/scope)
-(require 'semantic/sort)
-(require 'semantic/analyze/fcn)
-
-(eval-when-compile (require 'semantic/find))
-
-(declare-function data-debug-new-buffer "data-debug")
-(declare-function data-debug-insert-object-slots "eieio-datadebug")
-
-;;; Code:
-(defvar semantic-analyze-error-stack nil
- "Collection of any errors thrown during analysis.")
-
-(defun semantic-analyze-push-error (err)
- "Push the error data in ERR onto the error stack."
- (push err semantic-analyze-error-stack))
-
-;;; Analysis Classes
-;;
-;; These classes represent what a context is. Different types
-;; of contexts provide differing amounts of information to help
-;; provide completions.
-;;
-(defclass semantic-analyze-context ()
- ((bounds :initarg :bounds
- :type list
- :documentation "The bounds of this context.
-Usually bound to the dimension of a single symbol or command.")
- (prefix :initarg :prefix
- :type list
- :documentation "List of tags defining local text.
-This can be nil, or a list where the last element can be a string
-representing text that may be incomplete. Preceding elements
-must be semantic tags representing variables or functions
-called in a dereference sequence.")
- (prefixclass :initarg :prefixclass
- :type list
- :documentation "Tag classes expected at this context.
-These are classes for tags, such as 'function, or 'variable.")
- (prefixtypes :initarg :prefixtypes
- :type list
- :documentation "List of tags defining types for :prefix.
-This list is one shorter than :prefix. Each element is a semantic
-tag representing a type matching the semantic tag in the same
-position in PREFIX.")
- (scope :initarg :scope
- :type (or null semantic-scope-cache)
- :documentation "List of tags available in scopetype.
-See `semantic-analyze-scoped-tags' for details.")
- (buffer :initarg :buffer
- :type buffer
- :documentation "The buffer this context is derived from.")
- (errors :initarg :errors
- :documentation "Any errors thrown and caught during analysis.")
- )
- "Base analysis data for any context.")
-
-(defclass semantic-analyze-context-assignment (semantic-analyze-context)
- ((assignee :initarg :assignee
- :type list
- :documentation "A sequence of tags for an assignee.
-This is a variable into which some value is being placed. The last
-item in the list is the variable accepting the value. Earlier
-tags represent the variables being dereferenced to get to the
-assignee."))
- "Analysis class for a value in an assignment.")
-
-(defclass semantic-analyze-context-functionarg (semantic-analyze-context)
- ((function :initarg :function
- :type list
- :documentation "A sequence of tags for a function.
-This is a function being called. The cursor will be in the position
-of an argument.
-The last tag in :function is the function being called. Earlier
-tags represent the variables being dereferenced to get to the
-function.")
- (index :initarg :index
- :type integer
- :documentation "The index of the argument for this context.
-If a function takes 4 arguments, this value should be bound to
-the values 1 through 4.")
- (argument :initarg :argument
- :type list
- :documentation "A sequence of tags for the :index argument.
-The argument can accept a value of some type, and this contains the
-tag for that definition. It should be a tag, but might
-be just a string in some circumstances.")
- )
- "Analysis class for a value as a function argument.")
-
-(defclass semantic-analyze-context-return (semantic-analyze-context)
- () ; No extra data.
- "Analysis class for return data.
-Return data methods identify the required type by the return value
-of the parent function.")
-
-;;; METHODS
-;;
-;; Simple methods against the context classes.
-;;
-(cl-defmethod semantic-analyze-type-constraint
- ((_context semantic-analyze-context) &optional desired-type)
- "Return a type constraint for completing :prefix in CONTEXT.
-Optional argument DESIRED-TYPE may be a non-type tag to analyze."
- (when (semantic-tag-p desired-type)
- ;; Convert the desired type if needed.
- (if (not (eq (semantic-tag-class desired-type) 'type))
- (setq desired-type (semantic-tag-type desired-type)))
- ;; Protect against plain strings
- (cond ((stringp desired-type)
- (setq desired-type (list desired-type 'type)))
- ((and (stringp (car desired-type))
- (not (semantic-tag-p desired-type)))
- (setq desired-type (list (car desired-type) 'type)))
- ((semantic-tag-p desired-type)
- ;; We have a tag of some sort. Yay!
- nil)
- (t (setq desired-type nil))
- )
- desired-type))
-
-(cl-defmethod semantic-analyze-type-constraint
- ((context semantic-analyze-context-functionarg))
- "Return a type constraint for completing :prefix in CONTEXT."
- (cl-call-next-method context (car (oref context argument))))
-
-(cl-defmethod semantic-analyze-type-constraint
- ((context semantic-analyze-context-assignment))
- "Return a type constraint for completing :prefix in CONTEXT."
- (cl-call-next-method context (car (reverse (oref context assignee)))))
-
-(cl-defmethod semantic-analyze-interesting-tag
- ((context semantic-analyze-context))
- "Return a tag from CONTEXT that would be most interesting to a user."
- (let ((prefix (reverse (oref context prefix))))
- ;; Go back through the prefix until we find a tag we can return.
- (while (and prefix (not (semantic-tag-p (car prefix))))
- (setq prefix (cdr prefix)))
- ;; Return the found tag, or nil.
- (car prefix)))
-
-(cl-defmethod semantic-analyze-interesting-tag
- ((context semantic-analyze-context-functionarg))
- "Try the base, and if that fails, return what we are assigning into."
- (or (cl-call-next-method) (car-safe (oref context function))))
-
-(cl-defmethod semantic-analyze-interesting-tag
- ((context semantic-analyze-context-assignment))
- "Try the base, and if that fails, return what we are assigning into."
- (or (cl-call-next-method) (car-safe (oref context assignee))))
-
-;;; ANALYSIS
-;;
-;; Start out with routines that will calculate useful parts of
-;; the general analyzer function. These could be used directly
-;; by an application that doesn't need to calculate the full
-;; context.
-
-(define-overloadable-function semantic-analyze-find-tag-sequence
- (sequence &optional scope typereturn throwsym &rest flags)
- "Attempt to find all tags in SEQUENCE.
-Optional argument LOCALVAR is the list of local variables to use when
-finding the details on the first element of SEQUENCE in case
-it is not found in the global set of tables.
-Optional argument SCOPE are additional terminals to search which are currently
-scoped. These are not local variables, but symbols available in a structure
-which doesn't need to be dereferenced.
-Optional argument TYPERETURN is a symbol in which the types of all found
-will be stored. If nil, that data is thrown away.
-Optional argument THROWSYM specifies a symbol the throw on non-recoverable
-error.
-Remaining arguments FLAGS are additional flags to apply when searching.")
-
-(defun semantic-analyze-find-tag-sequence-default
- ;; Note: overloadable fcn uses &rest, but it is a list already, so we don't need
- ;; to do that in the -default.
- (sequence &optional scope typereturn throwsym flags)
- "Attempt to find all tags in SEQUENCE.
-SCOPE are extra tags which are in scope.
-TYPERETURN is a symbol in which to place a list of tag classes that
-are found in SEQUENCE.
-Optional argument THROWSYM specifies a symbol the throw on non-recoverable
-error.
-Remaining arguments FLAGS are additional flags to apply when searching.
-This function knows of flags:
- `mustbeclassvariable'"
- (let ((s sequence) ; copy of the sequence
- (tmp nil) ; tmp find variable
- (tag nil) ; tag return list
- (tagtype nil) ; tag types return list
- (fname nil)
- (miniscope (when scope (clone scope)))
- (tagclass (if (memq 'mustbeclassvariable flags)
- 'variable nil))
- )
- ;; First order check. Is this wholly contained in the typecache?
- (setq tmp (semanticdb-typecache-find sequence))
-
- (when tmp
- (if (or (not tagclass) (semantic-tag-of-class-p tmp tagclass))
- ;; We are effectively done...
- (setq s nil
- tag (list tmp))
- ;; tagclass doesn't match, so fail this.
- (setq tmp nil)))
-
- (unless tmp
- ;; For tag class filtering, only apply the filter if the first entry
- ;; is also the only entry.
- (let ((lftagclass (if (= (length s) 1) tagclass)))
-
- ;; For the first entry, it better be a variable, but it might
- ;; be in the local context too.
- ;; NOTE: Don't forget c++ namespace foo::bar.
- (setq tmp (or
- ;; Is this tag within our scope. Scopes can sometimes
- ;; shadow other things, so it goes first.
- (and scope (semantic-scope-find (car s) lftagclass scope))
- ;; Find the tag out there... somewhere, but not in scope
- (semantic-analyze-find-tag (car s) lftagclass)
- ))
-
- (if (and (listp tmp) (semantic-tag-p (car tmp)))
- (setq tmp (semantic-analyze-select-best-tag tmp lftagclass)))
- (if (not (semantic-tag-p tmp))
- (if throwsym
- (throw throwsym "Cannot find definition")
- (error "Cannot find definition for \"%s\"" (car s))))
- (setq s (cdr s))
- (setq tag (cons tmp tag)) ; tag is nil here...
- (setq fname (semantic-tag-file-name tmp))
- ))
-
- ;; For the middle entries
- (while s
- ;; Using the tag found in TMP, let's find the tag
- ;; representing the full typeographic information of its
- ;; type, and use that to determine the search context for
- ;; (car s)
- (let* ((tmptype
- ;; In some cases the found TMP is a type,
- ;; and we can use it directly.
- (cond ((semantic-tag-of-class-p tmp 'type)
- (or (semantic-analyze-type tmp miniscope)
- tmp))
- (t
- (semantic-analyze-tag-type tmp miniscope))))
- (typefile
- (when tmptype
- (semantic-tag-file-name tmptype)))
- (slots nil))
-
- ;; Get the children
- (setq slots (semantic-analyze-scoped-type-parts tmptype scope))
-
- ;; find (car s) in the list o slots
- (setq tmp (semantic-find-tags-by-name (car s) slots))
-
- ;; If we have lots
- (if (and (listp tmp) (semantic-tag-p (car tmp)))
- (setq tmp (semantic-analyze-select-best-tag tmp)))
-
- ;; Make sure we have a tag.
- (if (not (semantic-tag-p tmp))
- (if (cdr s)
- ;; In the middle, we need to keep seeking our types out.
- (error "Cannot find definition for \"%s\"" (car s))
- ;; Else, it's ok to end with a non-tag
- (setq tmp (car s))))
-
- (setq fname (or typefile fname))
- (when (and fname (semantic-tag-p tmp)
- (not (semantic-tag-in-buffer-p tmp)))
- (semantic--tag-put-property tmp :filename fname))
- (setq tag (cons tmp tag))
- (setq tagtype (cons tmptype tagtype))
- (when miniscope
- (let ((rawscope
- (apply #'append
- (mapcar #'semantic-tag-type-members tagtype))))
- (oset miniscope fullscope rawscope)))
- )
- (setq s (cdr s)))
-
- (if typereturn (set typereturn (nreverse tagtype)))
- ;; Return the mess
- (nreverse tag)))
-
-(defun semantic-analyze-find-tag (name &optional tagclass scope)
- "Return the first tag found with NAME or nil if not found.
-Optional argument TAGCLASS specifies the class of tag to return,
-such as `function' or `variable'.
-Optional argument SCOPE specifies a scope object which has
-additional tags which are in SCOPE and do not need prefixing to
-find.
-
-This is a wrapper on top of semanticdb, semanticdb typecache,
-semantic-scope, and semantic search functions. Almost all
-searches use the same arguments."
- (let ((namelst (if (consp name) name ;; test if pre-split.
- (semantic-analyze-split-name name))))
- (cond
- ;; If the splitter gives us a list, use the sequence finder
- ;; to get the list. Since this routine is expected to return
- ;; only one tag, return the LAST tag found from the sequence
- ;; which is supposedly the nested reference.
- ;;
- ;; Of note, the SEQUENCE function below calls this function
- ;; (recursively now) so the names that we get from the above
- ;; fcn better not, in turn, be splittable.
- ((listp namelst)
- ;; If we had a split, then this is likely a c++ style namespace::name sequence,
- ;; so take a short-cut through the typecache.
- (or (semanticdb-typecache-find namelst)
- ;; Ok, not there, try the usual...
- (let ((seq (semantic-analyze-find-tag-sequence
- namelst scope nil)))
- (semantic-analyze-select-best-tag seq tagclass)
- )))
- ;; If NAME is solo, then do our searches for it here.
- ((stringp namelst)
- (let ((retlist (and scope (semantic-scope-find name tagclass scope))))
- (if retlist
- (semantic-analyze-select-best-tag
- retlist tagclass)
- (if (eq tagclass 'type)
- (semanticdb-typecache-find name)
- ;; Search in the typecache. First entries in a sequence are
- ;; often there.
- (setq retlist (semanticdb-typecache-find name))
- (if (and retlist (or (not tagclass)
- (semantic-tag-of-class-p retlist 'tagclass)))
- retlist
- (semantic-analyze-select-best-tag
- (semanticdb-strip-find-results
- (semanticdb-find-tags-by-name name)
- 'name)
- tagclass)
- )))))
- )))
-
-;;; SHORT ANALYSIS
-;;
-;; Create a mini-analysis of just the symbol under point.
-;;
-(define-overloadable-function semantic-analyze-current-symbol
- (analyzehookfcn &optional position)
- "Call ANALYZEHOOKFCN after analyzing the symbol under POSITION.
-The ANALYZEHOOKFCN is called with the current symbol bounds, and the
-analyzed prefix. It should take the arguments (START END PREFIX).
-The ANALYZEHOOKFCN is only called if some sort of prefix with bounds was
-found under POSITION.
-
-The results of ANALYZEHOOKFCN is returned, or nil if there was nothing to
-call it with.
-
-For regular analysis, you should call `semantic-analyze-current-context'
-to calculate the context information. The purpose for this function is
-to provide a large number of non-cached analysis for filtering symbols."
- ;; Only do this in a Semantic enabled buffer.
- (when (not (semantic-active-p))
- (error "Cannot analyze buffers not supported by Semantic"))
- ;; Always refresh out tags in a safe way before doing the
- ;; context.
- (semantic-refresh-tags-safe)
- ;; Do the rest of the analysis.
- (save-match-data
- (save-excursion
- (:override)))
- )
-
-(defvar semantic--prefixtypes)
-
-(defun semantic-analyze-current-symbol-default (analyzehookfcn position)
- "Call ANALYZEHOOKFCN on the analyzed symbol at POSITION."
- (let* ((semantic-analyze-error-stack nil)
- ;; (LLstart (current-time))
- (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point))))
- (prefix (car prefixandbounds))
- (bounds (nth 2 prefixandbounds))
- (scope (semantic-calculate-scope position))
- )
- ;; Only do work if we have bounds (meaning a prefix to complete)
- (when bounds
-
- (if debug-on-error
- (catch 'unfindable
- ;; If debug on error is on, allow debugging in this fcn.
- (setq prefix (semantic-analyze-find-tag-sequence
- prefix scope 'semantic--prefixtypes 'unfindable)))
- ;; Debug on error is off. Capture errors and move on
- (condition-case err
- ;; NOTE: This line is duplicated in
- ;; semantic-analyzer-debug-global-symbol
- ;; You will need to update both places.
- (setq prefix (semantic-analyze-find-tag-sequence
- prefix scope 'semantic--prefixtypes))
- (error (semantic-analyze-push-error err))))
-
- ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart nil))
-
- )
- (when prefix
- (prog1
- (funcall analyzehookfcn (car bounds) (cdr bounds) prefix)
- ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart nil))
- )
-
- )))
-
-;;; MAIN ANALYSIS
-;;
-;; Create a full-up context analysis.
-;;
-;;;###autoload
-(define-overloadable-function semantic-analyze-current-context (&optional position)
- "Analyze the current context at optional POSITION.
-If called interactively, display interesting information about POSITION
-in a separate buffer.
-Returns an object based on symbol `semantic-analyze-context'.
-
-This function can be overridden with the symbol `analyze-context'.
-When overriding this function, your override will be called while
-cursor is at POSITION. In addition, your function will not be called
-if a cached copy of the return object is found."
- (interactive "d")
- ;; Only do this in a Semantic enabled buffer.
- (when (not (semantic-active-p))
- (error "Cannot analyze buffers not supported by Semantic"))
- ;; Always refresh out tags in a safe way before doing the
- ;; context.
- (semantic-refresh-tags-safe)
- ;; Do the rest of the analysis.
- (if (not position) (setq position (point)))
- (save-excursion
- (goto-char position)
- (let* ((answer (semantic-get-cache-data 'current-context)))
- (with-syntax-table semantic-lex-syntax-table
- (when (not answer)
- (setq answer (:override))
- (when (and answer (oref answer bounds))
- (with-slots (bounds) answer
- (semantic-cache-data-to-buffer (current-buffer)
- (car bounds)
- (cdr bounds)
- answer
- 'current-context
- 'exit-cache-zone)))
- ;; Check for interactivity
- (when (called-interactively-p 'any)
- (if answer
- (semantic-analyze-pop-to-context answer)
- (message "No Context."))
- ))
-
- answer))))
-
-(defun semantic-analyze-current-context-default (position)
- "Analyze the current context at POSITION.
-Returns an object based on symbol `semantic-analyze-context'."
- (let* ((semantic-analyze-error-stack nil)
- (context-return nil)
- (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point))))
- (prefix (car prefixandbounds))
- (bounds (nth 2 prefixandbounds))
- ;; @todo - vv too early to really know this answer! vv
- (prefixclass (semantic-ctxt-current-class-list))
- (semantic--prefixtypes nil)
- (scope (semantic-calculate-scope position))
- (function nil)
- (fntag nil)
- arg fntagend argtag
- assign asstag newseq
- )
-
- ;; Pattern for Analysis:
- ;;
- ;; Step 1: Calculate DataTypes in Scope:
- ;;
- ;; a) Calculate the scope (above)
- ;;
- ;; Step 2: Parse context
- ;;
- ;; a) Identify function being called, or variable assignment,
- ;; and find source tags for those references
- ;; b) Identify the prefix (text cursor is on) and find the source
- ;; tags for those references.
- ;;
- ;; Step 3: Assemble an object
- ;;
-
- ;; Step 2 a:
-
- (setq function (semantic-ctxt-current-function))
-
- (when function
- ;; Calculate the argument for the function if there is one.
- (setq arg (semantic-ctxt-current-argument))
-
- ;; Find a tag related to the function name.
- (condition-case err
- (setq fntag
- (semantic-analyze-find-tag-sequence function scope))
- (error (semantic-analyze-push-error err)))
-
- ;; fntag can have the last entry as just a string, meaning we
- ;; could not find the core datatype. In this case, the searches
- ;; below will not work.
- (when (stringp (car (last fntag)))
- ;; Take a wild guess!
- (setcar (last fntag) (semantic-tag (car (last fntag)) 'function))
- )
-
- (when fntag
- (let ((fcn (semantic-find-tags-by-class 'function fntag)))
- (when (not fcn)
- (let ((ty (semantic-find-tags-by-class 'type fntag)))
- (when ty
- ;; We might have a constructor with the same name as
- ;; the found datatype.
- (setq fcn (semantic-find-tags-by-name
- (semantic-tag-name (car ty))
- (semantic-tag-type-members (car ty))))
- (if fcn
- (let ((lp fcn))
- (while lp
- (when (semantic-tag-get-attribute (car lp)
- :constructor)
- (setq fcn (cons (car lp) fcn)))
- (setq lp (cdr lp))))
- ;; Give up, go old school
- (setq fcn fntag))
- )))
- (setq fntagend (car (reverse fcn))
- argtag
- (when (semantic-tag-p fntagend)
- (nth (1- arg) (semantic-tag-function-arguments fntagend)))
- fntag fcn))))
-
- ;; Step 2 b:
-
- ;; Only do work if we have bounds (meaning a prefix to complete)
- (when bounds
-
- (if debug-on-error
- (catch 'unfindable
- (setq prefix (semantic-analyze-find-tag-sequence
- prefix scope 'semantic--prefixtypes 'unfindable))
- ;; If there's an alias, dereference it and analyze
- ;; sequence again.
- (when (setq newseq
- (semantic-analyze-dereference-alias prefix))
- (setq prefix (semantic-analyze-find-tag-sequence
- newseq scope 'semantic--prefixtypes 'unfindable))))
- ;; Debug on error is off. Capture errors and move on
- (condition-case err
- ;; NOTE: This line is duplicated in
- ;; semantic-analyzer-debug-global-symbol
- ;; You will need to update both places.
- (progn
- (setq prefix (semantic-analyze-find-tag-sequence
- prefix scope 'semantic--prefixtypes))
- (when (setq newseq
- (semantic-analyze-dereference-alias prefix))
- (setq prefix (semantic-analyze-find-tag-sequence
- newseq scope 'semantic--prefixtypes))))
- (error (semantic-analyze-push-error err))))
- )
-
- ;; Step 3:
-
- (cond
- (fntag
- ;; If we found a tag for our function, we can go into
- ;; functional context analysis mode, meaning we have a type
- ;; for the argument.
- (setq context-return
- (semantic-analyze-context-functionarg
- :buffer (current-buffer)
- :function fntag
- :index arg
- :argument (list argtag)
- :scope scope
- :prefix prefix
- :prefixclass prefixclass
- :bounds bounds
- :prefixtypes semantic--prefixtypes
- :errors semantic-analyze-error-stack)))
-
- ;; No function, try assignment
- ((and (setq assign (semantic-ctxt-current-assignment))
- ;; We have some sort of an assignment
- (condition-case err
- (setq asstag (semantic-analyze-find-tag-sequence
- assign scope nil nil 'mustbeclassvariable))
- (error (semantic-analyze-push-error err)
- nil)))
-
- (setq context-return
- (semantic-analyze-context-assignment
- :buffer (current-buffer)
- :assignee asstag
- :scope scope
- :bounds bounds
- :prefix prefix
- :prefixclass prefixclass
- :prefixtypes semantic--prefixtypes
- :errors semantic-analyze-error-stack)))
-
- ;; TODO: Identify return value condition.
- ;;((setq return .... what to do?)
- ;; ...)
-
- (bounds
- ;; Nothing in particular
- (setq context-return
- (semantic-analyze-context
- :buffer (current-buffer)
- :scope scope
- :bounds bounds
- :prefix prefix
- :prefixclass prefixclass
- :prefixtypes semantic--prefixtypes
- :errors semantic-analyze-error-stack)))
-
- (t (setq context-return nil))
- )
-
- ;; Return our context.
- context-return))
-
-(defun semantic-analyze-dereference-alias (taglist)
- "Dereference first tag in TAGLIST if it is an alias.
-Returns a sequence of names which can then be fed again into
-`semantic-analyze-find-tag-sequence'.
-Returns nil if no alias was found."
- (when (eq (semantic-tag-get-attribute (car taglist) :kind) 'alias)
- (let ((tagname
- (semantic-analyze-split-name
- (semantic-tag-name
- (car (semantic-tag-get-attribute (car taglist) :members))))))
- (append (if (listp tagname)
- tagname
- (list tagname))
- (cdr taglist)))))
-\f
-(defun semantic-adebug-analyze (&optional ctxt)
- "Perform `semantic-analyze-current-context'.
-Display the results as a debug list.
-Optional argument CTXT is the context to show."
- (interactive)
- (require 'data-debug)
- (let ((start (current-time))
- (ctxt (or ctxt (semantic-analyze-current-context))))
- (if (not ctxt)
- (message "No Analyzer Results")
- (message "Analysis took %.2f seconds."
- (semantic-elapsed-time start nil))
- (semantic-analyze-pulse ctxt)
- (if ctxt
- (progn
- (data-debug-new-buffer "*Analyzer ADEBUG*")
- (data-debug-insert-object-slots ctxt "]"))
- (message "No Context to analyze here.")))))
-
-\f
-;;; DEBUG OUTPUT
-;;
-;; Friendly output of a context analysis.
-;;
-(declare-function pulse-momentary-highlight-region "pulse")
-
-(cl-defmethod semantic-analyze-pulse ((context semantic-analyze-context))
- "Pulse the region that CONTEXT affects."
- (require 'pulse)
- (with-current-buffer (oref context buffer)
- (let ((bounds (oref context bounds)))
- (when bounds
- (pulse-momentary-highlight-region (car bounds) (cdr bounds))))))
-
-(defcustom semantic-analyze-summary-function 'semantic-format-tag-prototype
- "Function to use when creating items in Imenu.
-Some useful functions are found in `semantic-format-tag-functions'."
- :group 'semantic
- :type semantic-format-tag-custom-list)
-
-(defun semantic-analyze-princ-sequence (sequence &optional prefix _buff)
- "Send the tag SEQUENCE to standard out.
-Use PREFIX as a label.
-Use BUFF as a source of override methods."
- ;; If there is no sequence, at least show the field as being empty.
- (unless sequence (princ prefix) (princ "<none>\n"))
-
- ;; Display the sequence column aligned.
- (while sequence
- (princ prefix)
- (cond
- ((semantic-tag-p (car sequence))
- (princ (funcall semantic-analyze-summary-function
- (car sequence))))
- ((stringp (car sequence))
- (princ "\"")
- (princ (semantic--format-colorize-text (car sequence) 'variable))
- (princ "\""))
- (t
- (princ (format "'%S" (car sequence)))))
- (princ "\n")
- (setq sequence (cdr sequence))
- (setq prefix (make-string (length prefix) ? ))
- ))
-
-(cl-defmethod semantic-analyze-show ((context semantic-analyze-context))
- "Insert CONTEXT into the current buffer in a nice way."
- (semantic-analyze-princ-sequence (oref context prefix) "Prefix: " )
- (semantic-analyze-princ-sequence (oref context prefixclass) "Prefix Classes: ")
- (semantic-analyze-princ-sequence (oref context prefixtypes) "Prefix Types: ")
- (semantic-analyze-princ-sequence (oref context errors) "Encountered Errors: ")
- (princ "--------\n")
- ;(semantic-analyze-princ-sequence (oref context scopetypes) "Scope Types: ")
- ;(semantic-analyze-princ-sequence (oref context scope) "Scope: ")
- ;(semantic-analyze-princ-sequence (oref context localvariables) "LocalVars: ")
- (when (oref context scope)
- (semantic-analyze-show (oref context scope)))
- )
-
-(cl-defmethod semantic-analyze-show ((context semantic-analyze-context-assignment))
- "Insert CONTEXT into the current buffer in a nice way."
- (semantic-analyze-princ-sequence (oref context assignee) "Assignee: ")
- (cl-call-next-method))
-
-(cl-defmethod semantic-analyze-show ((context semantic-analyze-context-functionarg))
- "Insert CONTEXT into the current buffer in a nice way."
- (semantic-analyze-princ-sequence (oref context function) "Function: ")
- (princ "Argument Index: ")
- (princ (oref context index))
- (princ "\n")
- (semantic-analyze-princ-sequence (oref context argument) "Argument: ")
- (cl-call-next-method))
-
-(defun semantic-analyze-pop-to-context (context)
- "Display CONTEXT in a temporary buffer.
-CONTEXT's content is described in `semantic-analyze-current-context'."
- (semantic-analyze-pulse context)
- (with-output-to-temp-buffer "*Semantic Context Analysis*"
- (princ "Context Type: ")
- (princ (eieio-object-name context))
- (princ "\n")
- (princ "Bounds: ")
- (princ (oref context bounds))
- (princ "\n")
- (semantic-analyze-show context)
- )
- (shrink-window-if-larger-than-buffer
- (get-buffer-window "*Semantic Context Analysis*"))
- )
-
-
-;;; Completion At Point functions
-(defun semantic-analyze-completion-at-point-function ()
- "Return possible analysis completions at point.
-The completions provided are via `semantic-analyze-possible-completions'.
-This function can be used by `completion-at-point-functions'."
- (when (semantic-active-p)
- (let* ((ctxt (semantic-analyze-current-context))
- (possible (semantic-analyze-possible-completions ctxt)))
-
- ;; The return from this is either:
- ;; nil - not applicable here.
- ;; A list: (START END COLLECTION . PROPS)
- (when possible
- (list (car (oref ctxt bounds))
- (cdr (oref ctxt bounds))
- possible))
- )))
-
-(defun semantic-analyze-notc-completion-at-point-function ()
- "Return possible analysis completions at point.
-The completions provided are via `semantic-analyze-possible-completions',
-but with the `no-tc' option passed in, which means constraints based
-on what is being assigned to are ignored.
-This function can be used by `completion-at-point-functions'."
- (when (semantic-active-p)
- (let* ((ctxt (semantic-analyze-current-context))
- (possible (semantic-analyze-possible-completions ctxt 'no-tc)))
-
- (when possible
- (list (car (oref ctxt bounds))
- (cdr (oref ctxt bounds))
- possible))
- )))
-
-(defun semantic-analyze-nolongprefix-completion-at-point-function ()
- "Return possible analysis completions at point.
-The completions provided are via `semantic-analyze-possible-completions',
-but with the `no-tc' and `no-longprefix' option passed in, which means
-constraints resulting in a long multi-symbol dereference are ignored.
-This function can be used by `completion-at-point-functions'."
- (when (semantic-active-p)
- (let* ((ctxt (semantic-analyze-current-context))
- (possible (semantic-analyze-possible-completions
- ctxt 'no-tc 'no-longprefix)))
-
- (when possible
- (list (car (oref ctxt bounds))
- (cdr (oref ctxt bounds))
- possible))
- )))
-
-(provide 'semantic/analyze)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/analyze"
-;; End:
-
-;;; semantic/analyze.el ends here
+++ /dev/null
-;;; semantic/analyze/complete.el --- Smart Completions -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Calculate smart completions.
-;;
-;; Uses the analyzer context routine to determine the best possible
-;; list of completions.
-;;
-;;; History:
-;;
-;; Code was moved here from semantic/analyze.el
-
-(require 'semantic/analyze)
-
-;; For semantic-find-* macros:
-(eval-when-compile (require 'semantic/find))
-
-;;; Code:
-
-;;; Helper Fcns
-;;
-;;
-;;;###autoload
-(define-overloadable-function semantic-analyze-type-constants (type)
- "For the tag TYPE, return any constant symbols of TYPE.
-Used as options when completing.")
-
-(defun semantic-analyze-type-constants-default (_type)
- "Do nothing with TYPE."
- nil)
-
-(defun semantic-analyze-tags-of-class-list (tags classlist)
- "Return the tags in TAGS that are of classes in CLASSLIST."
- (let ((origc tags))
- ;; Accept only tags that are of the datatype specified by
- ;; the desired classes.
- (setq tags (apply #'nconc ;; All input lists are permutable.
- (mapcar (lambda (class)
- (semantic-find-tags-by-class class origc))
- classlist)))
- tags))
-
-;;; MAIN completion calculator
-;;
-;;;###autoload
-(define-overloadable-function semantic-analyze-possible-completions (context &rest flags)
- "Return a list of semantic tags which are possible completions.
-CONTEXT is either a position (such as point), or a precalculated
-context. Passing in a context is useful if the caller also needs
-to access parts of the analysis.
-The remaining FLAGS arguments are passed to the mode specific completion engine.
-Bad flags should be ignored by modes that don't use them.
-See `semantic-analyze-possible-completions-default' for details
-on the default FLAGS.
-
-Completions run through the following filters:
- * Elements currently in scope
- * Constants currently in scope
- * Elements match the :prefix in the CONTEXT.
- * Type of the completion matches the type of the context.
-Context type matching can identify the following:
- * No specific type
- * Assignment into a variable of some type.
- * Argument to a function with type constraints.
-When called interactively, displays the list of possible completions
-in a buffer."
- (interactive "d")
- ;; In theory, we don't need the below since the context will
- ;; do it for us.
- ;;(semantic-refresh-tags-safe)
- (if (semantic-active-p)
- (with-syntax-table semantic-lex-syntax-table
- (let* ((context (if (cl-typep context 'semantic-analyze-context)
- context
- (semantic-analyze-current-context context)))
- (ans (if (not context)
- (when (called-interactively-p 'any)
- (error "Nothing to complete"))
- (with-demoted-errors "%S"
- (:override)))))
- ;; If interactive, display them.
- (when (called-interactively-p 'any)
- (with-output-to-temp-buffer "*Possible Completions*"
- (semantic-analyze-princ-sequence ans "" (current-buffer)))
- (shrink-window-if-larger-than-buffer
- (get-buffer-window "*Possible Completions*")))
- ans))
- ;; Buffer was not parsed by Semantic.
- ;; Raise error if called interactively.
- (when (called-interactively-p 'any)
- (error "Buffer was not parsed by Semantic"))))
-
-(defvar semantic--prefixtypes)
-
-(defun semantic-analyze-possible-completions-default (context &optional flags)
- "Default method for producing smart completions.
-Argument CONTEXT is an object specifying the locally derived context.
-The optional argument FLAGS changes which return options are returned.
-FLAGS can be any number of:
- `no-tc' - do not apply data-type constraint.
- `no-longprefix' - ignore long multi-symbol prefixes.
- `no-unique' - do not apply unique by name filtering."
- (let* ((a context)
- (desired-type (semantic-analyze-type-constraint a))
- (desired-class (oref a prefixclass))
- (prefix (oref a prefix))
- (semantic--prefixtypes (oref a prefixtypes))
- (completetext nil)
- (completetexttype nil)
- (scope (oref a scope))
- (localvar (when scope (oref scope localvar)))
- (origc nil)
- (c nil)
- ;; (any nil)
- (do-typeconstraint (not (memq 'no-tc flags)))
- (do-longprefix (not (memq 'no-longprefix flags)))
- (do-unique (not (memq 'no-unique flags)))
- )
-
- (when (not do-longprefix)
- ;; If we are not doing the long prefix, shorten all the key
- ;; elements.
- (setq prefix (list (car (reverse prefix)))
- semantic--prefixtypes nil))
-
- ;; Calculate what our prefix string is so that we can
- ;; find all our matching text.
- (setq completetext (car (reverse prefix)))
- (if (semantic-tag-p completetext)
- (setq completetext (semantic-tag-name completetext)))
-
- (if (and (not completetext) (not desired-type))
- (error "Nothing to complete"))
-
- (if (not completetext) (setq completetext ""))
-
- ;; This better be a reasonable type, or we should fry it.
- ;; The prefixtypes should always be at least 1 less than
- ;; the prefix since the type is never looked up for the last
- ;; item when calculating a sequence.
- (setq completetexttype (car (reverse semantic--prefixtypes)))
- (when (or (not completetexttype)
- (not (and (semantic-tag-p completetexttype)
- (eq (semantic-tag-class completetexttype) 'type))))
- ;; What should I do here? I think this is an error condition.
- (setq completetexttype nil)
- ;; If we had something that was a completetexttype but it wasn't
- ;; valid, then express our dismay!
- (when (> (length prefix) 1)
- (let* ((errprefix (car (cdr (reverse prefix)))))
- (error "Cannot find types for `%s'"
- (cond ((semantic-tag-p errprefix)
- (semantic-format-tag-prototype errprefix))
- (t
- (format "%S" errprefix)))))
- ))
-
- ;; There are many places to get our completion stream for.
- ;; Here we go.
- (if completetexttype
-
- (setq c (semantic-find-tags-for-completion
- completetext
- (semantic-analyze-scoped-type-parts completetexttype scope)
- ))
-
- ;; No type based on the completetext. This is a free-range
- ;; var or function. We need to expand our search beyond this
- ;; scope into semanticdb, etc.
- (setq c (nconc
- ;; Argument list and local variables
- (semantic-find-tags-for-completion completetext localvar)
- ;; The current scope
- (semantic-find-tags-for-completion completetext (when scope (oref scope fullscope)))
- ;; The world
- (semantic-analyze-find-tags-by-prefix completetext))
- )
- )
-
- (let ((loopc c)
- (dtname (semantic-tag-name desired-type)))
-
- ;; Save off our first batch of completions
- (setq origc c)
-
- ;; Reset c.
- (setq c nil)
-
- ;; Loop over all the found matches, and categorize them
- ;; as being possible features.
- (while (and loopc do-typeconstraint)
-
- (cond
- ;; Strip operators
- ((semantic-tag-get-attribute (car loopc) :operator-flag)
- nil
- )
-
- ;; If we are completing from within some prefix,
- ;; then we want to exclude constructors and destructors
- ((and completetexttype
- (or (semantic-tag-get-attribute (car loopc) :constructor-flag)
- (semantic-tag-get-attribute (car loopc) :destructor-flag)))
- nil
- )
-
- ;; If there is a desired type, we need a pair of restrictions
- (desired-type
-
- (cond
- ;; Ok, we now have a completion list based on the text we found
- ;; we want to complete on. Now filter that stream against the
- ;; type we want to search for.
- ((string= dtname (semantic-analyze-type-to-name (semantic-tag-type (car loopc))))
- (setq c (cons (car loopc) c))
- )
-
- ;; Now anything that is a compound type which could contain
- ;; additional things which are of the desired type
- ((semantic-tag-type (car loopc))
- (let ((att (semantic-analyze-tag-type (car loopc) scope))
- )
- (if (and att (semantic-tag-type-members att))
- (setq c (cons (car loopc) c))))
- )
-
- ) ; cond
- ); desired type
-
- ;; No desired type, no other restrictions. Just add.
- (t
- (setq c (cons (car loopc) c)))
-
- ); cond
-
- (setq loopc (cdr loopc)))
-
- (when desired-type
- ;; Some types, like the enum in C, have special constant values that
- ;; we could complete with. Thus, if the target is an enum, we can
- ;; find possible symbol values to fill in that value.
- (let ((constants
- (semantic-analyze-type-constants desired-type)))
- (if constants
- (progn
- ;; Filter
- (setq constants
- (semantic-find-tags-for-completion
- completetext constants))
- ;; Add to the list
- (setq c (nconc c constants)))
- )))
- )
-
- (when desired-class
- (setq c (semantic-analyze-tags-of-class-list c desired-class)))
-
- (if do-unique
- (if c
- ;; Pull out trash.
- ;; NOTE TO SELF: Is this too slow?
- (setq c (semantic-unique-tag-table-by-name c))
- (setq c (semantic-unique-tag-table-by-name origc)))
- (when (not c)
- (setq c origc)))
-
- ;; All done!
- c))
-
-(provide 'semantic/analyze/complete)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/analyze/complete"
-;; End:
-
-;;; semantic/analyze/complete.el ends here
+++ /dev/null
-;;; semantic/analyze/debug.el --- Debug the analyzer -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Provide a top-order debugging tool for figuring out what's going on with
-;; smart completion and analyzer mode.
-
-(require 'semantic)
-(require 'semantic/analyze)
-(require 'semantic/analyze/complete)
-(require 'semantic/db-typecache)
-(require 'pulse)
-
-;; For semantic-find-tags-by-class:
-(eval-when-compile (require 'semantic/find))
-
-(declare-function ede-get-locator-object "ede/files")
-
-;;; Code:
-
-(defun semantic-analyze-debug-assist ()
- "Debug semantic analysis at the current point."
- (interactive)
- (let ((actualfcn (fetch-overload 'semantic-analyze-current-context))
- (ctxt (semantic-analyze-current-context))
- )
- ;; What to show.
- (if actualfcn
- (message "Mode %s does not use the default analyzer."
- major-mode)
- ;; Debug our context.
- )
- (or (semantic-analyzer-debug-test-local-context)
- (and ctxt (semantic-analyzer-debug-found-prefix ctxt))
- )
-
- ))
-
-;; @TODO - If this happens, but the last found type is
-;; a datatype, then the below is wrong
-(defun semantic-analyzer-debug-found-prefix (ctxt)
- "Debug the prefix found by the analyzer output CTXT."
- (let* ((pf (oref ctxt prefix))
- (pft (oref ctxt prefixtypes))
- (idx 0)
- (stop nil)
- (comp (condition-case nil
- (semantic-analyze-possible-completions ctxt)
- (error nil)))
- )
- (while (and (nth idx pf) (not stop))
- (let ((pentry (nth idx pf))
- (ptentry (nth idx pft)))
- (if (or (stringp pentry) (not ptentry))
- ;; Found something ok. Stop.
- (setq stop t)
- (setq idx (1+ idx)))))
- ;; We found the first non-tag entry. What is the situation?
- (cond
- ((and (eq idx 0) (stringp (car pf)))
- ;; First part, we couldn't find it.
- (semantic-analyzer-debug-global-symbol ctxt (car pf) comp))
- ((not (nth (1- idx) pft)) ;; idx can't be 0 here.
- ;; The previous entry failed to have an identifiable data
- ;; type, which is a global search.
- (semantic-analyzer-debug-missing-datatype ctxt idx comp))
- ((and (nth (1- idx) pft) (stringp (nth idx pf)))
- ;; Non-first search, didn't find string in known data type.
- (semantic-analyzer-debug-missing-innertype ctxt idx comp))
- (t
- ;; Things are ok?
- (message "Things look ok."))
- )))
-
-(defun semantic-analyzer-debug-global-symbol (ctxt prefix comp)
- "Debug why we can't find the first entry in the CTXT PREFIX.
-Argument COMP are possible completions here."
- (let ((tab semanticdb-current-table)
- (finderr nil)
- (origbuf (current-buffer))
- )
- (with-output-to-temp-buffer (help-buffer)
- (with-current-buffer standard-output
- (princ "Unable to find symbol ")
- (princ prefix)
- (princ ".\n\n")
-
- ;; NOTE: This line is copied from semantic-analyze-current-context.
- ;; You will need to update both places.
- (condition-case err
- (with-current-buffer origbuf
- (let* ((position (or (cdr-safe (oref ctxt bounds)) (point)))
- ;; (semantic--prefixtypes nil) ; Used as type return
- (scope (semantic-calculate-scope position))
- )
- (semantic-analyze-find-tag-sequence
- (list prefix "") scope) ;; 'semantic--prefixtypes
- )
- )
- (error (setq finderr err)))
-
- (if finderr
- (progn
- (princ "The prefix lookup code threw the following error:\n ")
- (prin1 finderr)
- (princ "\n\nTo debug this error you can do this:
- M-x toggle-debug-on-error RET
-and then re-run the debug analyzer.\n")
- )
- ;; No find error, just not found
- (princ "The prefix ")
- (princ prefix)
- (princ " could not be found in the local scope,
-nor in any search tables.\n")
- )
- (princ "\n")
-
- ;; Describe local scope, and why we might not be able to
- ;; find it.
- (semantic-analyzer-debug-describe-scope ctxt)
-
- (semantic-analyzer-debug-show-completions comp)
-
- (princ "When Semantic cannot find a symbol, it could be because the include
-path was setup incorrectly.\n")
-
- (semantic-analyzer-debug-insert-include-summary tab)
-
- ))
- (semantic-analyzer-debug-add-buttons)
- ))
-
-(defun semantic-analyzer-debug-missing-datatype (ctxt idx _comp)
- "Debug why we can't find a datatype entry for CTXT prefix at IDX.
-Argument COMP are possible completions here."
- (let* ((prefixitem (nth idx (oref ctxt prefix)))
- (dt (nth (1- idx) (oref ctxt prefixtypes)))
- (tt (semantic-tag-type prefixitem))
- (tab semanticdb-current-table)
- )
- (when dt (error "Missing Datatype debugger is confused"))
- (with-output-to-temp-buffer (help-buffer)
- (with-current-buffer standard-output
- (princ "Unable to find datatype for: \"")
- (princ (semantic-format-tag-prototype prefixitem))
- (princ "\".
-Declared type is: ")
- (when (semantic-tag-p tt)
- (semantic-analyzer-debug-insert-tag tt)
- (princ "\nRaw data type is: "))
- (princ (format "%S" tt))
- (princ "
-
-Semantic could not find this data type in any of its global tables.
-
-Semantic locates datatypes through either the local scope, or the global
-typecache.
-")
-
- ;; Describe local scope, and why we might not be able to
- ;; find it.
- (semantic-analyzer-debug-describe-scope ctxt '(type))
-
- ;; Describe the typecache.
- (princ "\nSemantic creates and maintains a type cache for each buffer.
-If the type is a global type, then it should appear in they typecache.
-To examine the typecache, type:
-
- M-x semanticdb-typecache-dump RET
-
-Current typecache Statistics:\n")
- (princ (format " %4d types global in this file\n %4d types from includes.\n"
- (length (semanticdb-typecache-file-tags tab))
- (length (semanticdb-typecache-include-tags tab))))
-
- (princ "\nIf the datatype is not in the typecache, then your include
-path may be incorrect. ")
-
- (semantic-analyzer-debug-insert-include-summary tab)
-
- ;; End with-buffer
- ))
- (semantic-analyzer-debug-add-buttons)
- ))
-
-(defun semantic-analyzer-debug-missing-innertype (ctxt idx comp)
- "Debug why we can't find an entry for CTXT prefix at IDX for known type.
-We need to see if we have possible completions against the entry before
-being too vocal about it.
-Argument COMP are possible completions here."
- (let* ((prefixitem (nth idx (oref ctxt prefix)))
- (prevprefix (nth (1- idx) (oref ctxt prefix)))
- (dt (nth (1- idx) (oref ctxt prefixtypes)))
- (desired-type (semantic-analyze-type-constraint ctxt))
- (orig-buffer (current-buffer))
- (ots (semantic-analyze-tag-type prevprefix
- (oref ctxt scope)
- t ; Don't deref
- ))
- )
- (when (not dt) (error "Missing Innertype debugger is confused"))
- (with-output-to-temp-buffer (help-buffer)
- (with-current-buffer standard-output
- (princ "Cannot find symbol \"")
- (princ prefixitem)
- (princ "\" in datatype:
- ")
- (semantic-analyzer-debug-insert-tag dt)
- (princ "\n")
-
- (cond
- ;; Any language with a namespace.
- ((string= (semantic-tag-type dt) "namespace")
- (princ "Semantic may not have found all possible namespaces with
-the name ")
- (princ (semantic-tag-name dt))
- (princ ". You can debug the entire typecache, including merged namespaces
-with the command:
-
- M-x semanticdb-typecache-dump RET")
- )
-
- ;; @todo - external declarations??
- (nil
- nil)
-
- ;; A generic explanation
- (t
- (princ "\nSemantic has found the datatype ")
- (semantic-analyzer-debug-insert-tag dt)
- (if (or (not (semantic-equivalent-tag-p ots dt))
- (not (with-current-buffer orig-buffer
- (car (semantic-analyze-dereference-metatype
- ots (oref ctxt scope))))))
- (let ((lasttype ots)
- (nexttype (with-current-buffer orig-buffer
- (car (semantic-analyze-dereference-metatype
- ots (oref ctxt scope))))))
- (if (eq nexttype lasttype)
- (princ "\n [ Debugger error trying to help with metatypes ]")
-
- (if (eq ots dt)
- (princ "\nwhich is a metatype")
- (princ "\nwhich is derived from metatype ")
- (semantic-analyzer-debug-insert-tag lasttype)))
-
- (princ ".\nThe Metatype stack is:\n")
- (princ " ")
- (semantic-analyzer-debug-insert-tag lasttype)
- (princ "\n")
- (while (and nexttype
- (not (eq nexttype lasttype)))
- (princ " ")
- (semantic-analyzer-debug-insert-tag nexttype)
- (princ "\n")
- (setq lasttype nexttype
- nexttype
- (with-current-buffer orig-buffer
- (car (semantic-analyze-dereference-metatype
- nexttype (oref ctxt scope)))))
- )
- (when (not nexttype)
- (princ " nil\n\n")
- (princ
- "Last metatype is nil. This means that semantic cannot derive
-the list of members because the type referred to cannot be found.\n")
- )
- )
- (princ "\nand its list of members.")
-
- (if (not comp)
- (progn
- (princ " Semantic does not know what
-possible completions there are for \"")
- (princ prefixitem)
- (princ "\". Examine the known
-members below for more."))
- (princ " Semantic knows of some
-possible completions for \"")
- (princ prefixitem)
- (princ "\".")))
- )
- ;; end cond
- )
-
- (princ "\n")
- (semantic-analyzer-debug-show-completions comp)
-
- (princ "\nKnown members of ")
- (princ (semantic-tag-name dt))
- (princ ":\n")
- (dolist (M (semantic-tag-type-members dt))
- (princ " ")
- ;;(princ (semantic-format-tag-prototype M))
- (semantic-analyzer-debug-insert-tag M)
- (princ "\n"))
-
- ;; This doesn't refer to in-type completions.
- ;;(semantic-analyzer-debug-global-miss-text prefixitem)
-
- ;; More explanation
- (when desired-type
- (princ "\nWhen there are known members that would make good completion
-candidates that are not in the completion list, then the most likely
-cause is a type constraint. Semantic has determined that there is a
-type constraint looking for the type ")
- (if (semantic-tag-p desired-type)
- (semantic-analyzer-debug-insert-tag desired-type)
- (princ (format "%S" desired-type)))
- (princ "."))
- ))
- (semantic-analyzer-debug-add-buttons)
-
- ))
-
-
-(defun semantic-analyzer-debug-test-local-context ()
- "Test the local context parsed from the file."
- (let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point)))
- (prefix (car prefixandbounds))
- (bounds (nth 2 prefixandbounds))
- )
- (when (and (or (not prefixandbounds)
- (not prefix)
- (not bounds))
- )
- (with-output-to-temp-buffer (help-buffer)
- (with-current-buffer standard-output
- (princ "Local Context Parser Failed.
-
-If this is unexpected, then there is likely a bug in the Semantic
-local context parser.
-
-Consider debugging the function ")
- (let ((lcf (fetch-overload 'semantic-ctxt-current-symbol-and-bounds)))
- (if lcf
- (princ (symbol-name lcf))
- (princ "semantic-ctxt-current-symbol-and-bounds,
-or implementing a version specific to ")
- (princ (symbol-name major-mode))
- )
- (princ ".\n"))
- (semantic-analyzer-debug-add-buttons)
- t)))
- ))
-
-;;; General Inserters with help
-;;
-(defun semantic-analyzer-debug-show-completions (comp)
- "Show the completion list COMP."
- (if (not comp)
- (princ "\nNo known possible completions.\n")
-
- (princ "\nPossible completions are:\n")
- (dolist (C comp)
- (princ " ")
- (cond ((stringp C)
- (princ C)
- )
- ((semantic-tag-p C)
- (semantic-analyzer-debug-insert-tag C)))
- (princ "\n"))
- (princ "\n")))
-
-(defvar semantic-dependency-system-include-path)
-
-(defun semantic-analyzer-debug-insert-include-summary (table)
- "Display a summary of includes for the semanticdb TABLE."
- (require 'semantic/dep)
- (semantic-fetch-tags)
- (let ((inc (semantic-find-tags-by-class 'include table))
- ;;(path (semanticdb-find-test-translate-path-no-loading))
- (unk
- (with-current-buffer (semanticdb-get-buffer table)
- semanticdb-find-lost-includes))
- (ip
- (with-current-buffer (semanticdb-get-buffer table)
- semantic-dependency-system-include-path))
- (edeobj
- (with-current-buffer (semanticdb-get-buffer table)
- (and (boundp 'ede-object)
- ede-object)))
- (edeproj
- (with-current-buffer (semanticdb-get-buffer table)
- (and (boundp 'ede-object-project)
- ede-object-project))))
-
- (princ "\n\nInclude Path Summary:")
- (when edeobj
- (princ (substitute-command-keys
- "\n\nThis file's project include search is handled by the EDE object:\n"))
- (princ " Buffer Target: ")
- (princ (cl-prin1-to-string edeobj))
- (princ "\n")
- (when (not (eq edeobj edeproj))
- (princ " Buffer Project: ")
- (princ (cl-prin1-to-string edeproj))
- (princ "\n"))
- (when edeproj
- (let ((loc (ede-get-locator-object edeproj)))
- (princ " Backup Locator: ")
- (princ (cl-prin1-to-string loc))
- (princ "\n")))
- )
-
- (princ "\n\nThe system include path is:\n")
- (dolist (dir ip)
- (princ " ")
- (princ dir)
- (princ "\n"))
-
- (princ "\n\nInclude Summary: ")
- (princ (semanticdb-full-filename table))
- (princ "\n\n")
- (princ (format "%s contains %d includes.\n"
- (file-name-nondirectory
- (semanticdb-full-filename table))
- (length inc)))
- (let ((ok 0)
- (unknown 0)
- (unparsed 0)
- (all 0))
- (dolist (i inc)
- (let* ((fileinner (semantic-dependency-tag-file i))
- (tableinner (when fileinner
- (semanticdb-file-table-object fileinner t))))
- (cond ((not fileinner)
- (setq unknown (1+ unknown)))
- ((and tableinner (number-or-marker-p (oref tableinner pointmax)))
- (setq ok (1+ ok)))
- (t
- (setq unparsed (1+ unparsed))))))
- (setq all (+ ok unknown unparsed))
- (when (not (= 0 all))
- (princ (format " Unknown Includes: %d\n" unknown))
- (princ (format " Unparsed Includes: %d\n" unparsed))
- (princ (format " Parsed Includes: %d\n" ok)))
- )
-
- ;; Unknowns...
- (if unk
- (progn
- (princ "\nA likely cause of an unfound tag is missing include files.")
- (semantic-analyzer-debug-insert-tag-list
- "The following includes were not found" unk)
-
- (princ "\nYou can fix the include path for ")
- (princ (symbol-name (oref table major-mode)))
- (princ (substitute-command-keys " by using this function:
-
-\\[semantic-customize-system-include-path]
-
-which customizes the mode specific variable for the mode-local
-variable `semantic-dependency-system-include-path'."))
- )
-
- (princ "\n No unknown includes.\n"))
- ))
-
-(defun semantic-analyzer-debug-describe-scope (ctxt &optional classconstraint)
- "Describe the scope in CTXT for finding a global symbol.
-Optional argument CLASSCONSTRAINT says to output to tags of that class."
- (let* ((scope (oref ctxt scope))
- (parents (oref scope parents))
- (cc (or classconstraint (oref ctxt prefixclass)))
- )
- (princ "\nLocal Scope Information:")
- (princ "\n * Tag Class Constraint against SCOPE: ")
- (princ (format "%S" classconstraint))
-
- (if parents
- (semantic-analyzer-debug-insert-tag-list
- " >> Known parent types with possible in scope symbols"
- parents)
- (princ "\n * No known parents in current scope."))
-
- (let ((si (semantic-analyze-tags-of-class-list
- (oref scope scope) cc))
- (lv (semantic-analyze-tags-of-class-list
- (oref scope localvar) cc))
- )
- (if si
- (semantic-analyzer-debug-insert-tag-list
- " >> Known symbols within the current scope"
- si)
- (princ "\n * No known symbols currently in scope."))
-
- (if lv
- (semantic-analyzer-debug-insert-tag-list
- " >> Known symbols that are declared locally"
- lv)
- (princ "\n * No known symbols declared locally."))
- )
- )
- )
-
-(defun semantic-analyzer-debug-global-miss-text (name-in)
- "Use `princ' to show text describing not finding symbol NAME-IN.
-NAME is the name of the unfound symbol."
- (let ((name (cond ((stringp name-in)
- name-in)
- ((semantic-tag-p name-in)
- (semantic-format-tag-name name-in))
- (t (format "%S" name-in)))))
- (when (not (string= name ""))
- (princ "\nIf ")
- (princ name)
- (princ " is a local variable, argument, or symbol in some
-namespace or class exposed via scoping statements, then it should
-appear in the scope.
-
-Debugging the scope can be done with:
- M-x semantic-calculate-scope RET
-
-If the prefix is a global symbol, in an included file, then
-your search path may be incomplete.
-"))))
-
-;;; Utils
-;;
-(defun semantic-analyzer-debug-insert-tag-list (text taglist)
- "Prefixing with TEXT, dump TAGLIST in a help buffer."
- (princ "\n") (princ text) (princ ":\n")
-
- (dolist (M taglist)
- (princ " ")
- ;;(princ (semantic-format-tag-prototype M))
- (semantic-analyzer-debug-insert-tag M)
- (princ "\n"))
- )
-
-(defun semantic-analyzer-debug-insert-tag (tag &optional parent)
- "Display a TAG by name, with possible jumpitude.
-PARENT is a possible parent (by nesting) tag."
- (let ((str (semantic-format-tag-prototype tag parent)))
- (if (and (semantic-tag-with-position-p tag)
- (semantic-tag-file-name tag))
- (with-current-buffer standard-output
- (insert-button str
- 'mouse-face 'custom-button-pressed-face
- 'tag tag
- 'action
- (lambda (button)
- (let ((buff nil)
- (pnt nil))
- (save-excursion
- (semantic-go-to-tag
- (button-get button 'tag))
- (setq buff (current-buffer))
- (setq pnt (point)))
- (if (get-buffer-window buff)
- (select-window (get-buffer-window buff))
- (pop-to-buffer buff t))
- (goto-char pnt)
- (pulse-line-hook-function)))
- ))
- (princ "\"")
- (princ str)
- (princ "\""))
- ))
-
-(defvar semantic-analyzer-debug-orig nil
- "The originating buffer for a help button.")
-
-(defun semantic-analyzer-debug-add-buttons ()
- "Add push-buttons to the *Help* buffer.
-Look for key expressions, and add push-buttons near them."
- (let ((orig-buffer (make-marker)))
- (set-marker orig-buffer (point) (current-buffer))
- ;; Get a buffer ready.
- (with-current-buffer "*Help*"
- (let ((inhibit-read-only t))
- (goto-char (point-min))
- (setq-local semantic-analyzer-debug-orig orig-buffer)
- ;; First, add do-in buttons to recommendations.
- (while (re-search-forward "^\\s-*M-x \\(\\(\\w\\|\\s_\\)+\\) " nil t)
- (let* ((fcn (match-string 1))
- (fsym (intern-soft fcn)))
- (when (not (fboundp fsym))
- (error "Help Err: Can't find %s" fcn))
- (end-of-line)
- (insert " ")
- (insert-button "[ Do It ]"
- 'mouse-face 'custom-button-pressed-face
- 'do-fcn fcn
- 'action (lambda (_arg)
- (let ((M semantic-analyzer-debug-orig))
- (set-buffer (marker-buffer M))
- (goto-char M))
- (call-interactively fsym))))))
- ;; Do something else?
- ;; Clean up the mess
- (set-buffer-modified-p nil))))
-
-(provide 'semantic/analyze/debug)
-
-;;; semantic/analyze/debug.el ends here
+++ /dev/null
-;;; semantic/analyze/fcn.el --- Analyzer support functions. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Analyzer support functions.
-
-;;; Code:
-
-(require 'semantic)
-(eval-when-compile (require 'semantic/find))
-
-(declare-function semanticdb-typecache-merge-streams "semantic/db-typecache")
-(declare-function semantic-scope-find "semantic/scope")
-(declare-function semantic-scope-set-typecache "semantic/scope")
-(declare-function semantic-scope-tag-get-scope "semantic/scope")
-
-;;; Small Mode Specific Options
-;;
-;; These queries allow a major mode to help the analyzer make decisions.
-;;
-
-(define-overloadable-function semantic-analyze-split-name (name)
- "Split a tag NAME into a sequence.
-Sometimes NAMES are gathered from the parser that are compounded,
-such as in C++ where foo::bar means:
- \"The class BAR in the namespace FOO.\"
-Return the string NAME for no change, or a list if it needs to be split.")
-
-(defun semantic-analyze-split-name-default (name)
- "Don't split up NAME by default."
- name)
-
-(define-overloadable-function semantic-analyze-unsplit-name (namelist)
- "Assemble a NAMELIST into a string representing a compound name.
-Return the string representing the compound name.")
-
-(defun semantic-analyze-unsplit-name-default (namelist)
- "Concatenate the names in NAMELIST with a . between."
- (mapconcat #'identity namelist "."))
-
-;;; SELECTING
-;;
-;; If you narrow things down to a list of tags that all mean
-;; the same thing, how to you pick one? Select or merge.
-;;
-
-(defun semantic-analyze-select-best-tag (sequence &optional tagclass)
- "For a SEQUENCE of tags, all with good names, pick the best one.
-If SEQUENCE is made up of namespaces, merge the namespaces together.
-If SEQUENCE has several prototypes, find the non-prototype.
-If SEQUENCE has some items with no type information, find the one with a type.
-If SEQUENCE is all prototypes, or has no prototypes, get the first one.
-Optional TAGCLASS indicates to restrict the return to only
-tags of TAGCLASS."
-
- ;; If there is a screw up and we get just one tag.. massage over it.
- (when (semantic-tag-p sequence)
- (setq sequence (list sequence)))
-
- ;; Filter out anything not of TAGCLASS
- (when tagclass
- (setq sequence (semantic-find-tags-by-class tagclass sequence)))
-
- (if (< (length sequence) 2)
- ;; If the remaining sequence is 1 tag or less, just return it
- ;; and skip the rest of this mumbo-jumbo.
- (car sequence)
-
- ;; 1)
- ;; This step will eliminate a vast majority of the types,
- ;; in addition to merging namespaces together.
- ;;
- ;; 2)
- ;; It will also remove prototypes.
- (require 'semantic/db-typecache)
- (setq sequence (semanticdb-typecache-merge-streams sequence nil))
-
- (if (< (length sequence) 2)
- ;; If the remaining sequence after the merge is 1 tag or less,
- ;; just return it and skip the rest of this mumbo-jumbo.
- (car sequence)
-
- (let ((best nil)
- (notypeinfo nil)
- )
- (while (and (not best) sequence)
-
- ;; 3) select a non-prototype.
- (if (not (semantic-tag-type (car sequence)))
- (setq notypeinfo (car sequence))
-
- (setq best (car sequence))
- )
-
- (setq sequence (cdr sequence)))
-
- ;; Select the best, or at least the prototype.
- (or best notypeinfo)))))
-
-;;; Tag Finding
-;;
-;; Mechanism for lookup up tags by name.
-;;
-(defun semantic-analyze-find-tags-by-prefix (prefix)
- ;; @todo - only used in semantic-complete. Find something better?
- "Attempt to find a tag with PREFIX.
-This is a wrapper on top of semanticdb, and semantic search functions.
-Almost all searches use the same arguments."
- (if (and (fboundp 'semanticdb-minor-mode-p)
- (semanticdb-minor-mode-p))
- ;; Search the database & concatenate all matches together.
- (semanticdb-strip-find-results
- (semanticdb-find-tags-for-completion prefix)
- 'name)
- ;; Search just this file because there is no DB available.
- (semantic-find-tags-for-completion
- prefix (current-buffer))))
-
-;;; Finding Datatypes
-;;
-
-(define-overloadable-function semantic-analyze-dereference-metatype (type scope &optional type-declaration)
- ;; todo - move into typecache!!
- "Return a concrete type tag based on input TYPE tag.
-A concrete type is an actual declaration of a memory description,
-such as a structure, or class. A meta type is an alias,
-or a typedef in C or C++. If TYPE is concrete, it
-is returned. If it is a meta type, it will return the concrete
-type defined by TYPE.
-The default behavior always returns TYPE.
-Override functions need not return a real semantic tag.
-Just a name, or short tag will be ok. It will be expanded here.
-SCOPE is the scope object with additional items in which to search for names."
- (catch 'default-behavior
- (let* ((ans-tuple (:override
- ;; Nothing fancy, just return type by default.
- (throw 'default-behavior (list type type-declaration))))
- (ans-type (car ans-tuple))
- (ans-type-declaration (cadr ans-tuple)))
- (list (semantic-analyze-dereference-metatype-1 ans-type scope) ans-type-declaration))))
-
-;; Finding a data type by name within a project.
-;;
-(defun semantic-analyze-type-to-name (type)
- "Get the name of TAG's type.
-The TYPE field in a tag can be nil (return nil)
-or a string, or a non-positional tag."
- (cond ((semantic-tag-p type)
- (if (semantic-tag-named-parent type)
- (semantic-analyze-unsplit-name `(,(semantic-tag-named-parent type)
- ,(semantic-tag-name type)))
- (semantic-tag-name type)))
- ((stringp type)
- type)
- ((listp type)
- (car type))
- (t nil)))
-
-(defun semantic-analyze-tag-type (tag &optional scope nometaderef)
- "Return the semantic tag for a type within the type of TAG.
-TAG can be a variable, function or other type of tag.
-The behavior of TAG's type is defined by `semantic-analyze-type'.
-Optional SCOPE represents a calculated scope in which the
-types might be found. This can be nil.
-If NOMETADEREF, then do not dereference metatypes. This is
-used by the analyzer debugger."
- (semantic-analyze-type (semantic-tag-type tag) scope nometaderef))
-
-(defun semantic-analyze-type (type-declaration &optional scope nometaderef)
- "Return the semantic tag for TYPE-DECLARATION.
-TAG can be a variable, function or other type of tag.
-The type of tag (such as a class or struct) is a name.
-Lookup this name in database, and return all slots/fields
-within that types field. Also handles anonymous types.
-Optional SCOPE represents a calculated scope in which the
-types might be found. This can be nil.
-If NOMETADEREF, then do not dereference metatypes. This is
-used by the analyzer debugger."
- (require 'semantic/scope)
- (let ((name nil)
- (typetag nil)
- )
-
- ;; Is it an anonymous type?
- (if (and type-declaration
- (semantic-tag-p type-declaration)
- (semantic-tag-of-class-p type-declaration 'type)
- (not (semantic-tag-prototype-p type-declaration))
- )
- ;; We have an anonymous type for TAG with children.
- ;; Use this type directly.
- (if nometaderef
- type-declaration
- (semantic-analyze-dereference-metatype-stack
- type-declaration scope type-declaration))
-
- ;; Not an anonymous type. Look up the name of this type
- ;; elsewhere, and report back.
- (setq name (semantic-analyze-type-to-name type-declaration))
-
- (if (and name (not (string= name "")))
- (progn
- ;; Find a type of that name in scope.
- (setq typetag (and scope (semantic-scope-find name 'type scope)))
- ;; If no typetag, try the typecache
- (when (not typetag)
- (setq typetag (semanticdb-typecache-find name))))
-
- ;; No name to look stuff up with.
- (error "Semantic tag %S has no type information"
- (semantic-tag-name type-declaration)))
-
- ;; Handle lists of tags.
- (when (and (consp typetag) (semantic-tag-p (car typetag)))
- (setq typetag (semantic-analyze-select-best-tag typetag 'type))
- )
-
- ;; We now have a tag associated with the type. We need to deref it.
- ;;
- ;; If we were asked not to (ie - debugger) push the typecache anyway.
- (if nometaderef
- typetag
- (unwind-protect
- (progn
- (semantic-scope-set-typecache
- scope (semantic-scope-tag-get-scope typetag))
- (semantic-analyze-dereference-metatype-stack typetag scope type-declaration)
- )
- (semantic-scope-set-typecache scope nil)
- )))))
-
-(autoload 'semantic-tag-similar-p "semantic/tag-ls")
-
-(defun semantic-analyze-dereference-metatype-stack (type scope &optional type-declaration)
- "Dereference metatypes repeatedly until we hit a real TYPE.
-Uses `semantic-analyze-dereference-metatype'.
-Argument SCOPE is the scope object with additional items in which to search.
-Optional argument TYPE-DECLARATION is how TYPE was found referenced."
- (let ((lasttype type)
- (lasttypedeclaration type-declaration)
- (nexttype (semantic-analyze-dereference-metatype type scope type-declaration))
- (idx 0))
- (catch 'metatype-recursion
- (while (and nexttype (not (semantic-tag-similar-p (car nexttype) lasttype)))
- (setq lasttype (car nexttype)
- lasttypedeclaration (cadr nexttype))
- (setq nexttype (semantic-analyze-dereference-metatype lasttype scope lasttypedeclaration))
- (setq idx (1+ idx))
- (when (> idx 20) (message "Possible metatype recursion for %S"
- (semantic-tag-name lasttype))
- (throw 'metatype-recursion nil))
- ))
- lasttype))
-
-;; @ TODO - the typecache can also return a stack of scope names.
-
-(defun semantic-analyze-dereference-metatype-1 (ans scope)
- "Do extra work after dereferencing a metatype.
-ANS is the answer from the language specific query.
-SCOPE is the current scope."
- (require 'semantic/scope)
- ;; If ANS is a string, or if ANS is a short tag, we
- ;; need to do some more work to look it up.
- (if (stringp ans)
- ;; The metatype is just a string... look it up.
- (or (and scope (car-safe
- ;; @todo - should this be `find the best one'?
- (semantic-scope-find ans 'type scope)))
- (let ((tcsans nil))
- (prog1
- (setq tcsans
- (semanticdb-typecache-find ans))
- ;; While going through the metatype, if we have
- ;; a scope, push our new cache in.
- (when scope
- (semantic-scope-set-typecache
- scope (semantic-scope-tag-get-scope tcsans))
- ))
- ))
- (when (and (semantic-tag-p ans)
- (eq (semantic-tag-class ans) 'type))
- ;; We have a tag.
- (if (semantic-tag-prototype-p ans)
- ;; It is a prototype.. find the real one.
- (or (and scope
- (car-safe
- (semantic-scope-find (semantic-tag-name ans)
- 'type scope)))
- (let ((tcsans nil))
- (prog1
- (setq tcsans
- (semanticdb-typecache-find (semantic-tag-name ans)))
- ;; While going through the metatype, if we have
- ;; a scope, push our new cache in.
- (when scope
- (semantic-scope-set-typecache
- scope (semantic-scope-tag-get-scope tcsans))
- ))))
- ;; We have a tag, and it is not a prototype.
- ans))
- ))
-
-(provide 'semantic/analyze/fcn)
-
-;;; semantic/analyze/fcn.el ends here
+++ /dev/null
-;;; semantic/analyze/refs.el --- Analysis of the references between tags. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Analyze the references between tags.
-;;
-;; The original purpose of these analysis is to provide a way to jump
-;; between a prototype and implementation.
-;;
-;; Finding all prototype/impl matches is hard because you have to search
-;; through the entire set of allowed databases to capture all possible
-;; refs. The core analysis class stores basic starting point, and then
-;; entire raw search data, which is expensive to calculate.
-;;
-;; Once the raw data is available, queries for impl, prototype, or
-;; perhaps other things become cheap.
-
-(require 'semantic)
-(require 'semantic/analyze)
-(require 'semantic/db-find)
-(eval-when-compile (require 'semantic/find))
-
-(declare-function data-debug-new-buffer "data-debug")
-(declare-function data-debug-insert-object-slots "eieio-datadebug")
-(declare-function semantic-momentary-highlight-tag "semantic/decorate")
-
-;;; Code:
-(defclass semantic-analyze-references ()
- ((tag :initarg :tag
- :type semantic-tag
- :documentation
- "The starting TAG we are providing references analysis for.")
- (tagdb :initarg :tagdb
- :documentation
- "The database that tag can be found in.")
- (scope :initarg :scope
- :documentation "A Scope object.")
- (rawsearchdata :initarg :rawsearchdata
- :documentation
- "The raw search data for TAG's name across all databases.")
- ;; Note: Should I cache queried data here? I expect that searching
- ;; through rawsearchdata will be super-fast, so why bother?
- )
- "Class containing data from a semantic analysis.")
-
-(define-overloadable-function semantic-analyze-tag-references (tag &optional db)
- "Analyze the references for TAG.
-Returns a class with information about TAG.
-
-Optional argument DB is a database. It will be used to help
-locate TAG.
-
-Use `semantic-analyze-current-tag' to debug this fcn.")
-
-(defun semantic-analyze-tag-references-default (tag &optional db)
- "Analyze the references for TAG.
-Returns a class with information about TAG.
-
-Optional argument DB is a database. It will be used to help
-locate TAG.
-
-Use `semantic-analyze-current-tag' to debug this fcn."
- (when (not (semantic-tag-p tag)) (signal 'wrong-type-argument (list 'semantic-tag-p tag)))
- (let ((allhits nil)
- (scope nil)
- )
- (save-excursion
- (semantic-go-to-tag tag db)
- (setq scope (semantic-calculate-scope))
-
- (setq allhits (semantic--analyze-refs-full-lookup tag scope t))
-
- (semantic-analyze-references (semantic-tag-name tag)
- :tag tag
- :tagdb db
- :scope scope
- :rawsearchdata allhits)
- )))
-
-;;; METHODS
-;;
-;; These accessor methods will calculate the useful bits from the context, and cache values
-;; into the context.
-(cl-defmethod semantic-analyze-refs-impl ((refs semantic-analyze-references) &optional in-buffer)
- "Return the implementations derived in the reference analyzer REFS.
-Optional argument IN-BUFFER indicates that the returned tag
-should be in an active buffer."
- (let ((allhits (oref refs rawsearchdata))
- (tag (oref refs tag))
- (impl nil)
- )
- (semanticdb-find-result-mapc
- (lambda (T DB)
- "Examine T in the database DB, and sort it."
- (let* ((ans (semanticdb-normalize-one-tag DB T))
- (aT (cdr ans))
- (aDB (car ans))
- )
- (when (and (not (semantic-tag-prototype-p aT))
- (semantic-tag-similar-p tag aT
- :prototype-flag
- :parent
- :typemodifiers
- :default-value))
- (when in-buffer (save-excursion (semantic-go-to-tag aT aDB)))
- (push aT impl))))
- allhits)
- impl))
-
-(cl-defmethod semantic-analyze-refs-proto ((refs semantic-analyze-references) &optional in-buffer)
- "Return the prototypes derived in the reference analyzer REFS.
-Optional argument IN-BUFFER indicates that the returned tag
-should be in an active buffer."
- (let ((allhits (oref refs rawsearchdata))
- (tag (oref refs tag))
- (proto nil))
- (semanticdb-find-result-mapc
- (lambda (T DB)
- "Examine T in the database DB, and sort it."
- (let* ((ans (semanticdb-normalize-one-tag DB T))
- (aT (cdr ans))
- (aDB (car ans))
- )
- (when (and (semantic-tag-prototype-p aT)
- (semantic-tag-similar-p tag aT
- :prototype-flag
- :parent
- :typemodifiers
- :default-value))
- (when in-buffer (save-excursion (semantic-go-to-tag aT aDB)))
- (push aT proto))))
- allhits)
- proto))
-
-;;; LOOKUP
-;;
-(defun semantic--analyze-refs-full-lookup (tag scope &optional noerror)
- "Perform a full lookup for all occurrences of TAG in the current project.
-TAG should be the tag currently under point.
-SCOPE is the scope the cursor is in. From this a list of parents is
-derived. If SCOPE does not have parents, then only a simple lookup is done.
-Optional argument NOERROR means don't error if the lookup fails."
- (if (not (oref scope parents))
- ;; If this tag has some named parent, but is not
- (semantic--analyze-refs-full-lookup-simple tag noerror)
-
- ;; We have some sort of lineage we need to consider when we do
- ;; our side lookup of tags.
- (semantic--analyze-refs-full-lookup-with-parents tag scope)
- ))
-
-(defun semantic--analyze-refs-find-child-in-find-results (find-results name class)
- "Find in FIND-RESULT a tag NAME which is a child of a tag in FIND-RESULTS.
-CLASS is the class of the tag that ought to be returned."
- (let ((ans nil)
- (subans nil))
- ;; Loop over each segment of the find results.
- (dolist (FDB find-results)
- (setq subans nil)
- ;; Loop over each tag in the find results.
- (dolist (T (cdr FDB))
- ;; For each tag, get the children.
- (let* ((chil (semantic-tag-type-members T))
- (match (semantic-find-tags-by-name name chil)))
- ;; Go over the matches, looking for matching tag class.
- (dolist (M match)
- (when (semantic-tag-of-class-p M class)
- (push M subans)))))
- ;; Store current matches into a new find results.
- (when subans
- (push (cons (car FDB) subans) ans))
- )
- ans))
-
-(defun semantic--analyze-refs-find-tags-with-parent (find-results parents)
- "Find in FIND-RESULTS all tags with PARENTS.
-NAME is the name of the tag needing finding.
-PARENTS is a list of names."
- (let ((ans nil) (usingnames nil))
- ;; Loop over the find-results passed in.
- (semanticdb-find-result-mapc
- (lambda (tag db)
- (let* ((p (semantic-tag-named-parent tag))
- (ps (when (stringp p) (semantic-analyze-split-name p))))
- (when (stringp ps) (setq ps (list ps)))
- (when ps
- ;; If there is a perfect match, then use it.
- (if (equal ps parents)
- (push (list db tag) ans))
- ;; No match, find something from our list of using names.
- ;; Do we need to split UN?
- (save-excursion
- (semantic-go-to-tag tag db)
- (setq usingnames nil)
- (let ((imports (semantic-ctxt-imported-packages)))
- ;; Derive the names from all the using statements.
- (mapc (lambda (T)
- (setq usingnames
- (cons (semantic-format-tag-name-from-anything T) usingnames)))
- imports))
- (dolist (UN usingnames)
- (when (equal (cons UN ps) parents)
- (push (list db tag) ans)
- (setq usingnames (cdr usingnames))))
- ))))
- find-results)
- ans))
-
-(defun semantic--analyze-refs-full-lookup-with-parents (tag scope)
- "Perform a lookup for all occurrences of TAG based on TAG's SCOPE.
-TAG should be the tag currently under point."
- (let* ((classmatch (semantic-tag-class tag))
- (plist (mapcar (lambda (T) (semantic-tag-name T)) (oref scope parents)))
- ;; The first item in the parent list
- (name (car plist))
- ;; Stuff from the simple list.
- (simple (semantic--analyze-refs-full-lookup-simple tag t))
- ;; Find all hits for the first parent name.
- (brute (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-by-name-method table name tags)
- )
- nil nil t))
- ;; Prime the answer.
- (answer (semantic--analyze-refs-find-tags-with-parent simple plist))
- )
- ;; First parent is already search to initialize "brute".
- (setq plist (cdr plist))
-
- ;; Go through the list of parents, and try to find matches.
- ;; As we cycle through plist, for each level look for NAME,
- ;; and compare the named-parent, and also dive into the next item of
- ;; plist.
- (while (and plist brute)
-
- ;; Find direct matches
- (let* ((direct (semantic--analyze-refs-find-child-in-find-results
- brute (semantic-tag-name tag) classmatch))
- (pdirect (semantic--analyze-refs-find-tags-with-parent
- direct plist)))
- (setq answer (append pdirect answer)))
-
- ;; The next set of search items.
- (setq brute (semantic--analyze-refs-find-child-in-find-results
- brute (car plist) 'type))
-
- (setq plist (cdr plist)))
-
- ;; Brute now has the children from the very last match.
- (let* ((direct (semantic--analyze-refs-find-child-in-find-results
- brute (semantic-tag-name tag) classmatch))
- )
- (setq answer (append direct answer)))
-
- answer))
-
-(defun semantic--analyze-refs-full-lookup-simple (tag &optional noerror)
- "Perform a simple lookup for occurrences of TAG in the current project.
-TAG should be the tag currently under point.
-Optional NOERROR means don't throw errors on failure to find something.
-This only compares the tag name, and does not infer any matches in namespaces,
-or parts of some other data structure.
-Only works for tags in the global namespace."
- (let* ((name (semantic-tag-name tag))
- (brute (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-by-name-method table name tags)
- )
- nil ;; This may need to be the entire project??
- nil t))
- )
-
- (when (and (not brute) (not noerror))
- ;; An error, because tag under point ought to be found.
- (error "Cannot find any references to %s in wide search" name))
-
- (let* ((classmatch (semantic-tag-class tag))
- (RES
- (semanticdb-find-tags-collector
- (lambda (_table tags)
- (semantic-find-tags-by-class classmatch tags)
- ;; @todo - Add parent check also.
- )
- brute nil)))
-
- (when (and (not RES) (not noerror))
- (error "Cannot find any definitions for %s in wide search"
- (semantic-tag-name tag)))
-
- ;; Return the matching tags and databases.
- RES)))
-
-
-;;; USER COMMANDS
-;;
-;;;###autoload
-(defun semantic-analyze-current-tag ()
- "Analyze the tag under point."
- (interactive)
- (let* ((tag (semantic-current-tag))
- (start (current-time))
- (sac (semantic-analyze-tag-references tag))
- )
- (message "Analysis took %.2f seconds." (semantic-elapsed-time start nil))
- (if sac
- (progn
- (require 'eieio-datadebug)
- (data-debug-new-buffer "*Analyzer Reference ADEBUG*")
- (data-debug-insert-object-slots sac "]"))
- (message "No Context to analyze here."))))
-
-;;;###autoload
-(defun semantic-analyze-proto-impl-toggle ()
- "Toggle between the implementation, and a prototype of tag under point."
- (interactive)
- (require 'semantic/decorate)
- (semantic-fetch-tags)
- (let* ((tag (semantic-current-tag))
- (sar (if tag
- (semantic-analyze-tag-references tag)
- (error "Point must be in a declaration")))
- (target (if (semantic-tag-prototype-p tag)
- (car (semantic-analyze-refs-impl sar t))
- (car (semantic-analyze-refs-proto sar t))))
- )
-
- (when (not target)
- (error "Could not find suitable %s"
- (if (semantic-tag-prototype-p tag) "implementation" "prototype")))
-
- (push-mark)
- (when (fboundp 'xref-push-marker-stack)
- (xref-push-marker-stack))
- (semantic-go-to-tag target)
- (pop-to-buffer-same-window (current-buffer))
- (semantic-momentary-highlight-tag target))
- )
-
-(provide 'semantic/analyze/refs)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/analyze/refs"
-;; End:
-
-;;; semantic/analyze/refs.el ends here
+++ /dev/null
-;;; semantic/bovine.el --- LL Parser/Analyzer core -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2004, 2006-2007, 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic 1.x uses an LL parser named the "bovinator". This parser
-;; had several conveniences in it which made for parsing tags out of
-;; languages with list characters easy. This parser lives on as one
-;; of many available parsers for semantic the tool.
-;;
-;; This parser should be used when the language is simple, such as
-;; makefiles or other data-declarative languages.
-
-;;; Code:
-(require 'semantic)
-
-(declare-function semantic-create-bovine-debug-error-frame
- "semantic/bovine/debug")
-(declare-function semantic-bovine-debug-create-frame
- "semantic/bovine/debug")
-(declare-function semantic-debug-break "semantic/debug")
-
-;;; Variables
-;;
-(defvar-local semantic-bovinate-nonterminal-check-map nil
- "Obarray of streams already parsed for nonterminal symbols.
-Use this to detect infinite recursion during a parse.")
-
-
-\f
-;; These are functions that can be called from within a bovine table.
-;; Most of these have code auto-generated from other construct in the
-;; bovine input grammar.
-(defmacro semantic-lambda (&rest return-val)
- "Create a lambda expression to return a list including RETURN-VAL.
-The return list is a lambda expression to be used in a bovine table."
- `(lambda (vals start end)
- (ignore vals)
- (append ,@return-val (list start end))))
-
-;;; Semantic Bovination
-;;
-;; Take a semantic token stream, and convert it using the bovinator.
-;; The bovinator takes a state table, and converts the token stream
-;; into a new semantic stream defined by the bovination table.
-;;
-(defsubst semantic-bovinate-symbol-nonterminal-p (sym table)
- "Return non-nil if SYM is in TABLE, indicating it is NONTERMINAL."
- ;; sym is always a sym, so assq should be ok.
- (if (assq sym table) t nil))
-
-(defmacro semantic-bovinate-nonterminal-db-nt ()
- "Return the current nonterminal symbol.
-Part of the grammar source debugger. Depends on the existing
-environment of `semantic-bovinate-stream'."
- '(if nt-stack
- (car (aref (car nt-stack) 2))
- nonterminal))
-
-(defun semantic-bovinate-nonterminal-check (stream nonterminal)
- "Check if STREAM not already parsed for NONTERMINAL.
-If so abort because an infinite recursive parse is suspected."
- (or (hash-table-p semantic-bovinate-nonterminal-check-map)
- (setq semantic-bovinate-nonterminal-check-map
- (make-hash-table :test #'eq)))
- (let* ((vs (gethash nonterminal semantic-bovinate-nonterminal-check-map)))
- (if (memq stream vs)
- ;; Always enter debugger to see the backtrace
- (let ((debug-on-signal t)
- (debug-on-error t))
- (setq semantic-bovinate-nonterminal-check-map nil)
- (error "Infinite recursive parse suspected on %s" nonterminal))
- (push stream
- (gethash nonterminal semantic-bovinate-nonterminal-check-map)))))
-
-;;;###autoload
-(defun semantic-bovinate-stream (stream &optional nonterminal)
- "Bovinate STREAM, starting at the first NONTERMINAL rule.
-Use `bovine-toplevel' if NONTERMINAL is not provided.
-This is the core routine for converting a stream into a table.
-Return the list (STREAM SEMANTIC-STREAM) where STREAM are those
-elements of STREAM that have not been used. SEMANTIC-STREAM is the
-list of semantic tokens found."
- (if (not nonterminal)
- (setq nonterminal 'bovine-toplevel))
-
- ;; Try to detect infinite recursive parse when doing a full reparse.
- (or semantic--buffer-cache
- (semantic-bovinate-nonterminal-check stream nonterminal))
-
- ;; FIXME: `semantic-parse-region-c-mode' inspects `lse' to try and
- ;; detect a recursive call (used with macroexpansion, to avoid inf-loops).
- (with-suppressed-warnings ((lexical lse)) (defvar lse))
- (let* ((table semantic--parse-table)
- (matchlist (cdr (assq nonterminal table)))
- (starting-stream stream)
- (nt-loop t) ;non-terminal loop condition
- nt-popup ;non-nil if return from nt recursion
- nt-stack ;non-terminal recursion stack
- s ;Temp Stream Tracker
- lse ;Local Semantic Element
- lte ;Local matchlist element
- tev ;Matchlist entry values from buffer
- val ;Value found in buffer.
- cvl ;collected values list.
- out ;Output
- end ;End of match
- result
- )
- (condition-case debug-condition
- (while nt-loop
- (catch 'push-non-terminal
- (setq nt-popup nil
- end (semantic-lex-token-end (car stream)))
- (while (or nt-loop nt-popup)
- (setq nt-loop nil
- out nil)
- (while (or nt-popup matchlist)
- (if nt-popup
- ;; End of a non-terminal recursion
- (setq nt-popup nil)
- ;; New matching process
- (setq s stream ;init s from stream.
- cvl nil ;re-init the collected value list.
- lte (car matchlist) ;Get the local matchlist entry.
- )
- (if (or (compiled-function-p (car lte))
- (listp (car lte)))
- ;; In this case, we have an EMPTY match! Make
- ;; stuff up.
- (setq cvl (list nil))))
-
- (while (and lte
- (not (compiled-function-p (car lte)))
- (not (listp (car lte))))
-
- ;; GRAMMAR SOURCE DEBUGGING!
- (if (and (boundp 'semantic-debug-enabled)
- semantic-debug-enabled)
- (let* ((db-nt (semantic-bovinate-nonterminal-db-nt))
- (db-ml (cdr (assq db-nt table)))
- (db-mlen (length db-ml))
- (db-midx (- db-mlen (length matchlist)))
- (db-tlen (length (nth db-midx db-ml)))
- (db-tidx (- db-tlen (length lte)))
- (frame (progn
- (require 'semantic/bovine/debug)
- (semantic-bovine-debug-create-frame
- db-nt db-midx db-tidx cvl (car s))))
- (cmd (semantic-debug-break frame))
- )
- (cond ((eq 'fail cmd) (setq lte '(trash 0 . 0)))
- ((eq 'quit cmd) (signal 'quit "Abort"))
- ((eq 'abort cmd) (error "Abort"))
- ;; support more commands here.
-
- )))
- ;; END GRAMMAR SOURCE DEBUGGING!
-
- (cond
- ;; We have a nonterminal symbol. Recurse inline.
- ((setq nt-loop (assq (car lte) table))
-
- (setq
- ;; push state into the nt-stack
- nt-stack (cons (vector matchlist cvl lte stream end
- )
- nt-stack)
- ;; new non-terminal matchlist
- matchlist (cdr nt-loop)
- ;; new non-terminal stream
- stream s)
-
- (throw 'push-non-terminal t)
-
- )
- ;; Default case
- (t
- (setq lse (car s) ;Get the local stream element
- s (cdr s)) ;update stream.
- ;; Do the compare
- (if (eq (car lte) (semantic-lex-token-class lse)) ;syntactic match
- (let ((valdot (semantic-lex-token-bounds lse)))
- (setq val (semantic-lex-token-text lse))
- (setq lte (cdr lte))
- (if (stringp (car lte))
- (progn
- (setq tev (car lte)
- lte (cdr lte))
- (if (string-match tev val)
- (setq cvl (cons
- (if (memq (semantic-lex-token-class lse)
- '(comment semantic-list))
- valdot val)
- cvl)) ;append this value
- (setq lte nil cvl nil))) ;clear the entry (exit)
- (setq cvl (cons
- (if (memq (semantic-lex-token-class lse)
- '(comment semantic-list))
- valdot val)
- cvl))) ;append unchecked value.
- (setq end (semantic-lex-token-end lse))
- )
- (setq lte nil cvl nil)) ;No more matches, exit
- )))
- (if (not cvl) ;lte=nil; there was no match.
- (setq matchlist (cdr matchlist)) ;Move to next matchlist entry
- (let ((start (semantic-lex-token-start (car stream))))
- (setq out (cond
- ((car lte)
- (funcall (car lte) ;call matchlist fn on values
- (nreverse cvl) start end))
- ((and (= (length cvl) 1)
- (listp (car cvl))
- (not (numberp (car (car cvl)))))
- (append (car cvl) (list start end)))
- (t
- ;;(append (nreverse cvl) (list start end))))
- ;; MAYBE THE FOLLOWING NEEDS LESS CONS
- ;; CELLS THAN THE ABOVE?
- (nreverse (cons end (cons start cvl)))))
- matchlist nil) ;;generate exit condition
- (if (not end)
- (setq out nil)))
- ;; Nothing?
- ))
- (setq result
- (if (eq s starting-stream)
- (list (cdr s) nil)
- (list s out)))
- (if nt-stack
- ;; pop previous state from the nt-stack
- (let ((state (car nt-stack)))
-
- (setq nt-popup t
- ;; pop actual parser state
- matchlist (aref state 0)
- cvl (aref state 1)
- lte (aref state 2)
- stream (aref state 3)
- end (aref state 4)
- ;; update the stack
- nt-stack (cdr nt-stack))
-
- (if out
- (let ((len (length out))
- (strip (nreverse (cdr (cdr (reverse out))))))
- (setq end (nth (1- len) out) ;reset end to the end of exp
- cvl (cons strip cvl) ;prepend value of exp
- lte (cdr lte)) ;update the local table entry
- )
- ;; No value means that we need to terminate this
- ;; match.
- (setq lte nil cvl nil)) ;No match, exit
- )))))
- (error
- ;; On error just move forward the stream of lexical tokens
- (setq result (list (cdr starting-stream) nil))
- (when (and (boundp 'semantic-debug-enabled)
- semantic-debug-enabled)
- (require 'semantic/bovine/debug)
- (let ((frame (semantic-create-bovine-debug-error-frame
- debug-condition)))
- (semantic-debug-break frame)))))
- result))
-
-;; Make it the default parser
-;;;###autoload
-(defalias 'semantic-parse-stream-default #'semantic-bovinate-stream)
-
-(provide 'semantic/bovine)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/bovine"
-;; End:
-
-;;; semantic/bovine.el ends here
+++ /dev/null
-;;; semantic/bovine/c.el --- Semantic details for C -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2024 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 <https://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/analyze/refs)
-(require 'semantic/bovine)
-(require 'semantic/bovine/gcc)
-(require 'semantic/idle)
-(require 'semantic/lex-spp)
-(require 'semantic/bovine/c-by)
-(require 'semantic/db-find)
-(require 'hideif)
-
-(eval-when-compile
- (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-needs-refresh-p "semantic/db")
-(declare-function semanticdb-typecache-faux-namespace "semantic/db-typecache")
-(declare-function c-forward-conditional "cc-cmds")
-(declare-function ede-system-include-path "ede")
-
-(eval-when-compile (require 'cc-mode))
-
-(define-obsolete-function-alias 'semantic-c-end-of-macro
- #'c-end-of-macro "28.1")
-
-;;; Code:
-(with-suppressed-warnings ((obsolete define-child-mode))
- ;; FIXME: We should handle this some other way!
- (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 language.")
-
-(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.
-
-(if (memq 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" . "")
- ("__attribute_pure__" . "")
- ("__attribute_malloc__" . "")
- ("__nonnull" . "")
- ("__wur" . "")
- ("__declspec" . ((spp-arg-list ("foo") 1 . 2)))
- ("__attribute__" . ((spp-arg-list ("foo") 1 . 2)))
- ("__asm" . ((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 (and semantic-mode
- (featurep 'semantic/bovine/c))
- (remove-hook 'mode-local-init-hook
- #'semantic-c-reset-preprocessor-symbol-map)
- ;; Initialize semantic-lex-spp-macro-symbol-obarray with symbols.
- (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)))
- (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"
- (eieio-object-name table)))))
- (setq filemap (append filemap (oref table lexical-table)))
- )))))
- ;; Update symbol obarray
- (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))))))
-
-;; Make sure the preprocessor symbols are set up when mode-local kicks
-;; in.
-(add-hook 'mode-local-init-hook #'semantic-c-reset-preprocessor-symbol-map)
-
-(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 its 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 separate 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 its 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 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)))
- (beginning-of-define (match-end 1))
- (with-args (save-excursion
- (goto-char (match-end 0))
- (looking-at "(")))
- (semantic-lex-spp-replacements-enabled nil)
- ;; Temporarily 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
- (c-end-of-macro)
- ;; HACK - If there's a C comment after
- ;; the macro, do not parse it.
- (if (looking-back "/\\*.*" beginning-of-define)
- (progn
- (goto-char (match-beginning 0))
- (point))
- (point)))))
- )
-
- ;; Only do argument checking if the paren was immediately 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 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.
-Moves 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.
- (if (fboundp 'c-scan-conditionals)
- (goto-char (c-scan-conditionals 1))
- ;; For older Emacsen, but this will set the mark.
- (c-forward-conditional 1)))
- ((looking-at "^\\s-*#\\s-*elif")
- ;; We need to let the preprocessor analyze 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))))))
-
-;;; HIDEIF USAGE:
-;; NOTE: All hideif using code was contributed by Brian Carlson as
-;; copies from hideif plus modifications and additions.
-;; Eric then converted things to use hideif functions directly,
-;; deleting most of that code, and added the advice.
-
-;;; SPP SYM EVAL
-;;
-;; Convert SPP symbols into values usable by hideif.
-;;
-;; @TODO - can these conversion fcns be a part of semantic-lex-spp.el?
-;; -- TRY semantic-lex-spp-one-token-to-txt
-(defun semantic-c-convert-spp-value-to-hideif-value (symbol macrovalue)
- "Convert an spp macro SYMBOL MACROVALUE, to something that hideif can use.
-Take the first interesting thing and convert it."
- ;; Just warn for complex macros.
- (when (> (length macrovalue) 1)
- (semantic-push-parser-warning
- (format "Complex macro value (%s) may be improperly evaluated. "
- symbol) 0 0))
-
- (let* ((lextoken (car macrovalue))
- (key (semantic-lex-token-class lextoken))
- (value (semantic-lex-token-text lextoken)))
- (cond
- ((eq key 'number) (string-to-number value))
- ((eq key 'symbol) (semantic-c-evaluate-symbol-for-hideif value))
- ((eq key 'string)
- (if (string-match "^[0-9]+L?$" value)
- ;; If it matches a number expression, then
- ;; convert to a number.
- (string-to-number value)
- value))
- (t (semantic-push-parser-warning
- (format "Unknown macro value. Token class = %s value = %s. " key value)
- 0 0)
- nil)
- )))
-
-(defun semantic-c-evaluate-symbol-for-hideif (spp-symbol)
- "Lookup the symbol SPP-SYMBOL (a string) to something hideif can use.
-Pull out the symbol list, and call
-`semantic-c-convert-spp-value-to-hideif-value'."
- (interactive "sSymbol name: ")
- (when (symbolp spp-symbol) (setq spp-symbol (symbol-name spp-symbol)))
-
- (if (semantic-lex-spp-symbol-p spp-symbol )
- ;; Convert the symbol into a stream of tokens from the macro which we
- ;; can then interpret.
- (let ((stream (semantic-lex-spp-symbol-stream spp-symbol)))
- (cond
- ;; Empty string means defined, so t.
- ((null stream) t)
- ;; A list means a parsed macro stream.
- ((listp stream)
- ;; Convert the macro to something we can return.
- (semantic-c-convert-spp-value-to-hideif-value spp-symbol stream))
-
- ;; Strings might need to be turned into numbers
- ((stringp stream)
- (if (string-match "^[0-9]+L?$" stream)
- ;; If it matches a number expression, then convert to a
- ;; number.
- (string-to-number stream)
- stream))
-
- ;; Just return the stream. A user might have just stuck some
- ;; value in it directly.
- (t stream)
- ))
- ;; Else, store an error, return nil.
- (progn
- (semantic-push-parser-warning
- (format "SPP Symbol %s not available" spp-symbol)
- (point) (point))
- nil)))
-
-;;; HIDEIF HACK support fcns
-;;
-;; These fcns can replace the impl of some hideif features.
-;;
-;; @TODO - Should hideif and semantic-c merge?
-;; I picture a grammar just for CPP that expands into
-;; a second token stream for the parser.
-(defun semantic-c-hideif-lookup (var)
- "Replacement for `hif-lookup'.
-I think it just gets the value for some CPP variable VAR."
- (let ((val (semantic-c-evaluate-symbol-for-hideif
- (cond
- ((stringp var) var)
- ((symbolp var) (symbol-name var))
- (t "Unable to determine var")))))
- (if val
- val
- ;; Real hideif will return the right undefined symbol.
- nil)))
-
-(defun semantic-c-hideif-defined (var)
- "Replacement for `hif-defined'.
-I think it just returns t/nil dependent on if VAR has been defined."
- (let ((var-symbol-name
- (cond
- ((symbolp var) (symbol-name var))
- ((stringp var) var)
- (t "Not A Symbol"))))
- (if (not (semantic-lex-spp-symbol-p var-symbol-name))
- (progn
- (semantic-push-parser-warning
- (format "Skip %s" (buffer-substring-no-properties
- (line-beginning-position) (line-end-position)))
- (line-beginning-position) (line-end-position))
- nil)
- t)))
-
-;;; HIDEIF ADVICE
-;;
-;; Advise hideif functions to use our lexical tables instead.
-(defvar semantic-c-takeover-hideif nil
- "Non-nil when Semantic is taking over hideif features.")
-
-;; (defadvice hif-defined (around semantic-c activate)
-;; "Is the variable defined?"
-;; (if semantic-c-takeover-hideif
-;; (setq ad-return-value
-;; (semantic-c-hideif-defined (ad-get-arg 0)))
-;; ad-do-it))
-
-;; (defadvice hif-lookup (around semantic-c activate)
-;; "Is the argument defined? Return true or false."
-;; (let ((ans nil))
-;; (when semantic-c-takeover-hideif
-;; (setq ans (semantic-c-hideif-lookup (ad-get-arg 0))))
-;; (if (null ans)
-;; ad-do-it
-;; (setq ad-return-value ans))))
-
-;;; #if macros
-;;
-;; Support #if macros by evaluating the values via use of hideif
-;; logic. See above for hacks to make this work.
-(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\\|elif\\).*$"
- (semantic-c-do-lex-if))
-
-(defun semantic-c-do-lex-if ()
- "Handle lexical CPP if statements.
-Enables a takeover of some hideif functions, then uses hideif to
-evaluate the #if expression and enables us to make decisions on which
-code to parse."
- ;; Enable our advice, and use hideif to parse.
- (let* ((semantic-c-takeover-hideif t)
- (hif-ifx-regexp (concat hif-cpp-prefix "\\(elif\\|if\\(n?def\\)?\\)[ \t]+"))
- (parsedtokelist
- (condition-case nil
- ;; This is imperfect, so always assume on error.
- (hif-canonicalize hif-ifx-regexp)
- (error nil))))
-
- (let ((eval-form (condition-case err
- (eval parsedtokelist t)
- (error
- (semantic-push-parser-warning
- (format "Hideif forms produced an error. Assuming false.\n%S" err)
- (point) (1+ (point)))
- nil))))
- (if (or (not eval-form)
- (and (numberp eval-form)
- (equal eval-form 0)));; ifdef line resulted in false
-
- ;; The if indicates to skip this preprocessor section
- (let () ;; (pt nil)
- (semantic-push-parser-warning (format "Skip %s" (buffer-substring-no-properties
- (line-beginning-position)
- (line-end-position)))
- (line-beginning-position) (line-end-position))
- (beginning-of-line)
- ;; (setq pt (point))
- ;; 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))
-
- ;; @TODO -somewhere around here, we also need to skip
- ;; other sections of the conditional.
-
- nil)
- ;; Else, don't ignore it, but do handle the internals.
- (end-of-line)
- (setq semantic-lex-end-point (point))
- nil))))
-
-(define-lex-regex-analyzer semantic-lex-c-ifdef
- "Code blocks wrapped up in #ifdef.
-Uses known macro tables in SPP to determine what block to skip."
- "^\\s-*#\\s-*\\(ifndef\\|ifdef\\)\\s-+\\(\\(\\sw\\|\\s_\\)+\\)\\([ \t\C-m].*\\)?$"
- (semantic-c-do-lex-ifdef))
-
-(defun semantic-c-do-lex-ifdef ()
- "Handle lexical CPP if statements."
- (let* ((sym (buffer-substring-no-properties
- (match-beginning 2) (match-end 2)))
- (ift (buffer-substring-no-properties
- (match-beginning 1) (match-end 1)))
- (ifdef (string= ift "ifdef"))
- (ifndef (string= ift "ifndef"))
- )
- (if (or (and ifdef (not (semantic-lex-spp-symbol-p sym)))
- (and ifndef (semantic-lex-spp-symbol-p sym)))
- ;; The if indicates to skip this preprocessor section.
- (let ((pt nil))
- ;; (message "%s %s yes" ift sym)
- (beginning-of-line)
- (setq pt (point))
- ;; 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\\)"
- (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 be 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-ifdef
- 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-spp-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."
- ;; FIXME: We shouldn't depend on the internals of `semantic-bovinate-stream'.
- (with-suppressed-warnings ((lexical lse)) (defvar lse))
- (if (and (boundp 'lse) (or (/= start (point-min)) (/= 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 lexing 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)
- ))
-
-(defvar semantic-c-parse-token-hack-depth 0
- "Current depth of recursive calls to `semantic-c-parse-lexical-token'.")
-
-(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* ((semantic-c-parse-token-hack-depth (1+ semantic-c-parse-token-hack-depth))
- (buf (get-buffer-create (format " *C parse hack %d*"
- semantic-c-parse-token-hack-depth)))
- (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))
- )
- (if (> semantic-c-parse-token-hack-depth 5)
- nil
- (with-current-buffer buf
- (erase-buffer)
- (when (not (eq major-mode mode))
- (save-match-data
-
- ;; Protect against user hooks throwing errors.
- (condition-case nil
- (funcall mode)
- (error
- (if (y-or-n-p
- (format "There was an error initializing %s in buffer \"%s\". Debug your hooks? "
- mode (buffer-name)))
- (semantic-c-debug-mode-init mode)
- (message "Macro parsing state may be broken...")
- (sit-for 1))))
- ) ; save match data
-
- ;; Hack in mode-local
- (mode-local--activate-bindings)
- ;; Setup C parser
- (semantic-default-c-setup)
- ;; 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-functions
- #'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))
-
-(defvar semantic-c-debug-mode-init-last-mode nil
- "The most recent mode needing debugging.")
-
-(defun semantic-c-debug-mode-init (mm)
- "Debug mode init for major mode MM after we're done parsing now."
- (interactive (list semantic-c-debug-mode-init-last-mode))
- (if (called-interactively-p 'interactive)
- ;; Do the debug.
- (progn
- (switch-to-buffer (get-buffer-create "*MODE HACK TEST*"))
- (let ((debug-on-error t))
- (funcall mm)))
-
- ;; Notify about the debug
- (setq semantic-c-debug-mode-init-last-mode mm)
-
- (add-hook 'post-command-hook #'semantic-c-debug-mode-init-pch)))
-
-(defun semantic-c-debug-mode-init-pch ()
- "Notify user about needing to debug their major mode hooks."
- (let ((mm semantic-c-debug-mode-init-last-mode))
- (switch-to-buffer-other-window
- (get-buffer-create "*MODE HACK TEST*"))
- (erase-buffer)
- (insert "A failure occurred while parsing your buffers.
-
-The failure occurred while attempting to initialize " (symbol-name mm) " in a
-buffer not associated with a file. To debug this problem, type
-
-M-x semantic-c-debug-mode-init
-
-now.
-")
- (remove-hook 'post-command-hook #'semantic-c-debug-mode-init-pch)))
-
-(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)
- (setq return-list (semantic-expand-c-extern-C tag))
- ;; The members will be expanded in the next iteration. The
- ;; 'extern' tag itself isn't needed anymore.
- (setq tag nil))
-
- ;; Check if we have a complex type
- (when (or (semantic-tag-of-class-p tag 'function)
- (semantic-tag-of-class-p tag 'variable))
- (setq tag (semantic-expand-c-complex-type tag))
- ;; Extract new basetag
- (setq return-list (car tag))
- (setq tag (cdr tag)))
-
- ;; 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 (and tag (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-extern-C (tag)
- "Expand TAG containing an `extern \"C\"' statement.
-This will return all members of TAG with `extern \"C\"' added to
-the typemodifiers attribute."
- (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)))
- (nreverse ret))))
-
-(defun semantic-expand-c-complex-type (tag)
- "Check if TAG has a full :type with a name on its own.
-If so, extract it, and replace it with a reference to that type.
-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 its own toplevel tag. This function will return (cons A B)."
- (let* ((basetype (semantic-tag-type tag))
- (typeref nil)
- (ret 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 ret (cons basetype ret)))
- (cons ret tag)))
-
-(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 (and default
- (listp (cdr 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))
- (super (semantic-tag-get-attribute tag :superclasses))
- (addlast nil))
-
- (when (and (semantic-tag-of-type-p tag "typedef")
- (semantic-tag-of-class-p super 'type)
- (semantic-tag-type-members super))
- ;; This is a typedef of a real type. Extract
- ;; the super class, and stick it into the tags list.
- (setq addlast super)
-
- ;; Clone super and remove the members IFF super has a name.
- ;; Note: anonymous struct/enums that are typedef'd shouldn't
- ;; exist in the top level type list, so they will appear only
- ;; in the :typedef slot of the typedef.
- (setq super (semantic-tag-clone super))
- (if (not (string= (semantic-tag-name super) ""))
- (semantic-tag-put-attribute super :members nil)
- (setq addlast nil))
-
- ;; Add in props to the full superclass.
- (when addlast
- (semantic--tag-copy-properties tag addlast)
- (semantic--tag-set-overlay addlast (semantic-tag-overlay tag)))
- )
-
- (while names
-
- (setq vl (cons (semantic-tag-new-type
- (nth 1 (car names)) ; name
- "typedef"
- (semantic-tag-type-members tag)
- nil
- :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 super
- ;;(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)))
-
- ;; Add typedef superclass last.
- (when addlast (setq vl (cons addlast vl)))
-
- 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\".")
-
-(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-tag-references c-mode (tag &optional db)
- "Analyze the references for TAG.
-Returns a class with information about TAG.
-
-Optional argument DB is a database. It will be used to help
-locate TAG.
-
-Use `semantic-analyze-current-tag' to debug this fcn."
- (when (not (semantic-tag-p tag)) (signal 'wrong-type-argument (list 'semantic-tag-p tag)))
- (let ((allhits nil)
- (scope nil)
- ) ;; (refs nil)
- (save-excursion
- (semantic-go-to-tag tag db)
- (setq scope (semantic-calculate-scope))
-
- (setq allhits (semantic--analyze-refs-full-lookup tag scope t))
-
- (when (or (zerop (semanticdb-find-result-length allhits))
- (and (= (semanticdb-find-result-length allhits) 1)
- (eq (car (semanticdb-find-result-nth allhits 0)) tag)))
- ;; It found nothing or only itself - not good enough. As a
- ;; last resort, let's remove all namespaces from the scope and
- ;; search again.
- (oset scope parents
- (let ((parents (oref scope parents))
- newparents)
- (dolist (cur parents)
- (unless (string= (semantic-tag-type cur) "namespace")
- (push cur newparents)))
- (reverse newparents)))
- (setq allhits (semantic--analyze-refs-full-lookup tag scope t)))
-
- ;; (setq refs
- (semantic-analyze-references (semantic-tag-name tag)
- :tag tag
- :tagdb db
- :scope scope
- :rawsearchdata allhits)))) ;;)
-
-(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)))
- (nth 10 tokenpart) ; initializers
- )
- (not (car (nth 3 tokenpart)))))
- (fcnpointer (and (> (length (car tokenpart)) 0)
- (= (aref (car tokenpart) 0) ?*)))
- (fnname (if fcnpointer
- (substring (car tokenpart) 1)
- (car tokenpart)))
- (operator (if (string-match "[a-zA-Z]" fnname)
- nil
- 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)
- (let ((split (semantic-analyze-split-name-c-mode
- (car (nth 2 tokenpart)))))
- (if (stringp split) split
- (car (last split)))))
- ;; type
- (or (cdr semantic-c-classname)
- "class")
- ;; members
- nil
- ;; parents
- nil
- ))
- (t "int")))
- ;; Argument list can contain things like function pointers
- (semantic-c-reconstitute-function-arglist (nth 4 tokenpart))
- :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)
- :function-pointer fcnpointer
- :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)
- ;; Reentrant 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 with 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)
-
-(defun semantic-c-reconstitute-function-arglist (arglist)
- "Reconstitute the argument list of a function.
-This currently only checks if the function expects a function
-pointer as argument."
- (let (result)
- (dolist (arg arglist)
- ;; Names starting with a '*' denote a function pointer
- (if (and (> (length (semantic-tag-name arg)) 0)
- (= (aref (semantic-tag-name arg) 0) ?*))
- (setq result
- (append result
- (list
- (semantic-tag-new-function
- (substring (semantic-tag-name arg) 1)
- (semantic-tag-type arg)
- (cadr (semantic-tag-attributes arg))
- :function-pointer t))))
- (setq result (append result (list arg)))))
- result))
-
-\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 :function-pointer))
- )
- (if (not fnptr)
- name
- (concat "(*" name ")"))
- ))
-
-(define-mode-local-override semantic-format-tag-canonical-name
- c-mode (tag &optional parent color)
- "Create a canonical 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.
- (if (not (and parent (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.
- (setq prot (pcase s
- ((or "extern" "export") 'public)
- ("static" 'private)))))
- (setq mods (cdr mods)))
- ;; If we have a typed parent, look for :public style labels.
- (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
- (pcase (semantic-tag-name (car pp))
- ("public" 'public)
- ("private" 'private)
- ("protected" 'protected)))
- )
- (setq pp (cdr pp)))))
- (when (and (not prot) (eq (semantic-tag-class parent) 'type))
- (setq prot
- (pcase (semantic-tag-type parent)
- ("class" 'private)
- ("struct" 'public)
- (_ 'unknown))))
- (or prot
- (if (and parent (semantic-tag-of-class-p parent 'type))
- 'public
- nil))))
-
-(define-mode-local-override semantic-find-tags-included c-mode
- (&optional table)
- "Find all tags in TABLE that are of the `include' class.
-TABLE is a tag table. See `semantic-something-to-tag-table'.
-For C++, we also have to search namespaces for include tags."
- (let ((tags (semantic-find-tags-by-class 'include table))
- (namespaces (semantic-find-tags-by-type "namespace" table)))
- (dolist (cur namespaces)
- (setq tags
- (append tags
- (semantic-find-tags-by-class
- 'include
- (semantic-tag-get-attribute cur :members)))))
- tags))
-
-
-(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-format-tag-abbreviate-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 only if its 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-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 specifiers 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 result namespaces) ;; usingname tmp
- (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 nstype originaltype) ;; newtype
- ;; Make typename unqualified
- (setq typename (if (listp typename)
- (last typename)
- (list typename)))
- (when
- (and
- ;; Get original namespace and make sure TYPE exists there.
- (setq ns (semantic-tag-name
- (car (semantic-tag-get-attribute namespace :members))))
- (setq nstype (semanticdb-typecache-find ns))
- (setq originaltype (semantic-find-tags-by-name
- (car typename)
- (semantic-tag-get-attribute nstype :members))))
- ;; Construct new type with name in original namespace.
- (setq ns (semantic-analyze-split-name ns))
- ;; (setq newtype
- (semantic-tag-clone
- (car originaltype)
- (semantic-analyze-unsplit-name
- (if (listp ns)
- (append ns typename)
- (append (list ns) 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 its 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-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
- (append tagreturn (list (semantic-tag-type
- (car (semanticdb-find-result-nth tmp idx))))))
- (setq idx (1+ idx))))
- ;; Use the encompassed types around point to also look for using
- ;; statements. If we deal with types, search inside members; for
- ;; functions, we have to call `semantic-get-local-variables' to
- ;; parse inside the function's body.
- (dolist (cur tagsaroundpoint)
- (cond
- ((and (eq (semantic-tag-class cur) 'type)
- (setq tmp (semantic-find-tags-by-class
- 'using
- (semantic-tag-components (car tagsaroundpoint)))))
- (dolist (T tmp)
- (setq tagreturn (cons (semantic-tag-type T) tagreturn))))
- ((and (semantic-tag-of-class-p (car (last tagsaroundpoint)) 'function)
- (setq tmp (semantic-find-tags-by-class
- 'using
- (semantic-get-local-variables))))
- (setq tagreturn
- (append tagreturn
- (mapcar #'semantic-tag-type tmp))))))
- ;; Return the stuff
- tagreturn))
-
-(define-mode-local-override semantic-ctxt-imported-packages c++-mode (&optional point)
- "Return the list of using tag types in scope of POINT."
- (when point (goto-char (point)))
- (let ((tagsaroundpoint (semantic-find-tag-by-overlay))
- (namereturn nil)
- (tmp nil)
- )
- ;; Collect using statements from the top level.
- (setq tmp (semantic-find-tags-by-class 'using (current-buffer)))
- (dolist (T tmp) (setq namereturn (cons (semantic-tag-type T) namereturn)))
- ;; Move through the tags around point looking for more using statements
- (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 namereturn (cons (semantic-tag-type T) namereturn)))
- (setq tagsaroundpoint (cdr tagsaroundpoint))
- )
- namereturn))
-
-(define-mode-local-override semanticdb-expand-nested-tag c++-mode (tag)
- "Expand TAG if it has a fully qualified name.
-For types with a :parent, create faux namespaces to put TAG into."
- (let ((p (semantic-tag-get-attribute tag :parent)))
- (if (and p (semantic-tag-of-class-p tag 'type))
- ;; Expand the tag
- (let ((s (semantic-analyze-split-name p))
- (newtag (semantic-tag-copy tag nil t)))
- ;; Erase the qualified name.
- (semantic-tag-put-attribute newtag :parent nil)
- ;; Fixup the namespace name
- (setq s (if (stringp s) (list s) (nreverse s)))
- ;; Loop over all the parents, creating the nested
- ;; namespace.
- (require 'semantic/db-typecache)
- (dolist (namespace s)
- (setq newtag (semanticdb-typecache-faux-namespace
- namespace (list newtag)))
- )
- ;; Return the last created namespace.
- newtag)
- ;; Else, return tag unmodified.
- tag)))
-
-(define-mode-local-override semanticdb-find-table-for-include c-mode
- (includetag &optional table)
- "For a single INCLUDETAG found in TABLE, find a `semanticdb-table' object.
-INCLUDETAG is a semantic TAG of class `include'.
-TABLE is a semanticdb table that identifies where INCLUDETAG came from.
-TABLE is optional if INCLUDETAG has an overlay of :filename attribute.
-
-For C++, we also have to check if the include is inside a
-namespace, since this means all tags inside this include will
-have to be wrapped in that namespace."
- (let ((inctable (semanticdb-find-table-for-include-default includetag table))
- (inside-ns (semantic-tag-get-attribute includetag :inside-ns))
- tags newtags namespaces parenttable newtable) ;; prefix
- (if (or (null inside-ns)
- (not inctable)
- (not (slot-boundp inctable 'tags)))
- inctable
- (when (and (eq inside-ns t)
- ;; Get the table which has this include.
- (setq parenttable
- (semanticdb-find-table-for-include-default
- (semantic-tag-new-include
- (semantic--tag-get-property includetag :filename) nil)))
- table)
- ;; Find the namespace where this include is located.
- (setq namespaces
- (semantic-find-tags-by-type "namespace" parenttable))
- (when (and namespaces
- (slot-boundp inctable 'tags))
- (dolist (cur namespaces)
- (when (semantic-find-tags-by-name
- (semantic-tag-name includetag)
- (semantic-tag-get-attribute cur :members))
- (setq inside-ns (semantic-tag-name cur))
- ;; Cache the namespace value.
- (semantic-tag-put-attribute includetag :inside-ns inside-ns)))))
- (unless (semantic-find-tags-by-name
- inside-ns
- (semantic-find-tags-by-type "namespace" inctable))
- (setq tags (oref inctable tags))
- ;; Wrap tags inside namespace tag
- (setq newtags
- (list (semantic-tag-new-type inside-ns "namespace" tags nil)))
- ;; Create new semantic-table for the wrapped tags, since we don't want
- ;; the namespace to actually be a part of the header file.
- (setq newtable (semanticdb-table))
- (oset newtable tags newtags)
- (oset newtable parent-db (oref inctable parent-db))
- (oset newtable file (oref inctable file)))
- newtable)))
-
-
-(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 (when (semantic-tag-of-class-p ct 'function)
- (or (semantic-tag-function-parent ct)
- (car-safe (semantic-find-tags-by-type
- "class" (semantic-find-tag-by-overlay)))))))
- ;; If we have a function parent, then that implies we can
- (if p
- ;; Append a new tag THIS into our space.
- (cons (semantic-tag-new-variable "this" p nil :pointer 1)
- 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 with 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))))
-
-(define-mode-local-override semantic--tag-similar-names-p c-mode (tag1 tag2 blankok)
- "Compare the names of TAG1 and TAG2.
-If BLANKOK is false, then the names must exactly match.
-If BLANKOK is true, then always return t, as for C, the names don't matter
-for arguments compared."
- (if blankok t (semantic--tag-similar-names-p-default tag1 tag2 nil)))
-
-(define-mode-local-override semantic--tag-similar-types-p c-mode (tag1 tag2)
- "For `c-mode', deal with TAG1 and TAG2 being used in different namespaces.
-In this case, one type will be shorter than the other. Instead
-of fully resolving all namespaces currently in scope for both
-types, we simply compare as many elements as the shorter type
-provides."
- ;; First, we see if the default method fails
- (if (semantic--tag-similar-types-p-default tag1 tag2)
- t
- (let* ((names
- (mapcar
- (lambda (tag)
- (let ((type (semantic-tag-type tag)))
- (unless (stringp type)
- (setq type (semantic-tag-name type)))
- (setq type (semantic-analyze-split-name type))
- (when (stringp type)
- (setq type (list type)))
- type))
- (list tag1 tag2)))
- (len1 (length (car names)))
- (len2 (length (cadr names))))
- (cond
- ((<= len1 len2)
- (equal (nthcdr len1 (cadr names)) (car names)))
- ((< len2 len1)
- (equal (nthcdr len2 (car names)) (cadr names)))))))
-
-
-(define-mode-local-override semantic--tag-attribute-similar-p c-mode
- (attr value1 value2 ignorable-attributes)
- "For `c-mode', allow function :arguments to ignore the :name attributes."
- (cond ((eq attr :arguments)
- (semantic--tag-attribute-similar-p-default attr value1 value2
- (cons :name ignorable-attributes)))
- (t
- (semantic--tag-attribute-similar-p-default attr value1 value2
- ignorable-attributes))))
-
-(defvar-mode-local c-mode semantic-orphaned-member-metaparent-type "struct"
- "When lost members 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 ";"
- "Command 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.")
-
-(defvar-mode-local c-mode semantic-tag-similar-ignorable-attributes
- '(:prototype-flag :parent :typemodifiers)
- "Tag attributes to ignore during similarity tests.
-:parent is here because some tags might specify a parent, while others are
-actually in their parent which is not accessible.")
-
-;;;###autoload
-(defun semantic-default-c-setup ()
- "Set up a buffer for semantic parsing of the C language."
- (semantic-c-by--install-parser)
- (setq semantic-lex-syntax-modifications '((?> ".")
- (?< ".")))
-
- (setq semantic-lex-analyzer #'semantic-c-lexer)
- (add-hook 'semantic-lex-reset-functions #'semantic-lex-spp-reset-hook nil t)
- (when (derived-mode-p 'c++-mode)
- (add-to-list 'semantic-lex-c-preprocessor-symbol-map '("__cplusplus" . "")))
- )
-
-;;;###autoload
-(defun semantic-c-add-preprocessor-symbol (sym replacement)
- "Add a preprocessor symbol SYM with a REPLACEMENT value."
- (interactive "sSymbol: \nsReplacement: ")
- (let ((SA (assoc sym semantic-lex-c-preprocessor-symbol-map)))
- (if SA
- ;; Replace if there is one.
- (setcdr SA replacement)
- ;; Otherwise, append
- (setq semantic-lex-c-preprocessor-symbol-map
- (cons (cons sym replacement)
- semantic-lex-c-preprocessor-symbol-map))))
-
- (semantic-c-reset-preprocessor-symbol-map)
- )
-
-;;; SETUP QUERY
-;;
-(defun semantic-c-describe-environment ()
- "Describe the Semantic features of the current C environment."
- (interactive)
- (if (not (derived-mode-p '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 (and (boundp 'ede-object) ede-object)
- (princ (substitute-command-keys
- "\n This file's project include is handled by:\n"))
- (let ((objs (if (listp ede-object)
- ede-object
- (list ede-object))))
- (dolist (O objs)
- (princ " EDE : ")
- (princ 0)
- (let ((ipath (ede-system-include-path O)))
- (if (not ipath)
- (princ "\n with NO specified system include path.\n")
- (princ "\n with the system path:\n")
- (dolist (dir ipath)
- (princ " ")
- (princ dir)
- (princ "\n"))))))
- )
-
- (when semantic-dependency-include-path
- (princ (substitute-command-keys
- "\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 (substitute-command-keys
- "\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 system files:\n")
- (dolist (file semantic-lex-c-preprocessor-symbol-file)
- (princ " ")
- (princ file)
- (princ "\n")
- (princ " in table: ")
- (let ((fto (semanticdb-file-table-object file)))
- (if fto
- (princ (cl-prin1-to-string fto))
- (princ "No Table")))
- (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 (primed from system files):\n")
- (dolist (S semantic-lex-c-preprocessor-symbol-map)
- (princ " ")
- (princ (car S))
- (princ " = ")
- (princ (cdr S))
- (princ "\n")
- ))
-
- (when (and (boundp 'ede-object)
- ede-object)
- (princ "\n Project symbol map:\n")
- (when (and (boundp 'ede-object) ede-object)
- (princ " Your project symbol map is also derived from the EDE object:\n ")
- (princ (cl-prin1-to-string ede-object)))
- (princ "\n\n")
- (if (obarrayp semantic-lex-spp-project-macro-symbol-obarray)
- (let ((macros nil))
- (mapatoms
- (lambda (symbol)
- (setq macros (cons symbol macros)))
- semantic-lex-spp-project-macro-symbol-obarray)
- (dolist (S macros)
- (princ " ")
- (princ (symbol-name S))
- (princ " = ")
- (princ (symbol-value S))
- (princ "\n")
- ))
- ;; Else, not map
- (princ " No Symbols.\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)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/bovine/c"
-;; End:
-
-;;; semantic/bovine/c.el ends here
+++ /dev/null
-;;; semantic/bovine/debug.el --- Debugger support for bovinator -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2003, 2009-2024 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 <https://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 :nonterm nonterm
- :rule rule
- :match match
- :collection collection
- :lextoken lextoken)))
- (semantic-debug-set-frame semantic-debug-current-interface
- frame)
- frame))
-
-(cl-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))
- ))
-
-(cl-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 representation 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 :condition condition)))
- (semantic-debug-set-frame semantic-debug-current-interface
- frame)
- frame))
-
-(cl-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?
- )
-
-(cl-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 -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2005, 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Use the Semantic Bovinator for Emacs Lisp
-
-(require 'semantic)
-(require 'semantic/bovine)
-(require 'semantic/db-el)
-(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, convert it to a doc string.
-For Emacs Lisp, sometimes that string is non-existent.
-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)))
-
-(defcustom semantic-elisp-store-documentation-in-tag nil
- "When non-nil, store documentation strings in the created tags."
- :type 'boolean
- :group 'semantic)
-
-(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."
- (declare (indent 1))
- (let ((sym (make-symbol "sym")))
- `(dolist (,sym ',symbols)
- (put ,sym 'semantic-elisp-form-parser #',parser))))
-
-(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 (memq (car form) '(define-overload
- define-overloadable-function))
- ))
- defun
- defun*
- defsubst
- defmacro
- cl-defun
- cl-defsubst
- cl-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
- cl-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-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."
- (condition-case nil
- (find-library-name (semantic-tag-name tag))
- (error
- (message "semantic: cannot find source file %s"
- (semantic-tag-name tag)))))
-
-;;; 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.
- (mode-local--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)))
- (obsoleter 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 obsoleter a)))))
- (if obsoleter
- (format "\n@obsolete{%s,%s}" obsoleter (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. Let's 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 "System 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 its 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\\*?\\|\\(?:cl-\\)?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? That's 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 occurrences
-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-strictly 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 easily defined by parenthesis 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 easily defined by parenthesis 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 languages. We distinctly 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 prototype, 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.")
-
-(with-suppressed-warnings ((obsolete define-child-mode))
- ;; FIXME: We should handle this some other way!
- (define-child-mode lisp-mode emacs-lisp-mode
- "Make `lisp-mode' inherit mode local behavior from `emacs-lisp-mode'."))
-
-;;;###autoload
-(defun semantic-default-elisp-setup ()
- "Setup hook function for Emacs Lisp files and Semantic."
- ;; This is here mostly to get this file loaded when a .el file is
- ;; loaded into Emacs.
- )
-
-(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 "semantic/db"
- '(require 'semantic/db-el)
- )
-
-
-(provide 'semantic/bovine/el)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/bovine/el"
-;; End:
-
-;;; semantic/bovine/el.el ends here
+++ /dev/null
-;;; semantic/bovine/gcc.el --- gcc querying special code for the C parser -*- lexical-binding: t -*-
-
-;; Copyright (C) 2008-2024 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 <https://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)
-(require 'cl-lib)
-
-(defvar semantic-lex-c-preprocessor-symbol-file)
-(defvar semantic-lex-c-preprocessor-symbol-map)
-(declare-function semantic-c-reset-preprocessor-symbol-map "semantic/bovine/c")
-
-;;; Code:
-
-(defun semantic-gcc-query (gcc-cmd &rest gcc-options)
- "Return program output or error code in case error happens.
-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"))
- (options `(,nil ,(cons buff t) ,nil ,@gcc-options))
- (err 0))
- (with-current-buffer buff
- (erase-buffer)
- (setenv "LC_ALL" "C")
- (condition-case nil
- (setq err (apply #'call-process gcc-cmd options))
- (error ;; Some bogus directory for the first time perhaps?
- (let ((default-directory (expand-file-name "~/")))
- (condition-case nil
- (setq err (apply #'call-process gcc-cmd options))
- (error ;; gcc doesn't exist???
- nil)))))
- (setenv "LC_ALL" old-lc-messages)
- (prog1
- (if (zerop err)
- (buffer-string)
- err)
- (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 uses 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 (and (file-accessible-directory-p path)
- (file-name-absolute-p path))
- (cl-pushnew (expand-file-name path) inc-path
- :test #'equal))))))))
- (nreverse 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)
- (push (cons (nth 1 dat) (nth 2 dat)) lst))))
- 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.")
-
-(defvar c++-include-path)
-
-;;;###autoload
-(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"))))
- (cpp-options `("-E" "-dM" "-x" "c++" ,null-device))
- (query (let ((q (apply #'semantic-gcc-query "cpp" cpp-options)))
- (if (stringp q)
- q
- ;; `cpp' command in `semantic-gcc-setup' doesn't work on
- ;; Mac, try `gcc'.
- (apply #'semantic-gcc-query "gcc" cpp-options))))
- (defines (if (stringp query)
- (semantic-cpp-defs query)
- (message (concat "Could not query gcc for defines. "
- "Maybe g++ is not installed."))
- nil))
- (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
- ;; FIXME: Where are `c-include-path' and `c++-include-path' used?
- (c-include-path (semantic-gcc-get-include-paths "c"))
- (c++-include-path (semantic-gcc-get-include-paths "c++"))
- (gcc-exe (locate-file "gcc" exec-path exec-suffixes 'executable))
- )
- ;; Remember so we don't have to call GCC twice.
- (setq semantic-gcc-setup-data fields)
- (when (and (not c-include-path) gcc-exe)
- ;; Fallback to guesses
- (let* ( ;; gcc include dirs
- (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
- ;; Replace cl-function remove-if-not.
- (delq nil (mapcar (lambda (d)
- (if (file-accessible-directory-p d) d))
- (list "/usr/include" gcc-include))))
- (setq c++-include-path
- (delq nil (mapcar (lambda (d)
- (if (file-accessible-directory-p d) d))
- (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 (list (concat D "/bits/c++config.h") (concat D "/sys/cdefs.h")
- (concat D "/features.h"))))
- (dolist (cur cppconfig)
- ;; Presumably there will be only one of these files in the try-paths list...
- (when (file-readable-p cur)
- ;; 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 cur)
- ;; Setup the core macro header
- (setq semantic-lex-c-preprocessor-symbol-file (list cur)))
- ))))
- (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))
- ;; Needed for parsing macOS libc
- (when (eq system-type 'darwin)
- (add-to-list 'semantic-lex-c-preprocessor-symbol-map '("__i386__" . "")))
- (when (featurep 'semantic/bovine/c)
- (semantic-c-reset-preprocessor-symbol-map))
- nil))
-
-(provide 'semantic/bovine/gcc)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/bovine/gcc"
-;; End:
-
-;;; semantic/bovine/gcc.el ends here
+++ /dev/null
-;;; semantic/bovine/grammar.el --- Bovine's input grammar mode -*- lexical-binding: t; -*-
-;;
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-;;
-;; Author: David Ponce <david@dponce.com>
-;; Created: 26 Aug 2002
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Major mode for editing Bovine's input grammar (.by) files.
-
-;;; Code:
-
-(require 'semantic)
-(require 'semantic/grammar)
-(require 'semantic/find)
-(require 'semantic/lex)
-(require 'semantic/wisent)
-(require 'semantic/bovine)
-
-(defun bovine-grammar-EXPAND (bounds nonterm)
- "Expand call to EXPAND grammar macro.
-Return the form to parse from within a nonterminal between BOUNDS.
-NONTERM is the nonterminal symbol to start with."
- `(semantic-bovinate-from-nonterminal
- (car ,bounds) (cdr ,bounds) ',nonterm))
-
-(defun bovine-grammar-EXPANDFULL (bounds nonterm)
- "Expand call to EXPANDFULL grammar macro.
-Return the form to recursively parse the area between BOUNDS.
-NONTERM is the nonterminal symbol to start with."
- `(semantic-parse-region
- (car ,bounds) (cdr ,bounds) ',nonterm 1))
-
-(defun bovine-grammar-TAG (name class &rest attributes)
- "Expand call to TAG grammar macro.
-Return the form to create a generic semantic tag.
-See the function `semantic-tag' for the meaning of arguments NAME,
-CLASS and ATTRIBUTES."
- `(semantic-tag ,name ,class ,@attributes))
-
-(defun bovine-grammar-VARIABLE-TAG (name type default-value &rest attributes)
- "Expand call to VARIABLE-TAG grammar macro.
-Return the form to create a semantic tag of class variable.
-See the function `semantic-tag-new-variable' for the meaning of
-arguments NAME, TYPE, DEFAULT-VALUE and ATTRIBUTES."
- `(semantic-tag-new-variable ,name ,type ,default-value ,@attributes))
-
-(defun bovine-grammar-FUNCTION-TAG (name type arg-list &rest attributes)
- "Expand call to FUNCTION-TAG grammar macro.
-Return the form to create a semantic tag of class function.
-See the function `semantic-tag-new-function' for the meaning of
-arguments NAME, TYPE, ARG-LIST and ATTRIBUTES."
- `(semantic-tag-new-function ,name ,type ,arg-list ,@attributes))
-
-(defun bovine-grammar-TYPE-TAG (name type members parents &rest attributes)
- "Expand call to TYPE-TAG grammar macro.
-Return the form to create a semantic tag of class type.
-See the function `semantic-tag-new-type' for the meaning of arguments
-NAME, TYPE, MEMBERS, PARENTS and ATTRIBUTES."
- `(semantic-tag-new-type ,name ,type ,members ,parents ,@attributes))
-
-(defun bovine-grammar-INCLUDE-TAG (name system-flag &rest attributes)
- "Expand call to INCLUDE-TAG grammar macro.
-Return the form to create a semantic tag of class include.
-See the function `semantic-tag-new-include' for the meaning of
-arguments NAME, SYSTEM-FLAG and ATTRIBUTES."
- `(semantic-tag-new-include ,name ,system-flag ,@attributes))
-
-(defun bovine-grammar-PACKAGE-TAG (name detail &rest attributes)
- "Expand call to PACKAGE-TAG grammar macro.
-Return the form to create a semantic tag of class package.
-See the function `semantic-tag-new-package' for the meaning of
-arguments NAME, DETAIL and ATTRIBUTES."
- `(semantic-tag-new-package ,name ,detail ,@attributes))
-
-(defun bovine-grammar-CODE-TAG (name detail &rest attributes)
- "Expand call to CODE-TAG grammar macro.
-Return the form to create a semantic tag of class code.
-See the function `semantic-tag-new-code' for the meaning of arguments
-NAME, DETAIL and ATTRIBUTES."
- `(semantic-tag-new-code ,name ,detail ,@attributes))
-
-(defun bovine-grammar-ALIAS-TAG (name aliasclass definition &rest attributes)
- "Expand call to ALIAS-TAG grammar macro.
-Return the form to create a semantic tag of class alias.
-See the function `semantic-tag-new-alias' for the meaning of arguments
-NAME, ALIASCLASS, DEFINITION and ATTRIBUTES."
- `(semantic-tag-new-alias ,name ,aliasclass ,definition ,@attributes))
-
-;; Cache of macro definitions currently in use.
-(defvar bovine--grammar-macros nil)
-
-(defun bovine-grammar-expand-form (form quotemode &optional inplace)
- "Expand FORM into a new one suitable to the bovine parser.
-FORM is a list in which we are substituting.
-Argument QUOTEMODE is non-nil if we are in backquote mode.
-When non-nil, optional argument INPLACE indicates that FORM is being
-expanded from elsewhere."
- (when (eq (car form) 'quote)
- (setq form (cdr form))
- (cond
- ((and (= (length form) 1) (listp (car form)))
- (insert "\n(append")
- (bovine-grammar-expand-form (car form) quotemode nil)
- (insert ")")
- (setq form nil inplace nil)
- )
- ((and (= (length form) 1) (symbolp (car form)))
- (insert "\n'" (symbol-name (car form)))
- (setq form nil inplace nil)
- )
- (t
- (insert "\n(list")
- (setq inplace t)
- )))
- (let ((macro (assq (car form) bovine--grammar-macros))
- inlist first n q x)
- (if macro
- (bovine-grammar-expand-form
- (apply (cdr macro) (cdr form))
- quotemode t)
- (if inplace (insert "\n("))
- (while form
- (setq first (car form)
- form (cdr form))
- ;; Hack for dealing with new reading of unquotes outside of
- ;; backquote (introduced in 2010-12-06T16:37:26Z!monnier@iro.umontreal.ca).
- (when (and (listp first)
- (or (equal (car first) '\,)
- (equal (car first) '\,@)))
- (if (listp (cadr first))
- (setq form (append (cdr first) form)
- first (car first))
- (setq first (intern (concat (symbol-name (car first))
- (symbol-name (cadr first)))))))
- (cond
- ((eq first nil)
- (when (and (not inlist) (not inplace))
- (insert "\n(list")
- (setq inlist t))
- (insert " nil")
- )
- ((listp first)
- ;;(let ((fn (and (symbolp (caar form)) (fboundp (caar form)))))
- (when (and (not inlist) (not inplace))
- (insert "\n(list")
- (setq inlist t))
- ;;(if (and inplace (not fn) (not (eq (caar form) 'EXPAND)))
- ;; (insert " (append"))
- (bovine-grammar-expand-form
- first quotemode t) ;;(and fn (not (eq fn 'quote))))
- ;;(if (and inplace (not fn) (not (eq (caar form) 'EXPAND)))
- ;; (insert ")"))
- ;;)
- )
- ((symbolp first)
- (setq n (symbol-name first) ;the name
- q quotemode ;implied quote flag
- x nil) ;expand flag
- (if (eq (aref n 0) ?,)
- (if quotemode
- ;; backquote mode needs the @
- (if (eq (aref n 1) ?@)
- (setq n (substring n 2)
- q nil
- x t)
- ;; non backquote mode behaves normally.
- (setq n (substring n 1)
- q nil))
- (setq n (substring n 1)
- x t)))
- (if (string= n "")
- (progn
- ;; We expand only the next item in place (a list?)
- ;; A regular inline-list...
- (bovine-grammar-expand-form (car form) quotemode t)
- (setq form (cdr form)))
- (if (and (eq (aref n 0) ?$)
- ;; Don't expand $ tokens in implied quote mode.
- ;; This acts like quoting in other symbols.
- (not q))
- (progn
- (cond
- ((and (not x) (not inlist) (not inplace))
- (insert "\n(list"))
- ((and x inlist (not inplace))
- (insert ")")
- (setq inlist nil)))
- (insert "\n(nth " (int-to-string
- (1- (string-to-number
- (substring n 1))))
- " vals)")
- (and (not x) (not inplace)
- (setq inlist t)))
-
- (when (and (not inlist) (not inplace))
- (insert "\n(list")
- (setq inlist t))
- (or (char-equal (char-before) ?\()
- (insert " "))
- (insert (if (or inplace (eq first t))
- "" "'")
- n))) ;; " "
- )
- (t
- (when (and (not inlist) (not inplace))
- (insert "\n(list")
- (setq inlist t))
- (insert (format "\n%S" first))
- )
- ))
- (if inlist (insert ")"))
- (if inplace (insert ")")))
- ))
-
-(defun bovine-grammar-expand-action (textform quotemode)
- "Expand semantic action string TEXTFORM into Lisp code.
-QUOTEMODE is the mode in which quoted symbols are slurred."
- (if (string= "" textform)
- nil
- (let ((sexp (read textform)))
- ;; We converted the lambda string into a list. Now write it
- ;; out as the bovine lambda expression, and do macro-like
- ;; conversion upon it.
- (insert "\n")
- (cond
- ((eq (car sexp) 'EXPAND)
- (insert ",(lambda (vals start end)"
- "\n(ignore vals start end)")
- ;; The EXPAND macro definition is mandatory
- (bovine-grammar-expand-form
- (apply (cdr (assq 'EXPAND bovine--grammar-macros)) (cdr sexp))
- quotemode t)
- )
- ((and (listp (car sexp)) (eq (caar sexp) 'EVAL))
- ;; The user wants to evaluate the following args.
- ;; Use a simpler expander
- )
- (t
- (insert ",(semantic-lambda")
- (bovine-grammar-expand-form sexp quotemode)
- ))
- (insert ")\n")))
-)
-
-(define-mode-local-override semantic-grammar-parsetable-builder
- bovine-grammar-mode ()
- "Return the parser table expression as a string value.
-The format of a bovine parser table is:
-
- ( ( NONTERMINAL-SYMBOL1 MATCH-LIST1 )
- ( NONTERMINAL-SYMBOL2 MATCH-LIST2 )
- ...
- ( NONTERMINAL-SYMBOLn MATCH-LISTn )
-
-Where each NONTERMINAL-SYMBOL is an artificial symbol which can appear
-in any child state. As a starting place, one of the NONTERMINAL-SYMBOLS
-must be `bovine-toplevel'.
-
-A MATCH-LIST is a list of possible matches of the form:
-
- ( STATE-LIST1
- STATE-LIST2
- ...
- STATE-LISTN )
-
-where STATE-LIST is of the form:
- ( TYPE1 [ \"VALUE1\" ] TYPE2 [ \"VALUE2\" ] ... LAMBDA )
-
-where TYPE is one of the returned types of the token stream.
-VALUE is a value, or range of values to match against. For
-example, a SYMBOL might need to match \"foo\". Some TYPES will not
-have matching criteria.
-
-LAMBDA is a lambda expression which is evalled with the text of the
-type when it is found. It is passed the list of all buffer text
-elements found since the last lambda expression. It should return a
-semantic element (see below.)
-
-For consistency between languages, try to use common return values
-from your parser. Please reference the chapter \"Writing Parsers\" in
-the \"Language Support Developer's Guide -\" in the semantic texinfo
-manual."
- (let* ((start (semantic-grammar-start))
- (scopestart (semantic-grammar-scopestart))
- (quotemode (semantic-grammar-quotemode))
- (tags (semantic-find-tags-by-class
- 'token (current-buffer)))
- (nterms (semantic-find-tags-by-class
- 'nonterminal (current-buffer)))
- ;; Setup the cache of macro definitions.
- (bovine--grammar-macros (semantic-grammar-macros))
- nterm rules items item actn prec tag type regex)
-
- ;; Check some trivial things
- (cond
- ((null nterms)
- (error "Bad input grammar"))
- (start
- (if (cdr start)
- (message "Extra start symbols %S ignored" (cdr start)))
- (setq start (symbol-name (car start)))
- (unless (semantic-find-first-tag-by-name start nterms)
- (error "start symbol `%s' has no rule" start)))
- (t
- ;; Default to the first grammar rule.
- (setq start (semantic-tag-name (car nterms)))))
- (when scopestart
- (setq scopestart (symbol-name scopestart))
- (unless (semantic-find-first-tag-by-name scopestart nterms)
- (error "scopestart symbol `%s' has no rule" scopestart)))
-
- ;; Generate the grammar Lisp form.
- (with-temp-buffer
- (erase-buffer)
- (insert "`(")
- ;; Insert the start/scopestart rules
- (insert "\n(bovine-toplevel \n("
- start
- ")\n) ;; end bovine-toplevel\n")
- (when scopestart
- (insert "\n(bovine-inner-scope \n("
- scopestart
- ")\n) ;; end bovine-inner-scope\n"))
- ;; Process each nonterminal
- (while nterms
- (setq nterm (car nterms)
- ;; We can't use the override form because the current buffer
- ;; is not the originator of the tag.
- rules (semantic-tag-components-semantic-grammar-mode nterm)
- nterm (semantic-tag-name nterm)
- nterms (cdr nterms))
- (when (member nterm '("bovine-toplevel" "bovine-inner-scope"))
- (error "`%s' is a reserved internal name" nterm))
- (insert "\n(" nterm)
- ;; Process each rule
- (while rules
- (setq items (semantic-tag-get-attribute (car rules) :value)
- prec (semantic-tag-get-attribute (car rules) :prec)
- actn (semantic-tag-get-attribute (car rules) :expr)
- rules (cdr rules))
- ;; Process each item
- (insert "\n(")
- (if (null items)
- ;; EMPTY rule
- (insert ";;EMPTY" (if actn "" "\n"))
- ;; Expand items
- (while items
- (setq item (car items)
- items (cdr items))
- (if (consp item) ;; mid-rule action
- (message "Mid-rule action %S ignored" item)
- (or (char-equal (char-before) ?\()
- (insert "\n"))
- (cond
- ((member item '("bovine-toplevel" "bovine-inner-scope"))
- (error "`%s' is a reserved internal name" item))
- ;; Replace ITEM by its %token definition.
- ;; If a '%token TYPE ITEM [REGEX]' definition exists
- ;; in the grammar, ITEM is replaced by TYPE [REGEX].
- ((setq tag (semantic-find-first-tag-by-name
- item tags)
- type (semantic-tag-get-attribute tag :type))
- (insert type)
- (if (setq regex (semantic-tag-get-attribute tag :value))
- (insert (format "\n%S" regex))))
- ;; Don't change ITEM
- (t
- (insert (semantic-grammar-item-text item)))
- ))))
- (if prec
- (message "%%prec %S ignored" prec))
- (if actn
- (bovine-grammar-expand-action actn quotemode))
- (insert ")"))
- (insert "\n) ;; end " nterm "\n"))
- (insert ")\n")
- (buffer-string))))
-
-(defun bovine-grammar-calculate-source-on-path ()
- "Calculate the location of the source for current buffer.
-The source directory is relative to some root in the load path."
- (condition-case nil
- (let* ((dir (nreverse (split-string (buffer-file-name) "/")))
- (newdir (car dir)))
- (setq dir (cdr dir))
- ;; Keep trying the file name until it is on the path.
- (while (and (not (locate-library newdir)) dir)
- (setq newdir (concat (car dir) "/" newdir)
- dir (cdr dir)))
- (if (not dir)
- (buffer-name)
- newdir))
- (error (buffer-name))))
-
-(define-mode-local-override semantic-grammar-setupcode-builder
- bovine-grammar-mode ()
- "Return the text of the setup code."
- (format
- "(setq semantic--parse-table %s\n\
- semantic-debug-parser-source %S\n\
- semantic-debug-parser-class 'semantic-bovine-debug-parser
- semantic-debug-parser-debugger-source 'semantic/bovine/debug
- semantic-flex-keywords-obarray %s\n\
- %s)"
- (semantic-grammar-parsetable)
- (bovine-grammar-calculate-source-on-path)
- (semantic-grammar-keywordtable)
- (let ((mode (semantic-grammar-languagemode)))
- ;; Is there more than one major mode?
- (if (and (listp mode) (> (length mode) 1))
- (format "semantic-equivalent-major-modes '%S\n" mode)
- ""))))
-
-(defvar bovine-grammar-menu
- '("BY Grammar")
- "BY mode specific grammar menu.
-Menu items are appended to the common grammar menu.")
-
-;;;###autoload
-(define-derived-mode bovine-grammar-mode semantic-grammar-mode "BY"
- "Major mode for editing Bovine grammars."
- (semantic-grammar-setup-menu bovine-grammar-menu))
-
-(add-to-list 'auto-mode-alist '("\\.by\\'" . bovine-grammar-mode))
-
-(defvar-mode-local bovine-grammar-mode semantic-grammar-macros
- '(
- (ASSOC . semantic-grammar-ASSOC)
- (EXPAND . bovine-grammar-EXPAND)
- (EXPANDFULL . bovine-grammar-EXPANDFULL)
- (TAG . bovine-grammar-TAG)
- (VARIABLE-TAG . bovine-grammar-VARIABLE-TAG)
- (FUNCTION-TAG . bovine-grammar-FUNCTION-TAG)
- (TYPE-TAG . bovine-grammar-TYPE-TAG)
- (INCLUDE-TAG . bovine-grammar-INCLUDE-TAG)
- (PACKAGE-TAG . bovine-grammar-PACKAGE-TAG)
- (CODE-TAG . bovine-grammar-CODE-TAG)
- (ALIAS-TAG . bovine-grammar-ALIAS-TAG)
- )
- "Semantic grammar macros used in bovine grammars.")
-
-(defun bovine--make-parser-1 (infile &optional outdir)
- (if outdir (setq outdir (file-name-directory (expand-file-name outdir))))
- ;; It would be nicer to use a temp-buffer rather than find-file-noselect.
- ;; The only thing stopping us is bovine's semantic-grammar-setupcode-builder's
- ;; use of (buffer-name). Perhaps that could be changed to
- ;; (file-name-nondirectory (buffer-file-name)) ?
-;; (with-temp-buffer
-;; (insert-file-contents infile)
-;; (bovine-grammar-mode)
-;; (setq buffer-file-name (expand-file-name infile))
-;; (if outdir (setq default-directory outdir))
- (let ((packagename
- ;; This is with-demoted-errors.
- (condition-case err
- (with-current-buffer (find-file-noselect infile)
- (setq infile buffer-file-name)
- (if outdir (setq default-directory outdir))
- (semantic-grammar-create-package t t))
- (error (message "%s" (error-message-string err)) nil)))
- lang filename copyright-end)
- (when (and packagename
- (string-match "^.*/\\(.*\\)-by\\.el\\'" packagename))
- (setq lang (match-string 1 packagename))
- (setq filename (expand-file-name (concat lang "-by.el") outdir))
- (with-temp-file filename
- (insert-file-contents filename)
- ;; Fix copyright header:
- (goto-char (point-min))
- (re-search-forward "^;; Author:")
- (setq copyright-end (match-beginning 0))
- (re-search-forward "^;;; Code:\n")
- (delete-region copyright-end (match-end 0))
- (goto-char copyright-end)
- (insert ";; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This file was generated from "
- (if (string-match "\\(admin/grammars/.*\\.by\\)\\'" infile)
- (match-string 1 infile)
- (concat "admin/grammars/"
- (if (string-equal lang "scm") "scheme" lang) ".by"))
-".
-
-;;; Code:
-")
- (goto-char (point-min))
- (delete-region (point-min) (line-end-position))
- (insert ";;; " packagename
- " --- Generated parser support file "
- "-*- lexical-binding:t -*-")
- (delete-trailing-whitespace)
- (re-search-forward ";;; \\(.*\\) ends here")
- (replace-match packagename nil nil nil 1)))))
-
-(defun bovine-make-parsers ()
- "Generate Emacs's built-in Bovine-based parser files."
- (interactive)
- (semantic-mode 1)
- ;; Loop through each .by file in current directory, and run
- ;; `semantic-grammar-batch-build-one-package' to build the grammar.
- (dolist (f (directory-files default-directory nil "\\.by\\'"))
- (bovine--make-parser-1 f)))
-
-
-(defun bovine-batch-make-parser (&optional infile outdir)
- "Generate a Bovine parser from input INFILE, writing to OUTDIR.
-This is mainly intended for use in batch mode:
-
-emacs -batch -l semantic/bovine/grammar -f bovine-make-parser-batch \\
- [-dir output-dir | -o output-file] file.by
-
-If -o is supplied, only the directory part is used."
- (semantic-mode 1)
- (when (and noninteractive (not infile))
- (let (arg)
- (while command-line-args-left
- (setq arg (pop command-line-args-left))
- (cond ((string-equal arg "-dir")
- (setq outdir (pop command-line-args-left)))
- ((string-equal arg "-o")
- (setq outdir (file-name-directory (pop command-line-args-left))))
- (t (setq infile arg))))))
- (or infile (error "No input file specified"))
- (or (file-readable-p infile)
- (error "Input file `%s' not readable" infile))
- (bovine--make-parser-1 infile outdir))
-
-(provide 'semantic/bovine/grammar)
-
-;; Local variables:
-;; generated-autoload-load-name: "semantic/bovine/grammar"
-;; End:
-
-;;; semantic/bovine/grammar.el ends here
+++ /dev/null
-;;; semantic/bovine/make.el --- Makefile parsing rules. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000-2004, 2008-2024 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 <https://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)
-(require 'semantic/bovine/make-by)
-(require 'semantic/analyze)
-(require 'semantic/dep)
-
-(declare-function semantic-analyze-possible-completions-default
- "semantic/analyze/complete")
-
-;;; 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
- "Regexp for a command in a Makefile.
-It 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 &rest _flags)
- "Return a list of possible completions in a Makefile.
-Uses default implementation, and also gets a list of filenames."
- (require 'semantic/analyze/complete)
- (with-current-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 language.")
-
-;;;###autoload
-(defun semantic-default-make-setup ()
- "Set up a Makefile buffer for parsing with semantic."
- (semantic-make-by--install-parser)
- (setq semantic-symbol->name-assoc-list '((variable . "Variables")
- (function . "Rules")
- (include . "Dependencies")
- ;; File is a meta-type created
- ;; to represent completions
- ;; but not actually parsed.
- (file . "File"))
- semantic-case-fold t
- semantic-tag-expand-function #'semantic-make-expand-tag
- semantic-lex-syntax-modifications '((?. "_")
- (?= ".")
- (?/ "_")
- (?$ ".")
- (?+ ".")
- (?\\ ".")
- )
- imenu-create-index-function #'semantic-create-imenu-index
- )
- (setq semantic-lex-analyzer #'semantic-make-lexer)
- )
-
-(provide 'semantic/bovine/make)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/bovine/make"
-;; End:
-
-;;; semantic/bovine/make.el ends here
+++ /dev/null
-;;; semantic/bovine/scm.el --- Semantic details for Scheme (guile) -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2001-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Use the Semantic Bovinator for Scheme (guile)
-
-(require 'semantic)
-(require 'semantic/bovine)
-(require 'semantic/bovine/scm-by)
-(require 'semantic/format)
-(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 &optional parent color)
- "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 parent color))))
-
-(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\\|\\s_\\)+"
- ;; (message "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)
-
-;;;###autoload
-(defun semantic-default-scheme-setup ()
- "Setup hook function for Emacs Lisp files and Semantic."
- (semantic-scm-by--install-parser)
- (setq semantic-symbol->name-assoc-list '( (variable . "Variables")
- ;;(type . "Types")
- (function . "Functions")
- (include . "Loads")
- (package . "DefineModule"))
- imenu-create-index-function #'semantic-create-imenu-index
- )
- (setq semantic-lex-analyzer #'semantic-scheme-lexer)
- )
-
-(provide 'semantic/bovine/scm)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/bovine/scm"
-;; End:
-
-;;; semantic/bovine/scm.el ends here
+++ /dev/null
-;;; semantic/chart.el --- Utilities for use with semantic tag tables -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2001, 2003, 2005, 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; A set of simple functions for charting details about a file based on
-;; the output of the semantic parser.
-;;
-
-(require 'chart)
-(require 'semantic/db)
-(require 'semantic/find)
-(require 'semantic/db-typecache)
-(require 'semantic/scope)
-
-;;; Code:
-
-(defun semantic-chart-tags-by-class (&optional tagtable)
- "Create a bar chart representing the number of tags for a given tag class.
-Each bar represents how many toplevel tags in TAGTABLE
-exist with a given class. See `semantic-symbol->name-assoc-list'
-for tokens which will be charted.
-TAGTABLE is passed to `semantic-something-to-tag-table'."
- (interactive)
- (let* ((stream (semantic-something-to-tag-table
- (or tagtable (current-buffer))))
- (names (mapcar #'cdr semantic-symbol->name-assoc-list))
- (nums (mapcar
- (lambda (symname)
- (length
- (semantic-brute-find-tag-by-class (car symname)
- stream)
- ))
- semantic-symbol->name-assoc-list)))
- (chart-bar-quickie 'vertical
- "Semantic Toplevel Tag Volume"
- names "Tag Class"
- nums "Volume")
- ))
-
-(defun semantic-chart-database-size (&optional _tagtable)
- "Create a bar chart representing the size of each file in semanticdb.
-Each bar represents how many toplevel tags in TAGTABLE
-exist in each database entry.
-TAGTABLE is passed to `semantic-something-to-tag-table'."
- (interactive)
- (unless (and (fboundp 'semanticdb-minor-mode-p)
- (semanticdb-minor-mode-p))
- (error "Semanticdb is not enabled"))
- (let* ((db semanticdb-current-database)
- (dbt (semanticdb-get-database-tables db))
- (names (mapcar #'car
- (object-assoc-list
- 'file
- dbt)))
- (numnuts (mapcar (lambda (dba)
- (prog1
- (cons
- (if (slot-boundp dba 'tags)
- (length (oref dba tags))
- 1)
- (car names))
- (setq names (cdr names))))
- dbt))
- (nums nil)
- (fh (/ (- (frame-height) 7) 4)))
- (setq numnuts (sort numnuts :reverse t))
- (setq names (mapcar #'cdr numnuts)
- nums (mapcar #'car numnuts))
- (if (> (length names) fh)
- (progn
- (setcdr (nthcdr fh names) nil)
- (setcdr (nthcdr fh nums) nil)))
- (chart-bar-quickie 'horizontal
- "Semantic DB Toplevel Tag Volume"
- names "File"
- nums "Volume")
- ))
-
-(defun semantic-chart-token-complexity (tok)
- "Calculate the `complexity' of token TOK."
- (count-lines
- (semantic-tag-end tok)
- (semantic-tag-start tok)))
-
-(defun semantic-chart-tag-complexity
- (&optional class tagtable)
- "Create a bar chart representing the complexity of some tags.
-Complexity is calculated for tags of CLASS. Each bar represents
-the complexity of some tag in TAGTABLE. Only the most complex
-items are charted. TAGTABLE is passed to
-`semantic-something-to-tag-table'."
- (interactive)
- (let* ((sym (if (not class) 'function))
- (stream
- (semantic-find-tags-by-class
- sym (semantic-something-to-tag-table (or tagtable
- (current-buffer)))
- ))
- (name (cond ((semantic-tag-with-position-p (car stream))
- (buffer-name (semantic-tag-buffer (car stream))))
- (t "")))
- (cplx (mapcar (lambda (tok)
- (cons tok (semantic-chart-token-complexity tok)))
- stream))
- (namelabel (cdr (assoc 'function semantic-symbol->name-assoc-list)))
- (names nil)
- (nums nil))
- (setq cplx (sort cplx :key #'cdr :reverse t))
- (while (and cplx (<= (length names) (/ (- (frame-height) 7) 4)))
- (setq names (cons (semantic-tag-name (car (car cplx)))
- names)
- nums (cons (cdr (car cplx)) nums)
- cplx (cdr cplx)))
-;; ;; (setq names (mapcar (lambda (str)
-;; ;; (substring str (- (length str) 10)))
-;; ;; names))
- (chart-bar-quickie 'horizontal
- (format "%s Complexity in %s"
- (capitalize (symbol-name sym))
- name)
- names namelabel
- nums "Complexity (Lines of code)")
- ))
-
-(defun semantic-chart-analyzer ()
- "Chart the extent of the context analysis."
- (interactive)
- (let* ((p (semanticdb-find-translate-path nil nil))
- (plen (length p))
- (tab semanticdb-current-table)
- (tc (semanticdb-get-typecache tab))
- (tclen (+ (length (oref tc filestream))
- (length (oref tc includestream))))
- (scope (semantic-calculate-scope))
- (fslen (length (oref scope fullscope)))
- (lvarlen (length (oref scope localvar)))
- )
- (chart-bar-quickie 'vertical
- (format "Analyzer Overhead in %s" (buffer-name))
- '("includes" "typecache" "scopelen" "localvar")
- "Overhead Entries"
- (list plen tclen fslen lvarlen)
- "Number of tags")
- ))
-
-(provide 'semantic/chart)
-
-;;; semantic/chart.el ends here
+++ /dev/null
-;;; semantic/complete.el --- Routines for performing tag completion -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2003-2005, 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Completion of tags by name using tables of semantic generated tags.
-;;
-;; While it would be a simple matter of flattening all tag known
-;; tables to perform completion across them using `all-completions',
-;; or `try-completion', that process would be slow. In particular,
-;; when a system database is included in the mix, the potential for a
-;; ludicrous number of options becomes apparent.
-;;
-;; As such, dynamically searching across tables using a prefix,
-;; regular expression, or other feature is needed to help find symbols
-;; quickly without resorting to "show me every possible option now".
-;;
-;; In addition, some symbol names will appear in multiple locations.
-;; If it is important to distinguish, then a way to provide a choice
-;; over these locations is important as well.
-;;
-;; Beyond brute force offers for completion of plain strings,
-;; using the smarts of semantic-analyze to provide reduced lists of
-;; symbols, or fancy tabbing to zoom into files to show multiple hits
-;; of the same name can be provided.
-;;
-;;; How it works:
-;;
-;; There are several parts of any completion engine. They are:
-;;
-;; A. Collection of possible hits
-;; B. Typing or selecting an option
-;; C. Displaying possible unique completions
-;; D. Using the result
-;;
-;; Here, we will treat each section separately (excluding D)
-;; They can then be strung together in user-visible commands to
-;; fulfill specific needs.
-;;
-;; COLLECTORS:
-;;
-;; A collector is an object which represents the means by which tags
-;; to complete on are collected. It's first job is to find all the
-;; tags which are to be completed against. It can also rename
-;; some tags if needed so long as `semantic-tag-clone' is used.
-;;
-;; Some collectors will gather all tags to complete against first
-;; (for in buffer queries, or other small list situations). It may
-;; choose to do a broad search on each completion request. Built in
-;; functionality automatically focuses the cache in as the user types.
-;;
-;; A collector choosing to create and rename tags could choose a
-;; plain name format, a postfix name such as method:class, or a
-;; prefix name such as class.method.
-;;
-;; DISPLAYERS
-;;
-;; A displayer is in charge if showing the user interesting things
-;; about available completions, and can optionally provide a focus.
-;; The simplest display just lists all available names in a separate
-;; window. It may even choose to show short names when there are
-;; many to choose from, or long names when there are fewer.
-;;
-;; A complex displayer could opt to help the user 'focus' on some
-;; range. For example, if 4 tags all have the same name, subsequent
-;; calls to the displayer may opt to show each tag one at a time in
-;; the buffer. When the user likes one, selection would cause the
-;; 'focus' item to be selected.
-;;
-;; CACHE FORMAT
-;;
-;; The format of the tag lists used to perform the completions are in
-;; semanticdb "find" format, like this:
-;;
-;; ( ( DBTABLE1 TAG1 TAG2 ...)
-;; ( DBTABLE2 TAG1 TAG2 ...)
-;; ... )
-;;
-;; INLINE vs MINIBUFFER
-;;
-;; Two major ways completion is used in Emacs is either through a
-;; minibuffer query, or via completion in a normal editing buffer,
-;; encompassing some small range of characters.
-;;
-;; Structure for both types of completion are provided here.
-;; `semantic-complete-read-tag-engine' will use the minibuffer.
-;; `semantic-complete-inline-tag-engine' will complete text in
-;; a buffer.
-
-(require 'semantic)
-(require 'eieio-opt)
-(require 'semantic/analyze)
-(require 'semantic/ctxt)
-(require 'semantic/decorate)
-(require 'semantic/format)
-(require 'semantic/idle)
-
-(eval-when-compile
- ;; For the semantic-find-tags-for-completion macro.
- (require 'semantic/find))
-(require 'semantic/db-find) ;For type semanticdb-find-result-with-nil.
-
-;;; Code:
-
-(defvar semantic-complete-inline-overlay nil
- "The overlay currently active while completing inline.")
-
-(defun semantic-completion-inline-active-p ()
- "Non-nil if inline completion is active."
- (when (and semantic-complete-inline-overlay
- (not (overlay-buffer semantic-complete-inline-overlay)))
- (delete-overlay semantic-complete-inline-overlay)
- (setq semantic-complete-inline-overlay nil))
- semantic-complete-inline-overlay)
-
-;;; ------------------------------------------------------------
-;;; MINIBUFFER or INLINE utils
-;;
-(defun semantic-completion-text ()
- "Return the text that is currently in the completion buffer.
-For a minibuffer prompt, this is the minibuffer text.
-For inline completion, this is the text wrapped in the inline completion
-overlay."
- (if semantic-complete-inline-overlay
- (semantic-complete-inline-text)
- (minibuffer-contents)))
-
-(defun semantic-completion-delete-text ()
- "Delete the text that is actively being completed.
-Presumably if you call this you will insert something new there."
- (if semantic-complete-inline-overlay
- (semantic-complete-inline-delete-text)
- (delete-minibuffer-contents)))
-
-(defun semantic-completion-message (fmt &rest args)
- "Display the string FMT formatted with ARGS at the end of the minibuffer."
- (if semantic-complete-inline-overlay
- (apply #'message fmt args)
- (apply #'message (concat "%s" fmt) (buffer-string) args)))
-
-;;; ------------------------------------------------------------
-;;; MINIBUFFER: Option Selection harnesses
-;;
-(defvar semantic-completion-collector-engine nil
- "The tag collector for the current completion operation.
-Value should be an object of a subclass of
-`semantic-completion-engine-abstract'.")
-
-(defvar semantic-completion-display-engine nil
- "The tag display engine for the current completion operation.
-Value should be a ... what?")
-
-(defvar semantic-complete-key-map
- (let ((km (make-sparse-keymap)))
- (define-key km " " #'semantic-complete-complete-space)
- (define-key km "\t" #'semantic-complete-complete-tab)
- (define-key km "\C-m" #'semantic-complete-done)
- (define-key km "\C-g" #'abort-recursive-edit)
- (define-key km "\M-n" #'next-history-element)
- (define-key km "\M-p" #'previous-history-element)
- (define-key km "\C-n" #'next-history-element)
- (define-key km "\C-p" #'previous-history-element)
- ;; Add history navigation
- km)
- "Keymap used while completing across a list of tags.")
-
-(defvar semantic-completion-default-history nil
- "Default history variable for any unhistoried prompt.
-Keeps STRINGS only in the history.")
-
-(defvar semantic-complete-active-default)
-(defvar semantic-complete-current-matched-tag)
-
-(defun semantic-complete-read-tag-engine (collector displayer prompt
- default-tag initial-input
- history)
- "Read a semantic tag, and return a tag for the selection.
-Argument COLLECTOR is an object which can be used to calculate
-a list of possible hits. See `semantic-completion-collector-engine'
-for details on COLLECTOR.
-Argument DISPLAYER is an object used to display a list of possible
-completions for a given prefix. See `semantic-completion-display-engine'
-for details on DISPLAYER.
-PROMPT is a string to prompt with.
-DEFAULT-TAG is a semantic tag or string to use as the default value.
-If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
-HISTORY is a symbol representing a variable to story the history in."
- (let* ((semantic-completion-collector-engine collector)
- (semantic-completion-display-engine displayer)
- (semantic-complete-active-default nil)
- (semantic-complete-current-matched-tag nil)
- (default-as-tag (semantic-complete-default-to-tag default-tag))
- (default-as-string (when (semantic-tag-p default-as-tag)
- (semantic-tag-name default-as-tag)))
- )
-
- (when default-as-string
- ;; Add this to the prompt.
- ;;
- ;; I really want to add a lookup of the symbol in those
- ;; tags available to the collector and only add it if it
- ;; is available as a possibility, but I'm too lazy right
- ;; now.
- ;;
-
- ;; @todo - move from () to into the editable area
- (if (string-match ":" prompt)
- (setq prompt (format-prompt
- (substring prompt 0 (match-beginning 0))
- default-as-string))
- (setq prompt (format-prompt prompt default-as-string))))
- ;;
- ;; Perform the Completion
- ;;
- (unwind-protect
- (read-from-minibuffer prompt
- initial-input
- semantic-complete-key-map
- nil
- (or history
- 'semantic-completion-default-history)
- default-tag)
- (semantic-collector-cleanup semantic-completion-collector-engine)
- (semantic-displayer-cleanup semantic-completion-display-engine)
- )
- ;;
- ;; Extract the tag from the completion machinery.
- ;;
- semantic-complete-current-matched-tag
- ))
-
-\f
-;;; Util for basic completion prompts
-;;
-
-(defvar semantic-complete-active-default nil
- "The current default tag calculated for this prompt.")
-
-(defun semantic-complete-default-to-tag (default)
- "Convert a calculated or passed in DEFAULT into a tag."
- (if (semantic-tag-p default)
- ;; Just return what was passed in.
- (setq semantic-complete-active-default default)
- ;; If none was passed in, guess.
- (if (null default)
- (setq default (semantic-ctxt-current-thing)))
- (if (null default)
- ;; Do nothing
- nil
- ;; Turn default into something useful.
- (let ((str
- (cond
- ;; Semantic-ctxt-current-symbol will return a list of
- ;; strings. Technically, we should use the analyzer to
- ;; fully extract what we need, but for now, just grab the
- ;; first string
- ((and (listp default) (stringp (car default)))
- (car default))
- ((stringp default)
- default)
- ((symbolp default)
- (symbol-name default))
- (t
- (signal 'wrong-type-argument
- (list default 'semantic-tag-p)))))
- (tag nil))
- ;; Now that we have that symbol string, look it up using the active
- ;; collector. If we get a match, use it.
- (save-excursion
- (semantic-collector-calculate-completions
- semantic-completion-collector-engine
- str nil))
- ;; Do we have the perfect match???
- (let ((ml (semantic-collector-current-exact-match
- semantic-completion-collector-engine)))
- (when ml
- ;; We don't care about uniqueness. Just guess for convenience
- (setq tag (semanticdb-find-result-nth-in-buffer ml 0))))
- ;; save it
- (setq semantic-complete-active-default tag)
- ;; Return it.. .whatever it may be
- tag))))
-
-\f
-;;; Prompt Return Value
-;;
-;; Getting a return value out of this completion prompt is a bit
-;; challenging. The read command returns the string typed in.
-;; We need to convert this into a valid tag. We can exit the minibuffer
-;; for different reasons. If we purposely exit, we must make sure
-;; the focused tag is calculated... preferably once.
-(defvar semantic-complete-current-matched-tag nil
- "Variable used to pass the tags being matched to the prompt.")
-
-
-
-;; Abstract baseclass for any displayer which supports focus
-
-(defclass semantic-displayer-abstract ()
- ((table :type (or null semanticdb-find-result-with-nil)
- :initform nil
- :protection :protected
- :documentation "List of tags this displayer is showing.")
- (last-prefix :type string
- :protection :protected
- :documentation "Prefix associated with slot `table'.")
- )
- "Abstract displayer baseclass.
-Manages the display of some number of tags.
-Provides the basics for a displayer, including interacting with
-a collector, and tracking tables of completion to display."
- :abstract t)
-
-(defclass semantic-displayer-focus-abstract (semantic-displayer-abstract)
- ((focus :type number
- :protection :protected
- :documentation "A tag index from `table' which has focus.
-Multiple calls to the display function can choose to focus on a
-given tag, by highlighting its location.")
- (find-file-focus
- :allocation :class
- :initform nil
- :documentation
- "Non-nil if focusing requires a tag's buffer be in memory.")
- )
- "Abstract displayer supporting `focus'.
-A displayer which has the ability to focus in on one tag.
-Focusing is a way of differentiating among multiple tags
-which have the same name."
- :abstract t)
-
-
-(defun semantic-complete-current-match ()
- "Calculate a match from the current completion environment.
-Save this in our completion variable. Make sure that variable
-is cleared if any other keypress is made.
-Return value can be:
- tag - a single tag that has been matched.
- string - a message to show in the minibuffer."
- ;; Query the environment for an active completion.
- (let ((collector semantic-completion-collector-engine)
- (displayer semantic-completion-display-engine)
- (contents (semantic-completion-text))
- matchlist
- answer)
- (if (string= contents "")
- ;; The user wants the defaults!
- (setq answer semantic-complete-active-default)
- ;; This forces a full calculation of completion on CR.
- (save-excursion
- (semantic-collector-calculate-completions collector contents nil))
- (semantic-complete-try-completion)
- (cond
- ;; Input match displayer focus entry
- ((setq answer (semantic-displayer-current-focus displayer))
- ;; We have answer, continue
- )
- ;; One match from the collector
- ((setq matchlist (semantic-collector-current-exact-match collector))
- (if (= (semanticdb-find-result-length matchlist) 1)
- (setq answer (semanticdb-find-result-nth-in-buffer matchlist 0))
- (if (cl-typep displayer 'semantic-displayer-focus-abstract)
- ;; For focusing displayers, we can claim this is
- ;; not unique. Multiple focuses can choose the correct
- ;; one.
- (setq answer "Not Unique")
- ;; If we don't have a focusing displayer, we need to do something
- ;; graceful. First, see if all the matches have the same name.
- (let ((allsame t)
- (firstname (semantic-tag-name
- (car
- (semanticdb-find-result-nth matchlist 0)))
- )
- (cnt 1)
- (max (semanticdb-find-result-length matchlist)))
- (while (and allsame (< cnt max))
- (if (not (string=
- firstname
- (semantic-tag-name
- (car
- (semanticdb-find-result-nth matchlist cnt)))))
- (setq allsame nil))
- (setq cnt (1+ cnt))
- )
- ;; Now we know if they are all the same. If they are, just
- ;; accept the first, otherwise complain.
- (if allsame
- (setq answer (semanticdb-find-result-nth-in-buffer
- matchlist 0))
- (setq answer "Not Unique"))
- ))))
- ;; No match
- (t
- (setq answer "No Match")))
- )
- ;; Set it into our completion target.
- (when (semantic-tag-p answer)
- (setq semantic-complete-current-matched-tag answer)
- ;; Make sure it is up to date by clearing it if the user dares
- ;; to touch the keyboard.
- (add-hook 'pre-command-hook
- (lambda () (setq semantic-complete-current-matched-tag nil)))
- )
- ;; Return it
- answer
- ))
-
-\f
-;;; Keybindings
-;;
-;; Keys are bound to perform completion using our mechanisms.
-;; Do that work here.
-(defun semantic-complete-done ()
- "Accept the current input."
- (interactive)
- (let ((ans (semantic-complete-current-match)))
- (if (stringp ans)
- (semantic-completion-message (concat " [" ans "]"))
- (exit-minibuffer)))
- )
-
-(defun semantic-complete-complete-space ()
- "Complete the partial input in the minibuffer."
- (interactive)
- (semantic-complete-do-completion t))
-
-(defun semantic-complete-complete-tab ()
- "Complete the partial input in the minibuffer as far as possible."
- (interactive)
- (semantic-complete-do-completion))
-
-;;; Completion Functions
-;;
-;; Thees routines are functional entry points to performing completion.
-;;
-(defun semantic-complete-hack-word-boundaries (original new)
- "Return a string to use for completion.
-ORIGINAL is the text in the minibuffer.
-NEW is the new text to insert into the minibuffer.
-Within the difference bounds of ORIGINAL and NEW, shorten NEW
-to the nearest word boundary, and return that."
- (save-match-data
- (let* ((diff (substring new (length original)))
- (end (string-match "\\>" diff))
- (start (string-match "\\<" diff)))
- (cond
- ((and start (> start 0))
- ;; If start is greater than 0, include only the new
- ;; white-space stuff
- (concat original (substring diff 0 start)))
- (end
- (concat original (substring diff 0 end)))
- (t new)))))
-
-(defun semantic-complete-try-completion (&optional partial)
- "Try a completion for the current minibuffer.
-If PARTIAL, do partial completion stopping at spaces."
- (let ((comp (semantic-collector-try-completion
- semantic-completion-collector-engine
- (semantic-completion-text))))
- (cond
- ((null comp)
- (semantic-completion-message " [No Match]")
- (ding)
- )
- ((stringp comp)
- (if (string= (semantic-completion-text) comp)
- (when partial
- ;; Minibuffer isn't changing AND the text is not unique.
- ;; Test for partial completion over a word separator character.
- ;; If there is one available, use that so that SPC can
- ;; act like a SPC insert key.
- (let ((newcomp (semantic-collector-current-whitespace-completion
- semantic-completion-collector-engine)))
- (when newcomp
- (semantic-completion-delete-text)
- (insert newcomp))
- ))
- (when partial
- (let ((orig (semantic-completion-text)))
- ;; For partial completion, we stop and step over
- ;; word boundaries. Use this nifty function to do
- ;; that calculation for us.
- (setq comp
- (semantic-complete-hack-word-boundaries orig comp))))
- ;; Do the replacement.
- (semantic-completion-delete-text)
- (insert comp))
- )
- ((and (listp comp) (semantic-tag-p (car comp)))
- (unless (string= (semantic-completion-text)
- (semantic-tag-name (car comp)))
- ;; A fully unique completion was available.
- (semantic-completion-delete-text)
- (insert (semantic-tag-name (car comp))))
- ;; The match is complete
- (if (= (length comp) 1)
- (semantic-completion-message " [Complete]")
- (semantic-completion-message " [Complete, but not unique]"))
- )
- (t nil))))
-
-(defun semantic-complete-do-completion (&optional partial _inline)
- "Do a completion for the current minibuffer.
-If PARTIAL, do partial completion stopping at spaces.
-if INLINE, then completion is happening inline in a buffer."
- (let* ((collector semantic-completion-collector-engine)
- (displayer semantic-completion-display-engine)
- (contents (semantic-completion-text))
- (ans nil))
-
- (save-excursion
- (semantic-collector-calculate-completions collector contents partial))
- (let* ((na (semantic-complete-next-action partial)))
- (cond
- ;; We're all done, but only from a very specific
- ;; area of completion.
- ((eq na 'done)
- (semantic-completion-message " [Complete]")
- (setq ans 'done))
- ;; Perform completion
- ((or (eq na 'complete)
- (eq na 'complete-whitespace))
- (semantic-complete-try-completion partial)
- (setq ans 'complete))
- ;; We need to display the completions.
- ;; Set the completions into the display engine
- ((or (eq na 'display) (eq na 'displayend))
- (semantic-displayer-set-completions
- displayer
- (or
- ;; For the below - This caused problems for Chong Yidong
- ;; when experimenting with the completion engine. I don't
- ;; remember what the problem was though, and I wasn't sure why
- ;; the below two lines were there since they obviously added
- ;; some odd behavior. -EML
- ;; (and (not (eq na 'displayend))
- ;; (semantic-collector-current-exact-match collector))
- (semantic-collector-all-completions collector contents))
- contents)
- ;; Ask the displayer to display them.
- (semantic-displayer-show-request displayer))
- ((eq na 'scroll)
- (semantic-displayer-scroll-request displayer)
- )
- ((eq na 'focus)
- (semantic-displayer-focus-next displayer)
- (semantic-displayer-focus-request displayer)
- )
- ((eq na 'empty)
- (semantic-completion-message " [No Match]"))
- (t nil)))
- ans))
-
-\f
-;;; ------------------------------------------------------------
-;;; INLINE: tag completion harness
-;;
-;; Unlike the minibuffer, there is no mode nor other traditional
-;; means of reading user commands in completion mode. Instead
-;; we use a pre-command-hook to inset in our commands, and to
-;; push ourselves out of this mode on alternate keypresses.
-(defvar semantic-complete-inline-map
- (let ((km (make-sparse-keymap)))
- (define-key km "\C-i" #'semantic-complete-inline-TAB)
- (define-key km "\M-p" #'semantic-complete-inline-up)
- (define-key km "\M-n" #'semantic-complete-inline-down)
- (define-key km "\C-m" #'semantic-complete-inline-done)
- (define-key km "\C-\M-c" #'semantic-complete-inline-exit)
- (define-key km "\C-g" #'semantic-complete-inline-quit)
- (define-key km "?"
- (lambda () (interactive)
- (describe-variable 'semantic-complete-inline-map)))
- km)
- "Keymap used while performing Semantic inline completion.")
-
-(defface semantic-complete-inline-face
- '((((class color) (background dark))
- (:underline "yellow"))
- (((class color) (background light))
- (:underline "brown")))
- "Face used to show the region being completed inline.
-The face is used in `semantic-complete-inline-tag-engine'."
- :group 'semantic-faces)
-
-(defun semantic-complete-inline-text ()
- "Return the text that is being completed inline.
-Similar to `minibuffer-contents' when completing in the minibuffer."
- (let ((s (overlay-start semantic-complete-inline-overlay))
- (e (overlay-end semantic-complete-inline-overlay)))
- (if (= s e)
- ""
- (buffer-substring-no-properties s e ))))
-
-(defun semantic-complete-inline-delete-text ()
- "Delete the text currently being completed in the current buffer."
- (delete-region
- (overlay-start semantic-complete-inline-overlay)
- (overlay-end semantic-complete-inline-overlay)))
-
-(defun semantic-complete-inline-done ()
- "This completion thing is DONE, OR, insert a newline."
- (interactive)
- (let* ((displayer semantic-completion-display-engine)
- (tag (semantic-displayer-current-focus displayer)))
- (if tag
- (let ((txt (semantic-completion-text)))
- (insert (substring (semantic-tag-name tag)
- (length txt)))
- (semantic-complete-inline-exit))
-
- ;; Get whatever binding RET usually has.
- (let ((fcn
- (condition-case nil
- (lookup-key (current-active-maps) (this-command-keys))
- (error
- ;; I don't know why, but for some reason the above
- ;; throws an error sometimes.
- (lookup-key (current-global-map) (this-command-keys))
- ))))
- (when fcn
- (funcall fcn)))
- )))
-
-(defun semantic-complete-inline-quit ()
- "Quit an inline edit."
- (interactive)
- (semantic-complete-inline-exit)
- (keyboard-quit))
-
-(defun semantic-complete-inline-exit ()
- "Exit inline completion mode."
- (interactive)
- ;; Remove this hook FIRST!
- (remove-hook 'pre-command-hook #'semantic-complete-pre-command-hook)
-
- (condition-case nil
- (progn
- (when semantic-completion-collector-engine
- (semantic-collector-cleanup semantic-completion-collector-engine))
- (when semantic-completion-display-engine
- (semantic-displayer-cleanup semantic-completion-display-engine))
-
- (when semantic-complete-inline-overlay
- (let ((wc (overlay-get semantic-complete-inline-overlay
- 'window-config-start))
- (buf (overlay-buffer semantic-complete-inline-overlay))
- )
- (delete-overlay semantic-complete-inline-overlay)
- (setq semantic-complete-inline-overlay nil)
- ;; DON'T restore the window configuration if we just
- ;; switched windows!
- (when (eq buf (current-buffer))
- (set-window-configuration wc))
- ))
-
- (setq semantic-completion-collector-engine nil
- semantic-completion-display-engine nil))
- (error nil))
-
- ;; Remove this hook LAST!!!
- ;; This will force us back through this function if there was
- ;; some sort of error above.
- (remove-hook 'post-command-hook #'semantic-complete-post-command-hook)
-
- ;;(message "Exiting inline completion.")
- )
-
-(defun semantic-complete-pre-command-hook ()
- "Used to redefine what commands are being run while completing.
-When installed as a `pre-command-hook' the special keymap
-`semantic-complete-inline-map' is queried to replace commands normally run.
-Commands which edit what is in the region of interest operate normally.
-Commands which would take us out of the region of interest, or our
-quit hook, will exit this completion mode."
- (let ((fcn (lookup-key semantic-complete-inline-map
- (this-command-keys) nil)))
- (cond ((commandp fcn)
- (setq this-command fcn))
- (t nil)))
- )
-
-(defun semantic-complete-post-command-hook ()
- "Used to determine if we need to exit inline completion mode.
-If completion mode is active, check to see if we are within
-the bounds of `semantic-complete-inline-overlay', or within
-a reasonable distance."
- (condition-case nil
- ;; Exit if something bad happened.
- (if (not semantic-complete-inline-overlay)
- (progn
- ;;(message "Inline Hook installed, but overlay deleted.")
- (semantic-complete-inline-exit))
- ;; Exit if commands caused us to exit the area of interest
- (let ((os (overlay-get semantic-complete-inline-overlay 'semantic-original-start))
- (s (overlay-start semantic-complete-inline-overlay))
- (e (overlay-end semantic-complete-inline-overlay))
- (b (overlay-buffer semantic-complete-inline-overlay))
- (txt nil)
- )
- (cond
- ;; EXIT when we are no longer in a good place.
- ((or (not (eq b (current-buffer)))
- (< (point) s)
- (< (point) os)
- (> (point) e)
- )
- ;;(message "Exit: %S %S %S" s e (point))
- (semantic-complete-inline-exit)
- )
- ;; Exit if the user typed in a character that is not part
- ;; of the symbol being completed.
- ((and (setq txt (semantic-completion-text))
- (not (string= txt ""))
- (and (/= (point) s)
- (save-excursion
- (forward-char -1)
- (not (looking-at "\\(\\w\\|\\s_\\)")))))
- ;;(message "Non symbol character.")
- (semantic-complete-inline-exit))
- ((lookup-key semantic-complete-inline-map
- (this-command-keys) nil)
- ;; If the last command was one of our completion commands,
- ;; then do nothing.
- nil
- )
- (t
- ;; Else, show completions now
- (semantic-complete-inline-force-display)
- ))))
- ;; If something goes terribly wrong, clean up after ourselves.
- (error (semantic-complete-inline-exit))))
-
-(defun semantic-complete-inline-force-display ()
- "Force the display of whatever the current completions are.
-DO NOT CALL THIS IF THE INLINE COMPLETION ENGINE IS NOT ACTIVE."
- (condition-case e
- (save-excursion
- (let ((collector semantic-completion-collector-engine)
- (displayer semantic-completion-display-engine)
- (contents (semantic-completion-text)))
- (when collector
- (semantic-collector-calculate-completions
- collector contents nil)
- (semantic-displayer-set-completions
- displayer
- (semantic-collector-all-completions collector contents)
- contents)
- ;; Ask the displayer to display them.
- (semantic-displayer-show-request displayer))
- ))
- (error (message "Bug Showing Completions: %S" e))))
-
-(defun semantic-complete-inline-tag-engine
- (collector displayer buffer start end)
- "Perform completion based on semantic tags in a buffer.
-Argument COLLECTOR is an object which can be used to calculate
-a list of possible hits. See `semantic-completion-collector-engine'
-for details on COLLECTOR.
-Argument DISPLAYER is an object used to display a list of possible
-completions for a given prefix. See `semantic-completion-display-engine'
-for details on DISPLAYER.
-BUFFER is the buffer in which completion will take place.
-START is a location for the start of the full symbol.
-If the symbol being completed is \"foo.ba\", then START
-is on the \"f\" character.
-END is at the end of the current symbol being completed."
- ;; Set us up for doing completion
- (setq semantic-completion-collector-engine collector
- semantic-completion-display-engine displayer)
- ;; Create an overlay
- (setq semantic-complete-inline-overlay
- (make-overlay start end buffer nil t))
- (overlay-put semantic-complete-inline-overlay
- 'face
- 'semantic-complete-inline-face)
- (overlay-put semantic-complete-inline-overlay
- 'window-config-start
- (current-window-configuration))
- ;; Save the original start. We need to exit completion if START
- ;; moves.
- (overlay-put semantic-complete-inline-overlay
- 'semantic-original-start start)
- ;; Install our command hooks
- (add-hook 'pre-command-hook #'semantic-complete-pre-command-hook)
- (add-hook 'post-command-hook #'semantic-complete-post-command-hook)
- ;; Go!
- (semantic-complete-inline-force-display)
- )
-
-;;; Inline Completion Keymap Functions
-;;
-(defun semantic-complete-inline-TAB ()
- "Perform inline completion."
- (interactive)
- (let ((cmpl (semantic-complete-do-completion nil t)))
- (cond
- ((eq cmpl 'complete)
- (semantic-complete-inline-force-display))
- ((eq cmpl 'done)
- (semantic-complete-inline-done))
- ))
- )
-
-(defun semantic-complete-inline-down()
- "Focus forwards through the displayer."
- (interactive)
- (let ((displayer semantic-completion-display-engine))
- (semantic-displayer-focus-next displayer)
- (semantic-displayer-focus-request displayer)
- ))
-
-(defun semantic-complete-inline-up ()
- "Focus backwards through the displayer."
- (interactive)
- (let ((displayer semantic-completion-display-engine))
- (semantic-displayer-focus-previous displayer)
- (semantic-displayer-focus-request displayer)
- ))
-
-\f
-;;; ------------------------------------------------------------
-;;; Interactions between collection and displaying
-;;
-;; Functional routines used to help collectors communicate with
-;; the current displayer, or for the previous section.
-
-(defun semantic-complete-next-action (partial)
- "Determine what the next completion action should be.
-PARTIAL is non-nil if we are doing partial completion.
-First, the collector can determine if we should perform a completion or not.
-If there is nothing to complete, then the displayer determines if we are
-to show a completion list, scroll, or perhaps do a focus (if it is capable.)
-Expected return values are:
- done -> We have a singular match
- empty -> There are no matches to the current text
- complete -> Perform a completion action
- complete-whitespace -> Complete next whitespace type character.
- display -> Show the list of completions
- scroll -> The completions have been shown, and the user keeps hitting
- the complete button. If possible, scroll the completions
- focus -> The displayer knows how to shift focus among possible completions.
- Let it do that.
- displayend -> Whatever options the displayer had for repeating options, there
- are none left. Try something new."
- (let ((ans1 (semantic-collector-next-action
- semantic-completion-collector-engine
- partial))
- (ans2 (semantic-displayer-next-action
- semantic-completion-display-engine))
- )
- (cond
- ;; No collector answer, use displayer answer.
- ((not ans1)
- ans2)
- ;; Displayer selection of 'scroll, 'display, or 'focus trumps
- ;; 'done
- ((and (eq ans1 'done) ans2)
- ans2)
- ;; Use ans1 when we have it.
- (t
- ans1))))
-
-
-\f
-;;; ------------------------------------------------------------
-;;; Collection Engines
-;;
-;; Collection engines can scan tags from the current environment and
-;; provide lists of possible completions.
-;;
-;; General features of the abstract collector:
-;; * Cache completion lists between uses
-;; * Cache itself per buffer. Handle reparse hooks
-;;
-;; Key Interface Functions to implement:
-;; * semantic-collector-next-action
-;; * semantic-collector-calculate-completions
-;; * semantic-collector-try-completion
-;; * semantic-collector-all-completions
-
-(defvar-local semantic-collector-per-buffer-list nil
- "List of collectors active in this buffer.")
-
-(defvar semantic-collector-list nil
- "List of global collectors active this session.")
-
-(defclass semantic-collector-abstract ()
- ((buffer :initarg :buffer
- :type buffer
- :documentation "Originating buffer for this collector.
-Some collectors use a given buffer as a starting place while looking up
-tags.")
- (cache :initform nil
- :type (or null semanticdb-find-result-with-nil)
- :documentation "Cache of tags.
-These tags are re-used during a completion session.
-Sometimes these tags are cached between completion sessions.")
- (last-all-completions :initarg nil
- :type semanticdb-find-result-with-nil
- :documentation "Last result of `all-completions'.
-This result can be used for refined completions as `last-prefix' gets
-closer to a specific result.")
- (last-prefix :type string
- :protection :protected
- :documentation "The last queried prefix.
-This prefix can be used to cache intermediate completion offers.
-making the action of homing in on a token faster.")
- (last-completion :type (or null string)
- :documentation "The last calculated completion.
-This completion is calculated and saved for future use.")
- (last-whitespace-completion :type (or null string)
- :documentation "The last whitespace completion.
-For partial completion, SPC will disambiguate over whitespace type
-characters. This is the last calculated version.")
- (current-exact-match :type list
- :protection :protected
- :documentation "The list of matched tags.
-When tokens are matched, they are added to this list.")
- )
- "Root class for completion engines.
-The baseclass provides basic functionality for interacting with
-a completion displayer object, and tracking the current progress
-of a completion."
- :abstract t)
-
-;;; Smart completion collector
-(defclass semantic-collector-analyze-completions (semantic-collector-abstract)
- ((context :initarg :context
- :type semantic-analyze-context
- :documentation "An analysis context.
-Specifies some context location from whence completion lists will be drawn."
- )
- (first-pass-completions :type list
- :documentation "List of valid completion tags.
-This list of tags is generated when completion starts. All searches
-derive from this list.")
- )
- "Completion engine that uses the context analyzer to provide options.
-The only options available for completion are those which can be logically
-inserted into the current context.")
-
-(cl-defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-analyze-completions) prefix _completionlist)
- "Calculate the completions for prefix from COMPLETIONLIST."
- ;; if there are no completions yet, calculate them.
- (if (not (slot-boundp obj 'first-pass-completions))
- (oset obj first-pass-completions
- (semantic-analyze-possible-completions (oref obj context))))
- ;; search our cached completion list. make it look like a semanticdb
- ;; results type.
- (list (cons (with-current-buffer (oref (oref obj context) buffer)
- semanticdb-current-table)
- (semantic-find-tags-for-completion
- prefix
- (oref obj first-pass-completions)))))
-
-(cl-defmethod semantic-collector-cleanup ((_obj semantic-collector-abstract))
- "Clean up any mess this collector may have."
- nil)
-
-(cl-defmethod semantic-collector-next-action
- ((obj semantic-collector-abstract) partial)
- "What should we do next? OBJ can be used to determine the next action.
-PARTIAL indicates if we are doing a partial completion."
- (if (and (slot-boundp obj 'last-completion)
- (string= (semantic-completion-text) (oref obj last-completion)))
- (let* ((cem (semantic-collector-current-exact-match obj))
- (cemlen (semanticdb-find-result-length cem))
- (cac (semantic-collector-all-completions
- obj (semantic-completion-text)))
- (caclen (semanticdb-find-result-length cac)))
- (cond ((and cem (= cemlen 1)
- cac (> caclen 1)
- (eq last-command this-command))
- ;; Defer to the displayer...
- nil)
- ((and cem (= cemlen 1))
- 'done)
- ((and (not cem) (not cac))
- 'empty)
- ((and partial (semantic-collector-try-completion-whitespace
- obj (semantic-completion-text)))
- 'complete-whitespace)))
- 'complete))
-
-(cl-defmethod semantic-collector-last-prefix= ((obj semantic-collector-abstract)
- last-prefix)
- "Return non-nil if OBJ's prefix matches PREFIX."
- (and (slot-boundp obj 'last-prefix)
- (string= (oref obj last-prefix) last-prefix)))
-
-(cl-defmethod semantic-collector-get-cache ((obj semantic-collector-abstract))
- "Get the raw cache of tags for completion.
-Calculate the cache if there isn't one."
- (or (oref obj cache)
- (semantic-collector-calculate-cache obj)))
-
-(cl-defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-abstract) prefix completionlist)
- "Calculate the completions for prefix from completionlist.
-Output must be in semanticdb Find result format."
- ;; Must output in semanticdb format
- (unless completionlist
- (setq completionlist
- (or (oref obj cache)
- (semantic-collector-calculate-cache obj))))
- (let ((table (with-current-buffer (oref obj buffer)
- semanticdb-current-table))
- (result (semantic-find-tags-for-completion
- prefix
- ;; To do this kind of search with a pre-built completion
- ;; list, we need to strip it first.
- (semanticdb-strip-find-results completionlist))))
- (if result
- (list (cons table result)))))
-
-(cl-defmethod semantic-collector-calculate-completions
- ((obj semantic-collector-abstract) prefix _partial)
- "Calculate completions for prefix as setup for other queries."
- (let* ((case-fold-search semantic-case-fold)
- (same-prefix-p (semantic-collector-last-prefix= obj prefix))
- (last-prefix (and (slot-boundp obj 'last-prefix)
- (oref obj last-prefix)))
- (completionlist
- (cond ((or same-prefix-p
- (and last-prefix (string-prefix-p last-prefix prefix t)))
- ;; We have the same prefix, or last-prefix is a
- ;; substring of the of new prefix, in which case we are
- ;; refining our symbol so just reuse cache.
- (oref obj last-all-completions))
- ((and last-prefix
- (> (length prefix) 1)
- (string-prefix-p prefix last-prefix t))
- ;; The new prefix is a substring of the old
- ;; prefix, and it's longer than one character.
- ;; Perform a full search to pull in additional
- ;; matches.
- (let ((context (semantic-analyze-current-context (point))))
- ;; Set new context and make first-pass-completions
- ;; unbound so that they are newly calculated.
- (oset obj context context)
- (when (slot-boundp obj 'first-pass-completions)
- (slot-makeunbound obj 'first-pass-completions)))
- nil)))
- ;; Get the result
- (answer (if same-prefix-p
- completionlist
- (semantic-collector-calculate-completions-raw
- obj prefix completionlist)))
- (completion nil)
- (complete-not-uniq nil)
- )
- ;;(semanticdb-find-result-test answer)
- (when (not same-prefix-p)
- ;; Save results if it is interesting and beneficial
- (oset obj last-prefix prefix)
- (oset obj last-all-completions answer))
- ;; Now calculate the completion.
- (setq completion (try-completion
- prefix
- (semanticdb-strip-find-results answer)))
- (oset obj last-whitespace-completion nil)
- (oset obj current-exact-match nil)
- ;; Only do this if a completion was found. Letting a nil in
- ;; could cause a full semanticdb search by accident.
- (when completion
- (oset obj last-completion
- (cond
- ;; Unique match in AC. Last completion is a match.
- ;; Also set the current-exact-match.
- ((eq completion t)
- (oset obj current-exact-match answer)
- prefix)
- ;; It may be complete (a symbol) but still not unique.
- ;; We can capture a match
- ((setq complete-not-uniq
- (semanticdb-find-tags-by-name
- prefix
- answer))
- (oset obj current-exact-match
- complete-not-uniq)
- prefix
- )
- ;; Non unique match, return the string that handles
- ;; completion
- (t (or completion prefix))
- )))
- ))
-
-(cl-defmethod semantic-collector-try-completion-whitespace
- ((obj semantic-collector-abstract) prefix)
- "For OBJ, do whitespace completion based on PREFIX.
-This implies that if there are two completions, one matching
-the test \"prefix\\>\", and one not, the one matching the full
-word version of PREFIX will be chosen, and that text returned.
-This function requires that `semantic-collector-calculate-completions'
-has been run first."
- (let* ((ac (semantic-collector-all-completions obj prefix))
- (matchme (concat "^" prefix "\\>"))
- (compare (semanticdb-find-tags-by-name-regexp matchme ac))
- (numtag (semanticdb-find-result-length compare))
- )
- (if compare
- (let* ((idx 0)
- (cutlen (1+ (length prefix)))
- (twws (semanticdb-find-result-nth compare idx)))
- ;; Is our tag with whitespace a match that has whitespace
- ;; after it, or just an already complete symbol?
- (while (and (< idx numtag)
- (< (length (semantic-tag-name (car twws))) cutlen))
- (setq idx (1+ idx)
- twws (semanticdb-find-result-nth compare idx)))
- (when (and twws (car-safe twws))
- ;; If COMPARE has succeeded, then we should take the very
- ;; first match, and extend prefix by one character.
- (oset obj last-whitespace-completion
- (substring (semantic-tag-name (car twws))
- 0 cutlen))))
- )))
-
-
-(cl-defmethod semantic-collector-current-exact-match ((obj semantic-collector-abstract))
- "Return the active valid MATCH from the semantic collector.
-For now, just return the first element from our list of available
-matches. For semanticdb based results, make sure the file is loaded
-into a buffer."
- (when (slot-boundp obj 'current-exact-match)
- (oref obj current-exact-match)))
-
-(cl-defmethod semantic-collector-current-whitespace-completion ((obj semantic-collector-abstract))
- "Return the active whitespace completion value."
- (when (slot-boundp obj 'last-whitespace-completion)
- (oref obj last-whitespace-completion)))
-
-(cl-defmethod semantic-collector-get-match ((obj semantic-collector-abstract))
- "Return the active valid MATCH from the semantic collector.
-For now, just return the first element from our list of available
-matches. For semanticdb based results, make sure the file is loaded
-into a buffer."
- (when (slot-boundp obj 'current-exact-match)
- (semanticdb-find-result-nth-in-buffer (oref obj current-exact-match) 0)))
-
-(cl-defmethod semantic-collector-all-completions
- ((obj semantic-collector-abstract) _prefix)
- "For OBJ, retrieve all completions matching PREFIX.
-The returned list consists of all the tags currently
-matching PREFIX."
- (when (slot-boundp obj 'last-all-completions)
- (oref obj last-all-completions)))
-
-(cl-defmethod semantic-collector-try-completion
- ((obj semantic-collector-abstract) _prefix)
- "For OBJ, attempt to match PREFIX.
-See `try-completion' for details on how this works.
-Return nil for no match.
-Return a string for a partial match.
-For a unique match of PREFIX, return the list of all tags
-with that name."
- (if (slot-boundp obj 'last-completion)
- (oref obj last-completion)))
-
-(cl-defmethod semantic-collector-calculate-cache
- ((_obj semantic-collector-abstract))
- "Calculate the completion cache for OBJ."
- nil
- )
-
-(cl-defmethod semantic-collector-flush ((this semantic-collector-abstract))
- "Flush THIS collector object, clearing any caches and prefix."
- (oset this cache nil)
- (slot-makeunbound this 'last-prefix)
- (slot-makeunbound this 'last-completion)
- (slot-makeunbound this 'last-all-completions)
- (slot-makeunbound this 'current-exact-match)
- )
-
-;;; PER BUFFER
-;;
-(defclass semantic-collector-buffer-abstract (semantic-collector-abstract)
- ()
- "Root class for per-buffer completion engines.
-These collectors track themselves on a per-buffer basis."
- :abstract t)
-
-(cl-defmethod make-instance ((this (subclass semantic-collector-buffer-abstract))
- &rest _args)
- "Reuse previously created objects of this type in buffer."
- (let ((old nil)
- (bl semantic-collector-per-buffer-list))
- (while (and bl (null old))
- (if (eq (eieio-object-class (car bl)) this)
- (setq old (car bl))))
- (unless old
- (let ((new (cl-call-next-method)))
- (add-to-list 'semantic-collector-per-buffer-list new)
- (setq old new)))
- (slot-makeunbound old 'last-completion)
- (slot-makeunbound old 'last-prefix)
- (slot-makeunbound old 'current-exact-match)
- old))
-
-;; Buffer specific collectors should flush themselves
-(defun semantic-collector-buffer-flush (_newcache)
- "Flush all buffer collector objects.
-NEWCACHE is the new tag table, but we ignore it."
- (condition-case nil
- (let ((l semantic-collector-per-buffer-list))
- (while l
- (if (car l) (semantic-collector-flush (car l)))
- (setq l (cdr l))))
- (error nil)))
-
-(add-hook 'semantic-after-toplevel-cache-change-hook
- #'semantic-collector-buffer-flush)
-
-;;; DEEP BUFFER SPECIFIC COMPLETION
-;;
-(defclass semantic-collector-buffer-deep
- (semantic-collector-buffer-abstract)
- ()
- "Completion engine for tags in the current buffer.
-When searching for a tag, uses semantic deep search functions.
-Basics search only in the current buffer.")
-
-(cl-defmethod semantic-collector-calculate-cache
- ((obj semantic-collector-buffer-deep))
- "Calculate the completion cache for OBJ.
-Uses `semantic-flatten-tags-table'."
- (oset obj cache
- ;; Must create it in SEMANTICDB find format.
- ;; ( ( DBTABLE TAG TAG ... ) ... )
- (list
- (cons semanticdb-current-table
- (semantic-flatten-tags-table (oref obj buffer))))))
-
-;;; PROJECT SPECIFIC COMPLETION
-;;
-(defclass semantic-collector-project-abstract (semantic-collector-abstract)
- ((path :initarg :path
- :initform nil
- :documentation "List of database tables to search.
-At creation time, it can be anything accepted by
-`semanticdb-find-translate-path' as a PATH argument.")
- )
- "Root class for project wide completion engines.
-Uses semanticdb for searching all tags in the current project."
- :abstract t)
-
-;;; Project Search
-(defclass semantic-collector-project (semantic-collector-project-abstract)
- ()
- "Completion engine for tags in a project.")
-
-
-(cl-defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-project) prefix _completionlist)
- "Calculate the completions for prefix from COMPLETIONLIST."
- (semanticdb-find-tags-for-completion prefix (oref obj path)))
-
-;;; Brutish Project search
-(defclass semantic-collector-project-brutish (semantic-collector-project-abstract)
- ()
- "Completion engine for tags in a project.")
-
-(declare-function semanticdb-brute-deep-find-tags-for-completion
- "semantic/db-find")
-
-(cl-defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-project-brutish) prefix _completionlist)
- "Calculate the completions for prefix from COMPLETIONLIST."
- (require 'semantic/db-find)
- (semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path)))
-
-;;; Current Datatype member search.
-(defclass semantic-collector-local-members (semantic-collector-project-abstract)
- ((scope :initform nil
- :type (or null semantic-scope-cache)
- :documentation
- "The scope the local members are being completed from."))
- "Completion engine for tags in a project.")
-
-(cl-defmethod semantic-collector-calculate-completions-raw
- ((obj semantic-collector-local-members) prefix _completionlist)
- "Calculate the completions for prefix from COMPLETIONLIST."
- (let* ((scope (or (oref obj scope)
- (oset obj scope (semantic-calculate-scope))))
- (localstuff (oref scope scope)))
- (list
- (cons
- (oref scope table)
- (semantic-find-tags-for-completion prefix localstuff)))))
- ;(semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path))))
-
-\f
-;;; ------------------------------------------------------------
-;;; Tag List Display Engines
-;;
-;; A typical displayer accepts a pre-determined list of completions
-;; generated by a collector. This format is in semanticdb search
-;; form. This vaguely standard form is a bit challenging to navigate
-;; because the tags do not contain buffer info, but the file associated
-;; with the tags precedes the tag in the list.
-;;
-;; Basic displayers don't care, and can strip the results.
-;; Advanced highlighting displayers need to know when they need
-;; to load a file so that the tag in question can be highlighted.
-;;
-;; Key interface methods to a displayer are:
-;; * semantic-displayer-next-action
-;; * semantic-displayer-set-completions
-;; * semantic-displayer-current-focus
-;; * semantic-displayer-show-request
-;; * semantic-displayer-scroll-request
-;; * semantic-displayer-focus-request
-
-(define-obsolete-function-alias 'semantic-displayor-cleanup
- #'semantic-displayer-cleanup "27.1")
-(cl-defmethod semantic-displayer-cleanup ((_obj semantic-displayer-abstract))
- "Clean up any mess this displayer may have."
- nil)
-
-(define-obsolete-function-alias 'semantic-displayor-next-action
- #'semantic-displayer-next-action "27.1")
-(cl-defmethod semantic-displayer-next-action ((obj semantic-displayer-abstract))
- "The next action to take on the minibuffer related to display."
- (if (and (slot-boundp obj 'last-prefix)
- (or (eq this-command 'semantic-complete-inline-TAB)
- (and (string= (oref obj last-prefix) (semantic-completion-text))
- (eq last-command this-command))))
- 'scroll
- 'display))
-
-(define-obsolete-function-alias 'semantic-displayor-set-completions
- #'semantic-displayer-set-completions "27.1")
-(cl-defmethod semantic-displayer-set-completions ((obj semantic-displayer-abstract)
- table prefix)
- "Set the list of tags to be completed over to TABLE."
- (oset obj table table)
- (oset obj last-prefix prefix))
-
-(define-obsolete-function-alias 'semantic-displayor-show-request
- #'semantic-displayer-show-request "27.1")
-(cl-defmethod semantic-displayer-show-request ((_obj semantic-displayer-abstract))
- "A request to show the current tags table."
- (ding))
-
-(define-obsolete-function-alias 'semantic-displayor-focus-request
- #'semantic-displayer-focus-request "27.1")
-(cl-defmethod semantic-displayer-focus-request ((_obj semantic-displayer-abstract))
- "A request to for the displayer to focus on some tag option."
- (ding))
-
-(define-obsolete-function-alias 'semantic-displayor-scroll-request
- #'semantic-displayer-scroll-request "27.1")
-(cl-defmethod semantic-displayer-scroll-request ((_obj semantic-displayer-abstract))
- "A request to for the displayer to scroll the completion list (if needed)."
- (scroll-other-window))
-
-(define-obsolete-function-alias 'semantic-displayor-focus-previous
- #'semantic-displayer-focus-previous "27.1")
-(cl-defmethod semantic-displayer-focus-previous ((_obj semantic-displayer-abstract))
- "Set the current focus to the previous item."
- nil)
-
-(define-obsolete-function-alias 'semantic-displayor-focus-next
- #'semantic-displayer-focus-next "27.1")
-(cl-defmethod semantic-displayer-focus-next ((_obj semantic-displayer-abstract))
- "Set the current focus to the next item."
- nil)
-
-(define-obsolete-function-alias 'semantic-displayor-current-focus
- #'semantic-displayer-current-focus "27.1")
-(cl-defmethod semantic-displayer-current-focus ((_obj semantic-displayer-abstract))
- "Return a single tag currently in focus.
-This object type doesn't do focus, so will never have a focus object."
- nil)
-
-
-;; Traditional displayer
-(defcustom semantic-completion-displayer-format-tag-function
- #'semantic-format-tag-name
- "A Tag format function to use when showing completions."
- :group 'semantic
- :type semantic-format-tag-custom-list)
-
-(defclass semantic-displayer-traditional (semantic-displayer-abstract)
- ()
- "Display options in *Completions* buffer.
-Traditional display mechanism for a list of possible completions.
-Completions are shown in a new buffer and listed with the ability
-to click on the items to aid in completion.")
-
-(define-obsolete-function-alias 'semantic-displayor-show-request
- #'semantic-displayer-show-request "27.1")
-(cl-defmethod semantic-displayer-show-request ((obj semantic-displayer-traditional))
- "A request to show the current tags table."
-
- ;; NOTE TO SELF. Find the character to type next, and emphasize it.
-
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list
- (mapcar semantic-completion-displayer-format-tag-function
- (semanticdb-strip-find-results (oref obj table))))
- )
- )
-
-;;; Methods for any displayer which supports focus
-
-(define-obsolete-function-alias 'semantic-displayor-next-action
- #'semantic-displayer-next-action "27.1")
-(cl-defmethod semantic-displayer-next-action ((obj semantic-displayer-focus-abstract))
- "The next action to take on the minibuffer related to display."
- (if (and (slot-boundp obj 'last-prefix)
- (string= (oref obj last-prefix) (semantic-completion-text))
- (eq last-command this-command))
- (if (and
- (slot-boundp obj 'focus)
- (slot-boundp obj 'table)
- (<= (semanticdb-find-result-length (oref obj table))
- (1+ (oref obj focus))))
- ;; We are at the end of the focus road.
- 'displayend
- ;; Focus on some item.
- 'focus)
- 'display))
-
-(define-obsolete-function-alias 'semantic-displayor-set-completions
- #'semantic-displayer-set-completions "27.1")
-(cl-defmethod semantic-displayer-set-completions ((obj semantic-displayer-focus-abstract)
- _table _prefix)
- "Set the list of tags to be completed over to TABLE."
- (cl-call-next-method)
- (slot-makeunbound obj 'focus))
-
-(define-obsolete-function-alias 'semantic-displayor-focus-previous
- #'semantic-displayer-focus-previous "27.1")
-(cl-defmethod semantic-displayer-focus-previous ((obj semantic-displayer-focus-abstract))
- "Set the current focus to the previous item.
-Not meaningful return value."
- (when (and (slot-boundp obj 'table) (oref obj table))
- (with-slots (table) obj
- (if (or (not (slot-boundp obj 'focus))
- (<= (oref obj focus) 0))
- (oset obj focus (1- (semanticdb-find-result-length table)))
- (oset obj focus (1- (oref obj focus)))
- )
- )))
-
-(define-obsolete-function-alias 'semantic-displayor-focus-next
- #'semantic-displayer-focus-next "27.1")
-(cl-defmethod semantic-displayer-focus-next ((obj semantic-displayer-focus-abstract))
- "Set the current focus to the next item.
-Not meaningful return value."
- (when (and (slot-boundp obj 'table) (oref obj table))
- (with-slots (table) obj
- (if (not (slot-boundp obj 'focus))
- (oset obj focus 0)
- (oset obj focus (1+ (oref obj focus)))
- )
- (if (<= (semanticdb-find-result-length table) (oref obj focus))
- (oset obj focus 0))
- )))
-
-(define-obsolete-function-alias 'semantic-displayor-focus-tag
- #'semantic-displayer-focus-tag "27.1")
-(cl-defmethod semantic-displayer-focus-tag ((obj semantic-displayer-focus-abstract))
- "Return the next tag OBJ should focus on."
- (when (and (slot-boundp obj 'table) (oref obj table))
- (with-slots (table) obj
- (semanticdb-find-result-nth table (oref obj focus)))))
-
-(define-obsolete-function-alias 'semantic-displayor-current-focus
- #'semantic-displayer-current-focus "27.1")
-(cl-defmethod semantic-displayer-current-focus ((obj semantic-displayer-focus-abstract))
- "Return the tag currently in focus, or call parent method."
- (if (and (slot-boundp obj 'focus)
- (slot-boundp obj 'table)
- ;; Only return the current focus IFF the minibuffer reflects
- ;; the list this focus was derived from.
- (slot-boundp obj 'last-prefix)
- (string= (semantic-completion-text) (oref obj last-prefix))
- )
- ;; We need to focus
- (if (oref obj find-file-focus)
- (semanticdb-find-result-nth-in-buffer (oref obj table) (oref obj focus))
- ;; result-nth returns a cons with car being the tag, and cdr the
- ;; database.
- (car (semanticdb-find-result-nth (oref obj table) (oref obj focus))))
- ;; Do whatever
- (cl-call-next-method)))
-
-;;; Simple displayer which performs traditional display completion,
-;; and also focuses with highlighting.
-(defclass semantic-displayer-traditional-with-focus-highlight
- (semantic-displayer-focus-abstract semantic-displayer-traditional)
- ((find-file-focus :initform t))
- "Display completions in *Completions* buffer, with focus highlight.
-A traditional displayer which can focus on a tag by showing it.
-Same as `semantic-displayer-traditional', but with selection between
-multiple tags with the same name done by focusing on the source
-location of the different tags to differentiate them.")
-
-(define-obsolete-function-alias 'semantic-displayor-focus-request
- #'semantic-displayer-focus-request "27.1")
-(cl-defmethod semantic-displayer-focus-request
- ((obj semantic-displayer-traditional-with-focus-highlight))
- "Focus in on possible tag completions.
-Focus is performed by cycling through the tags and highlighting
-one in the source buffer."
- (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
- (focus (semantic-displayer-focus-tag obj))
- ;; Raw tag info.
- (rtag (car focus))
- (rtable (cdr focus))
- ;; Normalize
- (nt (semanticdb-normalize-one-tag rtable rtag))
- (tag (cdr nt))
- (table (car nt))
- (curwin (selected-window)))
- ;; If we fail to normalize, reset.
- (when (not tag) (setq table rtable tag rtag))
- ;; Do the focus.
- (let ((buf (or (semantic-tag-buffer tag)
- (and table (semanticdb-get-buffer table)))))
- ;; If no buffer is provided, then we can make up a summary buffer.
- (when (not buf)
- (with-current-buffer (get-buffer-create "*Completion Focus*")
- (erase-buffer)
- (insert "Focus on tag: \n")
- (insert (semantic-format-tag-summarize tag nil t) "\n\n")
- (when table
- (insert "From table: \n")
- (insert (eieio-object-name table) "\n\n"))
- (when buf
- (insert "In buffer: \n\n")
- (insert (format "%S" buf)))
- (setq buf (current-buffer))))
- ;; Show the tag in the buffer.
- (if (get-buffer-window buf)
- (select-window (get-buffer-window buf))
- (switch-to-buffer-other-window buf t)
- (select-window (get-buffer-window buf)))
- ;; Now do some positioning
- (when (semantic-tag-with-position-p tag)
- ;; Full tag positional information available
- (goto-char (semantic-tag-start tag))
- ;; This avoids a dangerous problem if we just loaded a tag
- ;; from a file, but the original position was not updated
- ;; in the TAG variable we are currently using.
- (semantic-momentary-highlight-tag (semantic-current-tag)))
- (select-window curwin)
- ;; Calculate text difference between contents and the focus item.
- (let* ((mbc (semantic-completion-text))
- (ftn (semantic-tag-name tag))
- (diff (substring ftn (length mbc))))
- (semantic-completion-message
- (format "%s [%d of %d matches]" diff (1+ (oref obj focus)) tablelength)))
- )))
-
-\f
-;;; Tooltip completion lister
-;;
-;; Written and contributed by Masatake YAMATO <yamato@redhat.com>
-;;
-;; Modified by Eric Ludlam for
-;; * Safe compatibility for tooltip free systems.
-;; * Don't use 'avoid package for tooltip positioning.
-
-;;;###autoload
-(defcustom semantic-displayer-tooltip-mode 'standard
- "Mode for the tooltip inline completion.
-
-Standard: Show only `semantic-displayer-tooltip-initial-max-tags'
-number of completions initially. Pressing TAB will show the
-extended set.
-
-Quiet: Only show completions when we have narrowed all
-possibilities down to a maximum of
-`semantic-displayer-tooltip-initial-max-tags' tags. Pressing TAB
-multiple times will also show completions.
-
-Verbose: Always show all completions available.
-
-The absolute maximum number of completions for all mode is
-determined through `semantic-displayer-tooltip-max-tags'."
- :group 'semantic
- :version "24.3"
- :type '(choice (const :tag "Standard" standard)
- (const :tag "Quiet" quiet)
- (const :tag "Verbose" verbose)))
-
-;;;###autoload
-(defcustom semantic-displayer-tooltip-initial-max-tags 5
- "Maximum number of tags to be displayed initially.
-See doc-string of `semantic-displayer-tooltip-mode' for details."
- :group 'semantic
- :version "24.3"
- :type 'integer)
-
-(defcustom semantic-displayer-tooltip-max-tags 25
- "The maximum number of tags to be displayed.
-Maximum number of completions where we have activated the
-extended completion list through typing TAB or SPACE multiple
-times. This limit needs to fit on your screen!
-
-Note: If available, customizing this variable increases
-`x-max-tooltip-size' to force over-sized tooltips when necessary.
-This will not happen if you directly set this variable via `setq'."
- :group 'semantic
- :version "24.3"
- :type 'integer
- :set (lambda (sym var)
- (set-default sym var)
- (when (boundp 'x-max-tooltip-size)
- (if (not (consp x-max-tooltip-size))
- (setq x-max-tooltip-size '(80 . 40)))
- (setcdr x-max-tooltip-size
- (max (1+ var) (cdr x-max-tooltip-size))))))
-
-(defclass semantic-displayer-tooltip (semantic-displayer-traditional)
- ((mode :initarg :mode
- :initform
- (symbol-value 'semantic-displayer-tooltip-mode)
- :documentation
- "See `semantic-displayer-tooltip-mode'.")
- (max-tags-initial :initarg max-tags-initial
- :initform
- (symbol-value 'semantic-displayer-tooltip-initial-max-tags)
- :documentation
- "See `semantic-displayer-tooltip-initial-max-tags'.")
- (typing-count :type integer
- :initform 0
- :documentation
- "Counter holding how many times the user types space or tab continuously before showing tags.")
- (shown :type boolean
- :initform nil
- :documentation
- "Flag representing whether tooltip has been shown yet.")
- )
- "Display completions options in a tooltip.
-Display mechanism using tooltip for a list of possible completions.")
-
-(cl-defmethod initialize-instance :after ((_obj semantic-displayer-tooltip) &rest _args)
- "Make sure we have tooltips required."
- (require 'tooltip))
-
-(defvar tooltip-mode)
-
-(define-obsolete-function-alias 'semantic-displayor-show-request
- #'semantic-displayer-show-request "27.1")
-(cl-defmethod semantic-displayer-show-request ((obj semantic-displayer-tooltip))
- "A request to show the current tags table."
- (if (or (not (featurep 'tooltip)) (not tooltip-mode))
- ;; If we cannot use tooltips, then go to the normal mode with
- ;; a traditional completion buffer.
- (cl-call-next-method)
- (let* ((tablelong (semanticdb-strip-find-results (oref obj table)))
- (table (semantic-unique-tag-table-by-name tablelong))
- (completions (mapcar semantic-completion-displayer-format-tag-function table))
- (numcompl (length completions))
- ;; (typing-count (oref obj typing-count))
- (mode (oref obj mode))
- (max-tags (oref obj max-tags-initial))
- (matchtxt (semantic-completion-text))
- msg msg-tail)
- ;; Keep a count of the consecutive completion commands entered by the user.
- (oset obj typing-count
- (if (equal (this-command-keys) "\C-i")
- (1+ (oref obj typing-count))
- 0))
- (cond
- ((eq mode 'quiet)
- ;; Switch back to standard mode if user presses key more than 5 times.
- (when (>= (oref obj typing-count) 5)
- (oset obj mode 'standard)
- (setq mode 'standard)
- (message "Resetting inline-mode to `standard'."))
- (when (and (> numcompl max-tags)
- (< (oref obj typing-count) 2))
- ;; Discretely hint at completion availability.
- (setq msg "...")))
- ((eq mode 'verbose)
- ;; Always show extended match set.
- (oset obj max-tags-initial semantic-displayer-tooltip-max-tags)
- (setq max-tags semantic-displayer-tooltip-max-tags)))
- (unless msg
- (oset obj shown t)
- (cond
- ((> numcompl max-tags)
- ;; We have too many items, be brave and truncate 'completions'.
- (setcdr (nthcdr (1- max-tags) completions) nil)
- (if (= max-tags semantic-displayer-tooltip-initial-max-tags)
- (setq msg-tail (concat "\n[<TAB> " (number-to-string (- numcompl max-tags)) " more]"))
- (setq msg-tail (concat "\n[<n/a> " (number-to-string (- numcompl max-tags)) " more]"))
- (when (>= (oref obj typing-count) 2)
- (message "Refine search to display results beyond the `%s' limit"
- (symbol-name 'semantic-complete-inline-max-tags-extended)))))
- ((= numcompl 1)
- ;; two possible cases
- ;; 1. input text != single match - we found a unique completion!
- ;; 2. input text == single match - we found no additional matches, it's just the input text!
- (when (string= matchtxt (semantic-tag-name (car table)))
- (setq msg "[COMPLETE]\n")))
- ((zerop numcompl)
- (oset obj shown nil)
- ;; No matches, say so if in verbose mode!
- (when semantic-idle-scheduler-verbose-flag
- (setq msg "[NO MATCH]"))))
- ;; Create the tooltip text.
- (setq msg (concat msg (mapconcat #'identity completions "\n"))))
- ;; Add any tail info.
- (setq msg (concat msg msg-tail))
- ;; Display tooltip.
- (when (not (equal msg ""))
- (semantic-displayer-tooltip-show msg)))))
-
-;;; Compatibility
-;;
-
-(defun semantic-displayer-point-position ()
- "Return the location of POINT as positioned on the selected frame.
-Return a cons cell (X . Y)."
- (let* ((frame (selected-frame))
- (toolbarleft
- (if (eq (cdr (assoc 'tool-bar-position default-frame-alist)) 'left)
- (tool-bar-pixel-width)
- 0))
- (left (+ (or (car-safe (cdr-safe (frame-parameter frame 'left)))
- (frame-parameter frame 'left))
- toolbarleft))
- (top (or (car-safe (cdr-safe (frame-parameter frame 'top)))
- (frame-parameter frame 'top)))
- (point-pix-pos (posn-x-y (posn-at-point)))
- (edges (window-inside-pixel-edges (selected-window))))
- (cons (+ (car point-pix-pos) (car edges) left)
- (+ (cdr point-pix-pos) (cadr edges) top))))
-
-
-(defvar tooltip-frame-parameters)
-(declare-function tooltip-show "tooltip" (text &optional use-echo-area
- text-face default-face))
-
-(defun semantic-displayer-tooltip-show (text)
- "Display a tooltip with TEXT near cursor."
- (let ((point-pix-pos (semantic-displayer-point-position))
- (tooltip-frame-parameters
- (append tooltip-frame-parameters nil)))
- (push
- (cons 'left (+ (car point-pix-pos) (frame-char-width)))
- tooltip-frame-parameters)
- (push
- (cons 'top (+ (cdr point-pix-pos) (frame-char-height)))
- tooltip-frame-parameters)
- (tooltip-show text)))
-
-(define-obsolete-function-alias 'semantic-displayor-scroll-request
- #'semantic-displayer-scroll-request "27.1")
-(cl-defmethod semantic-displayer-scroll-request ((obj semantic-displayer-tooltip))
- "A request to for the displayer to scroll the completion list (if needed)."
- ;; Do scrolling in the tooltip.
- (oset obj max-tags-initial 30)
- (semantic-displayer-show-request obj)
- )
-
-;; End code contributed by Masatake YAMATO <yamato@redhat.com>
-
-\f
-;;; Ghost Text displayer
-;;
-(defclass semantic-displayer-ghost (semantic-displayer-focus-abstract)
-
- ((ghostoverlay :type overlay
- :documentation
- "The overlay the ghost text is displayed in.")
- (first-show :initform t
- :documentation
- "Non-nil if we have not seen our first show request.")
- )
- "Cycle completions inline with ghost text.
-Completion displayer using ghost chars after point for focus options.
-Whichever completion is currently in focus will be displayed as ghost
-text using overlay options.")
-
-(define-obsolete-function-alias 'semantic-displayor-next-action
- #'semantic-displayer-next-action "27.1")
-(cl-defmethod semantic-displayer-next-action ((obj semantic-displayer-ghost))
- "The next action to take on the inline completion related to display."
- (let ((ans (cl-call-next-method))
- (table (when (slot-boundp obj 'table)
- (oref obj table))))
- (if (and (eq ans 'displayend)
- table
- (= (semanticdb-find-result-length table) 1)
- )
- nil
- ans)))
-
-(define-obsolete-function-alias 'semantic-displayor-cleanup
- #'semantic-displayer-cleanup "27.1")
-(cl-defmethod semantic-displayer-cleanup ((obj semantic-displayer-ghost))
- "Clean up any mess this displayer may have."
- (when (slot-boundp obj 'ghostoverlay)
- (delete-overlay (oref obj ghostoverlay)))
- )
-
-(define-obsolete-function-alias 'semantic-displayor-set-completions
- #'semantic-displayer-set-completions "27.1")
-(cl-defmethod semantic-displayer-set-completions ((obj semantic-displayer-ghost)
- _table _prefix)
- "Set the list of tags to be completed over to TABLE."
- (cl-call-next-method)
- (semantic-displayer-cleanup obj))
-
-
-(define-obsolete-function-alias 'semantic-displayor-show-request
- #'semantic-displayer-show-request "27.1")
-(cl-defmethod semantic-displayer-show-request ((obj semantic-displayer-ghost))
- "A request to show the current tags table."
-; (if (oref obj first-show)
-; (progn
-; (oset obj first-show nil)
- (semantic-displayer-focus-next obj)
- (semantic-displayer-focus-request obj)
-; )
- ;; Only do the traditional thing if the first show request
- ;; has been seen. Use the first one to start doing the ghost
- ;; text display.
-; (cl-call-next-method)
-; )
-)
-
-(define-obsolete-function-alias 'semantic-displayor-focus-request
- #'semantic-displayer-focus-request "27.1")
-(cl-defmethod semantic-displayer-focus-request
- ((obj semantic-displayer-ghost))
- "Focus in on possible tag completions.
-Focus is performed by cycling through the tags and showing a possible
-completion text in ghost text."
- (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
- (focus (semantic-displayer-focus-tag obj))
- (tag (car focus))
- )
- (if (not tag)
- (semantic-completion-message "No tags to focus on.")
- ;; Display the focus completion as ghost text after the current
- ;; inline text.
- (when (or (not (slot-boundp obj 'ghostoverlay))
- (not (overlay-buffer (oref obj ghostoverlay))))
- (oset obj ghostoverlay
- (make-overlay (point) (1+ (point)) (current-buffer) t)))
-
- (let* ((lp (semantic-completion-text))
- (os (substring (semantic-tag-name tag) (length lp)))
- (ol (oref obj ghostoverlay))
- )
-
- (put-text-property 0 (length os) 'face 'region os)
-
- (overlay-put
- ol 'display (concat os (buffer-substring (point) (1+ (point)))))
- )
- ;; Calculate text difference between contents and the focus item.
- (let* ((mbc (semantic-completion-text))
- (ftn (concat (semantic-tag-name tag)))
- )
- (put-text-property (length mbc) (length ftn) 'face
- 'bold ftn)
- (semantic-completion-message
- (format "%s [%d of %d matches]" ftn (1+ (oref obj focus)) tablelength)))
- )))
-
-\f
-;;; ------------------------------------------------------------
-;;; Specific queries
-;;
-(defvar semantic-complete-inline-custom-type
- (append '(radio)
- (mapcar
- (lambda (class)
- (let* ((C (intern (car class)))
- (doc (documentation-property C 'variable-documentation))
- (doc1 (car (split-string doc "\n")))
- )
- (list 'const
- :tag doc1
- C)))
- (eieio-build-class-alist 'semantic-displayer-abstract t))
- )
- "Possible options for inline completion displayers.
-Use this to enable custom editing.")
-
-(defcustom semantic-complete-inline-analyzer-displayer-class
- 'semantic-displayer-traditional
- "Class for displayer to use with inline completion."
- :group 'semantic
- :type semantic-complete-inline-custom-type
- )
-
-(defun semantic-complete-read-tag-buffer-deep (prompt &optional
- default-tag
- initial-input
- history)
- "Ask for a tag by name from the current buffer.
-Available tags are from the current buffer, at any level.
-Completion options are presented in a traditional way, with highlighting
-to resolve same-name collisions.
-PROMPT is a string to prompt with.
-DEFAULT-TAG is a semantic tag or string to use as the default value.
-If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
-HISTORY is a symbol representing a variable to store the history in."
- (semantic-complete-read-tag-engine
- (semantic-collector-buffer-deep prompt :buffer (current-buffer))
- (semantic-displayer-traditional-with-focus-highlight)
- ;;(semantic-displayer-tooltip)
- prompt
- default-tag
- initial-input
- history)
- )
-
-(defun semantic-complete-read-tag-local-members (prompt &optional
- default-tag
- initial-input
- history)
- "Ask for a tag by name from the local type members.
-Available tags are from the current scope.
-Completion options are presented in a traditional way, with highlighting
-to resolve same-name collisions.
-PROMPT is a string to prompt with.
-DEFAULT-TAG is a semantic tag or string to use as the default value.
-If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
-HISTORY is a symbol representing a variable to store the history in."
- (semantic-complete-read-tag-engine
- (semantic-collector-local-members prompt :buffer (current-buffer))
- (semantic-displayer-traditional-with-focus-highlight)
- ;;(semantic-displayer-tooltip)
- prompt
- default-tag
- initial-input
- history)
- )
-
-(defun semantic-complete-read-tag-project (prompt &optional
- default-tag
- initial-input
- history)
- "Ask for a tag by name from the current project.
-Available tags are from the current project, at the top level.
-Completion options are presented in a traditional way, with highlighting
-to resolve same-name collisions.
-PROMPT is a string to prompt with.
-DEFAULT-TAG is a semantic tag or string to use as the default value.
-If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
-HISTORY is a symbol representing a variable to store the history in."
- (semantic-complete-read-tag-engine
- (semantic-collector-project-brutish prompt
- :buffer (current-buffer)
- :path (current-buffer)
- )
- (semantic-displayer-traditional-with-focus-highlight)
- prompt
- default-tag
- initial-input
- history)
- )
-
-(defun semantic-complete-inline-tag-project ()
- "Complete a symbol name by name from within the current project.
-This is similar to `semantic-complete-read-tag-project', except
-that the completion interaction is in the buffer where the context
-was calculated from.
-Customize `semantic-complete-inline-analyzer-displayer-class'
-to control how completion options are displayed.
-See `semantic-complete-inline-tag-engine' for details on how
-completion works."
- (let* ((collector (semantic-collector-project-brutish
- :buffer (current-buffer)
- :path (current-buffer)))
- (sbounds (semantic-ctxt-current-symbol-and-bounds))
- (syms (car sbounds))
- (start (car (nth 2 sbounds)))
- (end (cdr (nth 2 sbounds)))
- (rsym (reverse syms))
- (thissym (nth 1 sbounds))
- (nextsym (car-safe (cdr rsym)))
- (complst nil))
- (when (and thissym (or (not (string= thissym ""))
- nextsym))
- ;; Do a quick calculation of completions.
- (semantic-collector-calculate-completions
- collector thissym nil)
- ;; Get the master list
- (setq complst (semanticdb-strip-find-results
- (semantic-collector-all-completions collector thissym)))
- ;; Shorten by name
- (setq complst (semantic-unique-tag-table-by-name complst))
- (if (or (and (= (length complst) 1)
- ;; Check to see if it is the same as what is there.
- ;; if so, we can offer to complete.
- (let ((compname (semantic-tag-name (car complst))))
- (not (string= compname thissym))))
- (> (length complst) 1))
- ;; There are several options. Do the completion.
- (semantic-complete-inline-tag-engine
- collector
- (funcall semantic-complete-inline-analyzer-displayer-class)
- ;;(semantic-displayer-tooltip)
- (current-buffer)
- start end))
- )))
-
-(defun semantic-complete-read-tag-analyzer (prompt &optional
- context
- history)
- "Ask for a tag by name based on the current context.
-The function `semantic-analyze-current-context' is used to
-calculate the context. `semantic-analyze-possible-completions' is used
-to generate the list of possible completions.
-PROMPT is the first part of the prompt. Additional prompt
-is added based on the contexts full prefix.
-CONTEXT is the semantic analyzer context to start with.
-HISTORY is a symbol representing a variable to store the history in.
-usually a default-tag and initial-input are available for completion
-prompts. these are calculated from the CONTEXT variable passed in."
- (if (not context) (setq context (semantic-analyze-current-context (point))))
- (let* ((syms (semantic-ctxt-current-symbol (point)))
- (inp (car (reverse syms))))
- (setq syms (nreverse (cdr (nreverse syms))))
- (semantic-complete-read-tag-engine
- (semantic-collector-analyze-completions
- prompt
- :buffer (oref context buffer)
- :context context)
- (semantic-displayer-traditional-with-focus-highlight)
- (with-current-buffer (oref context buffer)
- (goto-char (cdr (oref context bounds)))
- (concat prompt (mapconcat #'identity syms ".")
- (if syms "." "")))
- nil
- inp
- history)))
-
-(defun semantic-complete-inline-analyzer (context)
- "Complete a symbol name by name based on the current context.
-This is similar to `semantic-complete-read-tag-analyze', except
-that the completion interaction is in the buffer where the context
-was calculated from.
-CONTEXT is the semantic analyzer context to start with.
-Customize `semantic-complete-inline-analyzer-displayer-class'
-to control how completion options are displayed.
-
-See `semantic-complete-inline-tag-engine' for details on how
-completion works."
- (if (not context) (setq context (semantic-analyze-current-context (point))))
- (if (not context) (error "Nothing to complete on here"))
- (let* ((collector (semantic-collector-analyze-completions
- :buffer (oref context buffer)
- :context context))
- (syms (semantic-ctxt-current-symbol (point)))
- (rsym (reverse syms))
- (thissym (car rsym))
- (nextsym (car-safe (cdr rsym)))
- (complst nil))
- (when (and thissym (or (not (string= thissym ""))
- nextsym))
- ;; Do a quick calculation of completions.
- (semantic-collector-calculate-completions
- collector thissym nil)
- ;; Get the master list
- (setq complst (semanticdb-strip-find-results
- (semantic-collector-all-completions collector thissym)))
- ;; Shorten by name
- (setq complst (semantic-unique-tag-table-by-name complst))
- (if (or (and (= (length complst) 1)
- ;; Check to see if it is the same as what is there.
- ;; if so, we can offer to complete.
- (let ((compname (semantic-tag-name (car complst))))
- (not (string= compname thissym))))
- (> (length complst) 1))
- ;; There are several options. Do the completion.
- (semantic-complete-inline-tag-engine
- collector
- (funcall semantic-complete-inline-analyzer-displayer-class)
- ;;(semantic-displayer-tooltip)
- (oref context buffer)
- (car (oref context bounds))
- (cdr (oref context bounds))
- ))
- )))
-
-(defcustom semantic-complete-inline-analyzer-idle-displayer-class
- 'semantic-displayer-ghost
- "Class for displayer to use with inline completion at idle time."
- :group 'semantic
- :type semantic-complete-inline-custom-type
- )
-
-(defun semantic-complete-inline-analyzer-idle (context)
- "Complete a symbol name by name based on the current context for idle time.
-CONTEXT is the semantic analyzer context to start with.
-This function is used from `semantic-idle-completions-mode'.
-
-This is the same as `semantic-complete-inline-analyzer', except that
-it uses `semantic-complete-inline-analyzer-idle-displayer-class'
-to control how completions are displayed.
-
-See `semantic-complete-inline-tag-engine' for details on how
-completion works."
- (let ((semantic-complete-inline-analyzer-displayer-class
- semantic-complete-inline-analyzer-idle-displayer-class))
- (semantic-complete-inline-analyzer context)
- ))
-
-\f
-;;;###autoload
-(defun semantic-complete-jump-local ()
- "Jump to a local semantic symbol."
- (interactive)
- (semantic-error-if-unparsed)
- (let ((tag (semantic-complete-read-tag-buffer-deep "Jump to symbol: ")))
- (when (semantic-tag-p tag)
- (push-mark)
- (when (fboundp 'xref-push-marker-stack)
- (xref-push-marker-stack))
- (goto-char (semantic-tag-start tag))
- (semantic-momentary-highlight-tag tag)
- (message "%S: %s "
- (semantic-tag-class tag)
- (semantic-tag-name tag)))))
-
-;;;###autoload
-(defun semantic-complete-jump ()
- "Jump to a semantic symbol."
- (interactive)
- (semantic-error-if-unparsed)
- (let* ((tag (semantic-complete-read-tag-project "Jump to symbol: ")))
- (when (semantic-tag-p tag)
- (push-mark)
- (when (fboundp 'xref-push-marker-stack)
- (xref-push-marker-stack))
- (semantic-go-to-tag tag)
- (pop-to-buffer-same-window (current-buffer))
- (semantic-momentary-highlight-tag tag)
- (message "%S: %s "
- (semantic-tag-class tag)
- (semantic-tag-name tag)))))
-
-;;;###autoload
-(defun semantic-complete-jump-local-members ()
- "Jump to a semantic symbol."
- (interactive)
- (semantic-error-if-unparsed)
- (let* ((tag (semantic-complete-read-tag-local-members "Jump to symbol: ")))
- (when (semantic-tag-p tag)
- (let ((start (condition-case nil (semantic-tag-start tag)
- (error nil))))
- (unless start
- (error "Tag %s has no location" (semantic-format-tag-prototype tag)))
- (push-mark)
- (when (fboundp 'xref-push-marker-stack)
- (xref-push-marker-stack))
- (goto-char start)
- (semantic-momentary-highlight-tag tag)
- (message "%S: %s "
- (semantic-tag-class tag)
- (semantic-tag-name tag))))))
-
-;;;###autoload
-(defun semantic-complete-analyze-and-replace ()
- "Perform prompt completion to do in buffer completion.
-`semantic-analyze-possible-completions' is used to determine the
-possible values.
-The minibuffer is used to perform the completion.
-The result is inserted as a replacement of the text that was there."
- (interactive)
- (let* ((c (semantic-analyze-current-context (point)))
- (tag (save-excursion (semantic-complete-read-tag-analyzer "" c))))
- ;; Take tag, and replace context bound with its name.
- (goto-char (car (oref c bounds)))
- (delete-region (point) (cdr (oref c bounds)))
- (insert (semantic-tag-name tag))
- (message "%S" (semantic-format-tag-summarize tag))))
-
-;;;###autoload
-(defun semantic-complete-analyze-inline ()
- "Perform prompt completion to do in buffer completion.
-`semantic-analyze-possible-completions' is used to determine the
-possible values.
-The function returns immediately, leaving the buffer in a mode that
-will perform the completion.
-Configure `semantic-complete-inline-analyzer-displayer-class' to change
-how completion options are displayed."
- (interactive)
- ;; Only do this if we are not already completing something.
- (if (not (semantic-completion-inline-active-p))
- (semantic-complete-inline-analyzer
- (semantic-analyze-current-context (point))))
- ;; Report a message if things didn't startup.
- (if (and (called-interactively-p 'any)
- (not (semantic-completion-inline-active-p)))
- (message "Inline completion not needed.")
- ;; Since this is most likely bound to something, and not used
- ;; at idle time, throw in a TAB for good measure.
- (semantic-complete-inline-TAB)))
-
-;;;###autoload
-(defun semantic-complete-analyze-inline-idle ()
- "Perform prompt completion to do in buffer completion.
-`semantic-analyze-possible-completions' is used to determine the
-possible values.
-The function returns immediately, leaving the buffer in a mode that
-will perform the completion.
-Configure `semantic-complete-inline-analyzer-idle-displayer-class'
-to change how completion options are displayed."
- (interactive)
- ;; Only do this if we are not already completing something.
- (if (not (semantic-completion-inline-active-p))
- (semantic-complete-inline-analyzer-idle
- (semantic-analyze-current-context (point))))
- ;; Report a message if things didn't startup.
- (if (and (called-interactively-p 'interactive)
- (not (semantic-completion-inline-active-p)))
- (message "Inline completion not needed.")))
-
-;;;###autoload
-(defun semantic-complete-self-insert (arg)
- "Like `self-insert-command', but does completion afterwards.
-ARG is passed to `self-insert-command'. If ARG is nil,
-use `semantic-complete-analyze-inline' to complete."
- (interactive "p")
- ;; If we are already in a completion scenario, exit now, and then start over.
- (semantic-complete-inline-exit)
-
- ;; Insert the key
- (self-insert-command arg)
-
- ;; Prepare for doing completion, but exit quickly if there is keyboard
- ;; input.
- (when (save-window-excursion
- (save-excursion
- ;; FIXME: Use `while-no-input'?
- (and (not (semantic-exit-on-input 'csi
- (semantic-fetch-tags)
- (semantic-throw-on-input 'csi)
- nil))
- (= arg 1)
- (not (semantic-exit-on-input 'csi
- (semantic-analyze-current-context)
- (semantic-throw-on-input 'csi)
- nil)))))
- (condition-case nil
- (semantic-complete-analyze-inline)
- ;; Ignore errors. Seems likely that we'll get some once in a while.
- (error nil))
- ))
-
-;;;###autoload
-(defun semantic-complete-inline-project ()
- "Perform inline completion for any symbol in the current project.
-`semantic-analyze-possible-completions' is used to determine the
-possible values.
-The function returns immediately, leaving the buffer in a mode that
-will perform the completion."
- (interactive)
- ;; Only do this if we are not already completing something.
- (if (not (semantic-completion-inline-active-p))
- (semantic-complete-inline-tag-project))
- ;; Report a message if things didn't startup.
- (if (and (called-interactively-p 'interactive)
- (not (semantic-completion-inline-active-p)))
- (message "Inline completion not needed."))
- )
-
-(provide 'semantic/complete)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/complete"
-;; End:
-
-;;; semantic/complete.el ends here
+++ /dev/null
-;;; semantic/ctxt.el --- Context calculations for Semantic tools -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic, as a tool, provides a nice list of searchable tags.
-;; That information can provide some very accurate answers if the current
-;; context of a position is known.
-;;
-;; This library provides the hooks needed for a language to specify how
-;; the current context is calculated.
-;;
-(require 'semantic)
-
-;;; Code:
-(defvar-local semantic-command-separation-character
- ";"
- "String which indicates the end of a command.
-Used for identifying the end of a single command.")
-
-(defvar-local semantic-function-argument-separation-character
- ","
- "String which indicates the end of an argument.
-Used for identifying arguments to functions.")
-
-;;; Local Contexts
-;;
-;; These context are nested blocks of code, such as code in an
-;; if clause
-(declare-function semantic-current-tag-of-class "semantic/find")
-
-(define-overloadable-function semantic-up-context (&optional point bounds-type)
- "Move point up one context from POINT.
-Return non-nil if there are no more context levels.
-Overloaded functions using `up-context' take no parameters.
-BOUNDS-TYPE is a symbol representing a tag class to restrict
-movement to. If this is nil, `function' is used.
-This will find the smallest tag of that class (function, variable,
-type, etc) and make sure non-nil is returned if you cannot
-go up past the bounds of that tag."
- (require 'semantic/find)
- (if point (goto-char point))
- (let ((nar (semantic-current-tag-of-class (or bounds-type 'function))))
- (if nar
- (semantic-with-buffer-narrowed-to-tag nar (:override-with-args ()))
- (when bounds-type
- (error "No context of type %s to advance in" bounds-type))
- (:override-with-args ()))))
-
-(defun semantic-up-context-default ()
- "Move the point up and out one context level.
-Works with languages that use parenthetical grouping."
- ;; By default, assume that the language uses some form of parenthetical
- ;; do dads for their context.
- (condition-case nil
- (progn
- (up-list -1)
- nil)
- (error t)))
-
-(define-overloadable-function semantic-beginning-of-context (&optional point)
- "Move POINT to the beginning of the current context.
-Return non-nil if there is no upper context.
-The default behavior uses `semantic-up-context'.")
-
-(defun semantic-beginning-of-context-default (&optional point)
- "Move POINT to the beginning of the current context via parenthesis.
-Return non-nil if there is no upper context."
- (if point (goto-char point))
- (if (semantic-up-context)
- t
- (forward-char 1)
- nil))
-
-(define-overloadable-function semantic-end-of-context (&optional point)
- "Move POINT to the end of the current context.
-Return non-nil if there is no upper context.
-Be default, this uses `semantic-up-context', and assumes parenthetical
-block delimiters.")
-
-(defun semantic-end-of-context-default (&optional point)
- "Move POINT to the end of the current context via parenthesis.
-Return non-nil if there is no upper context."
- (if point (goto-char point))
- (let ((start (point)))
- (if (semantic-up-context)
- t
- ;; Go over the list, and back over the end parenthesis.
- (condition-case nil
- (progn
- (forward-sexp 1)
- (forward-char -1))
- (error
- ;; If an error occurs, get the current tag from the cache,
- ;; and just go to the end of that. Make sure we end up at least
- ;; where start was so parse-region type calls work.
- (if (semantic-current-tag)
- (progn
- (goto-char (semantic-tag-end (semantic-current-tag)))
- (when (< (point) start)
- (goto-char start)))
- (goto-char start))
- t)))
- nil))
-
-(defun semantic-narrow-to-context ()
- "Narrow the buffer to the extent of the current context."
- (let (b e)
- (save-excursion
- (if (semantic-beginning-of-context)
- nil
- (setq b (point))))
- (save-excursion
- (if (semantic-end-of-context)
- nil
- (setq e (point))))
- (if (and b e) (narrow-to-region b e))))
-
-(defmacro semantic-with-buffer-narrowed-to-context (&rest body)
- "Execute BODY with the buffer narrowed to the current context."
- (declare (indent 0) (debug t))
- `(save-restriction
- (semantic-narrow-to-context)
- ,@body))
-
-;;; Local Variables
-;;
-
-(defvar semantic--progress-reporter)
-
-(define-overloadable-function semantic-get-local-variables (&optional point)
- "Get the local variables based on POINT's context.
-Local variables are returned in Semantic tag format.
-This can be overridden with `get-local-variables'."
- ;; Disable parsing messages
- (let ((semantic--progress-reporter nil))
- (save-excursion
- (if point (goto-char point))
- (let* ((case-fold-search semantic-case-fold))
- (:override-with-args ())))))
-
-(defun semantic-get-local-variables-default ()
- "Get local values from a specific context.
-Uses the bovinator with the special top-symbol `bovine-inner-scope'
-to collect tags, such as local variables or prototypes."
- ;; This assumes a bovine parser. Make sure we don't do
- ;; anything in that case.
- (when (and semantic--parse-table (not (eq semantic--parse-table t)))
- (let ((vars (semantic-get-cache-data 'get-local-variables)))
- (if vars
- (progn
- ;;(message "Found cached vars.")
- vars)
- (let ((vars2 nil)
- ;; We want nothing to do with funny syntaxing while doing this.
- (semantic-unmatched-syntax-hook nil)
- (start (point))
- (firstusefulstart nil)
- )
- (while (not (semantic-up-context (point) 'function))
- (when (not vars)
- (setq firstusefulstart (point)))
- (save-excursion
- (forward-char 1)
- (setq vars
- ;; Note to self: semantic-parse-region returns cooked
- ;; but unlinked tags. File information is lost here
- ;; and is added next.
- (append (semantic-parse-region
- (point)
- (save-excursion (semantic-end-of-context) (point))
- 'bovine-inner-scope
- nil
- t)
- vars))))
- ;; Modify the tags in place.
- (setq vars2 vars)
- (while vars2
- (semantic--tag-put-property (car vars2) :filename (buffer-file-name))
- (setq vars2 (cdr vars2)))
- ;; Hash our value into the first context that produced useful results.
- (when (and vars firstusefulstart)
- (let ((end (save-excursion
- (goto-char firstusefulstart)
- (save-excursion
- (unless (semantic-end-of-context)
- (point))))))
- ;;(message "Caching values %d->%d." firstusefulstart end)
- (semantic-cache-data-to-buffer
- (current-buffer) firstusefulstart
- (or end
- ;; If the end-of-context fails,
- ;; just use our cursor starting
- ;; position.
- start)
- vars 'get-local-variables 'exit-cache-zone))
- )
- ;; Return our list.
- vars)))))
-
-(define-overloadable-function semantic-get-local-arguments (&optional point)
- "Get arguments (variables) from the current context at POINT.
-Parameters are available if the point is in a function or method.
-Return a list of tags unlinked from the originating buffer.
-Arguments are obtained by overriding `get-local-arguments', or by the
-default function `semantic-get-local-arguments-default'. This, must
-return a list of tags, or a list of strings that will be converted to
-tags."
- (save-excursion
- (if point (goto-char point))
- (let* ((case-fold-search semantic-case-fold)
- (args (:override-with-args ()))
- arg tags)
- ;; Convert unsafe arguments to the right thing.
- (while args
- (setq arg (car args)
- args (cdr args)
- tags (cons (cond
- ((semantic-tag-p arg)
- ;; Return a copy of tag without overlay.
- ;; The overlay is preserved.
- (semantic-tag-copy arg nil t))
- ((stringp arg)
- (semantic--tag-put-property
- (semantic-tag-new-variable arg nil nil)
- :filename (buffer-file-name)))
- (t
- (error "Unknown parameter element %S" arg)))
- tags)))
- (nreverse tags))))
-
-(defun semantic-get-local-arguments-default ()
- "Get arguments (variables) from the current context.
-Parameters are available if the point is in a function or method."
- (let ((tag (semantic-current-tag)))
- (if (and tag (semantic-tag-of-class-p tag 'function))
- (semantic-tag-function-arguments tag))))
-
-(define-overloadable-function semantic-get-all-local-variables (&optional point)
- "Get all local variables for this context, and parent contexts.
-Local variables are returned in Semantic tag format.
-Be default, this gets local variables, and local arguments.
-Optional argument POINT is the location to start getting the variables from.")
-
-(defun semantic-get-all-local-variables-default (&optional point)
- "Get all local variables for this context.
-Optional argument POINT is the location to start getting the variables from.
-That is a cons (LOCAL-ARGUMENTS . LOCAL-VARIABLES) where:
-
-- LOCAL-ARGUMENTS is collected by `semantic-get-local-arguments'.
-- LOCAL-VARIABLES is collected by `semantic-get-local-variables'."
- (save-excursion
- (if point (goto-char point))
- (let ((case-fold-search semantic-case-fold))
- (append (semantic-get-local-arguments)
- (semantic-get-local-variables)))))
-
-;;; Local context parsing
-;;
-;; Context parsing assumes a series of language independent commonalities.
-;; These terms are used to describe those contexts:
-;;
-;; command - One command in the language.
-;; symbol - The symbol the cursor is on.
-;; This would include a series of type/field when applicable.
-;; assignment - The variable currently being assigned to
-;; function - The function call the cursor is on/in
-;; argument - The index to the argument the cursor is on.
-;;
-;;
-(define-overloadable-function semantic-end-of-command ()
- "Move to the end of the current command.
-Be default, uses `semantic-command-separation-character'.")
-
-(defun semantic-end-of-command-default ()
- "Move to the end of the current command.
-Depends on `semantic-command-separation-character' to find the
-beginning and end of a command."
- (semantic-with-buffer-narrowed-to-context
- (let ((case-fold-search semantic-case-fold))
- (with-syntax-table semantic-lex-syntax-table
-
- (if (re-search-forward (regexp-quote semantic-command-separation-character)
- nil t)
- (forward-char -1)
- ;; If there wasn't a command after this, we are the last
- ;; command, and we are incomplete.
- (goto-char (point-max)))))))
-
-(define-overloadable-function semantic-beginning-of-command ()
- "Move to the beginning of the current command.
-Be default, uses `semantic-command-separation-character'.")
-
-(defun semantic-beginning-of-command-default ()
- "Move to the beginning of the current command.
-Depends on `semantic-command-separation-character' to find the
-beginning and end of a command."
- (semantic-with-buffer-narrowed-to-context
- (with-syntax-table semantic-lex-syntax-table
- (let ((case-fold-search semantic-case-fold))
- (skip-chars-backward semantic-command-separation-character)
- (if (re-search-backward (regexp-quote semantic-command-separation-character)
- nil t)
- (goto-char (match-end 0))
- ;; If there wasn't a command after this, we are the last
- ;; command, and we are incomplete.
- (goto-char (point-min)))
- (skip-chars-forward " \t\n")
- ))))
-
-
-(defsubst semantic-point-at-beginning-of-command ()
- "Return the point at the beginning of the current command."
- (save-excursion (semantic-beginning-of-command) (point)))
-
-(defsubst semantic-point-at-end-of-command ()
- "Return the point at the beginning of the current command."
- (save-excursion (semantic-end-of-command) (point)))
-
-(defsubst semantic-narrow-to-command ()
- "Narrow the current buffer to the current command."
- (narrow-to-region (semantic-point-at-beginning-of-command)
- (semantic-point-at-end-of-command)))
-
-(defmacro semantic-with-buffer-narrowed-to-command (&rest body)
- "Execute BODY with the buffer narrowed to the current command."
- (declare (indent 0) (debug t))
- `(save-restriction
- (semantic-narrow-to-command)
- ,@body))
-
-(define-overloadable-function semantic-ctxt-end-of-symbol (&optional point)
- "Move point to the end of the current symbol under POINT.
-This skips forward over symbols in a complex reference.
-For example, in the C statement:
- this.that().entry;
-
-If the cursor is on `this', will move point to the ; after entry.")
-
-(defun semantic-ctxt-end-of-symbol-default (&optional point)
- "Move point to the end of the current symbol under POINT.
-This will move past type/field names when applicable.
-Depends on `semantic-type-relation-separator-character', and will
-work on C like languages."
- (if point (goto-char point))
- (let* ((fieldsep1 (mapconcat (lambda (a) (regexp-quote a))
- semantic-type-relation-separator-character
- "\\|"))
- ;; NOTE: The [ \n] expression below should used \\s-, but that
- ;; doesn't work in C since \n means end-of-comment, and isn't
- ;; really whitespace.
- ;;(fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[ \t\n\r]*\\(\\w\\|\\s_\\)"))
- (case-fold-search semantic-case-fold)
- (continuesearch t)
- (end nil)
- )
- (with-syntax-table semantic-lex-syntax-table
- (cond ((looking-at "\\w\\|\\s_")
- ;; In the middle of a symbol, move to the end.
- (forward-sexp 1))
- ((looking-at fieldsep1)
- ;; We are in a fine spot.. do nothing.
- nil
- )
- ((save-excursion
- (and (condition-case nil
- (progn (forward-sexp -1)
- (forward-sexp 1)
- t)
- (error nil))
- (looking-at fieldsep1)))
- (forward-sexp -1)
- ;; Skip array expressions.
- (while (looking-at "\\s(") (forward-sexp -1))
- (forward-sexp 1))
- )
- ;; Set the current end marker.
- (setq end (point))
-
- ;; Cursor is at the safe end of some symbol. Look until we
- ;; find the logical end of this current complex symbol.
- (condition-case nil
- (while continuesearch
- ;; If there are functional arguments, arrays, etc, skip them.
- (when (looking-at "\\s(")
- (forward-sexp 1))
-
- ;; If there is a field separator, then skip that, plus
- ;; the next expected symbol.
- (if (not (looking-at fieldsep1))
- ;; We hit the end.
- (error nil)
-
- ;; Skip the separator and the symbol.
- (goto-char (match-end 0))
-
- (if (looking-at "\\w\\|\\s_")
- ;; Skip symbols
- (forward-sexp 1)
- ;; No symbol, exit the search...
- (setq continuesearch nil))
-
- (setq end (point)))
-
- ;; Cont...
- )
-
- ;; Restore position if we go to far....
- (error (goto-char end)) )
-
- )))
-
-(define-overloadable-function semantic-ctxt-current-symbol (&optional point)
- "Return the current symbol the cursor is on at POINT in a list.
-The symbol includes all logical parts of a complex reference.
-For example, in C the statement:
- this.that().entry
-
-Would be object `this' calling method `that' which returns some structure
-whose field `entry' is being reference. In this case, this function
-would return the list:
- ( \"this\" \"that\" \"entry\" )")
-
-(defun semantic-ctxt-current-symbol-default (&optional point)
- "Return the current symbol the cursor is on at POINT in a list.
-This will include a list of type/field names when applicable.
-Depends on `semantic-type-relation-separator-character'."
- (save-excursion
- (if point (goto-char point))
- (let* ((fieldsep1 (mapconcat (lambda (a) (regexp-quote a))
- semantic-type-relation-separator-character
- "\\|"))
- ;; NOTE: The [ \n] expression below should used \\s-, but that
- ;; doesn't work in C since \n means end-of-comment, and isn't
- ;; really whitespace.
- (fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[ \t\n\r]*\\(\\w\\|\\s_\\)"))
- (case-fold-search semantic-case-fold)
- (symlist nil)
- end)
- (with-syntax-table semantic-lex-syntax-table
- (save-excursion
- (cond ((looking-at "\\w\\|\\s_")
- ;; In the middle of a symbol, move to the end.
- (forward-sexp 1))
- ((looking-at fieldsep1)
- ;; We are in a fine spot.. do nothing.
- nil
- )
- ((save-excursion
- (and (condition-case nil
- (progn (forward-sexp -1)
- (forward-sexp 1)
- t)
- (error nil))
- (looking-at fieldsep1)))
- (setq symlist (list ""))
- (forward-sexp -1)
- ;; Skip array expressions.
- (while (looking-at "\\s(") (forward-sexp -1))
- (forward-sexp 1))
- )
- ;; Set our end point.
- (setq end (point))
-
- ;; Now that we have gotten started, let's do the rest.
- (condition-case nil
- (while (save-excursion
- (forward-char -1)
- (looking-at "\\w\\|\\s_"))
- ;; We have a symbol.. Do symbol things
- (forward-sexp -1)
- (setq symlist (cons (buffer-substring-no-properties (point) end)
- symlist))
- ;; Skip the next syntactic expression backwards, then go forwards.
- (let ((cp (point)))
- (forward-sexp -1)
- (forward-sexp 1)
- ;; If we end up at the same place we started, we are at the
- ;; beginning of a buffer, or narrowed to a command and
- ;; have to stop.
- (if (<= cp (point)) (error nil)))
- (if (looking-at fieldsep)
- (progn
- (forward-sexp -1)
- ;; Skip array expressions.
- (while (and (looking-at "\\s(") (not (bobp)))
- (forward-sexp -1))
- (forward-sexp 1)
- (setq end (point)))
- (error nil))
- )
- (error nil)))
- symlist))))
-
-
-(define-overloadable-function semantic-ctxt-current-symbol-and-bounds (&optional point)
- "Return the current symbol and bounds the cursor is on at POINT.
-The symbol should be the same as returned by `semantic-ctxt-current-symbol'.
-Return (PREFIX ENDSYM BOUNDS).")
-
-(defun semantic-ctxt-current-symbol-and-bounds-default (&optional point)
- "Return the current symbol and bounds the cursor is on at POINT.
-Uses `semantic-ctxt-current-symbol' to calculate the symbol.
-Return (PREFIX ENDSYM BOUNDS)."
- (save-excursion
- (when point (goto-char (point)))
- (let* ((prefix (semantic-ctxt-current-symbol))
- (endsym (car (reverse prefix)))
- ;; @todo - Can we get this data direct from ctxt-current-symbol?
- (bounds (save-excursion
- (cond ((string= endsym "")
- (cons (point) (point))
- )
- ((and prefix (looking-at endsym))
- (cons (point) (progn
- (condition-case nil
- (forward-sexp 1)
- (error nil))
- (point))))
- (prefix
- (condition-case nil
- (cons (progn (forward-sexp -1) (point))
- (progn (forward-sexp 1) (point)))
- (error nil)))
- (t nil))))
- )
- (list prefix endsym bounds))))
-
-(define-overloadable-function semantic-ctxt-current-assignment (&optional point)
- "Return the current assignment near the cursor at POINT.
-Return a list as per `semantic-ctxt-current-symbol'.
-Return nil if there is nothing relevant.")
-
-(defun semantic-ctxt-current-assignment-default (&optional point)
- "Return the current assignment near the cursor at POINT.
-By default, assume that \"=\" indicates an assignment."
- (if point (goto-char point))
- (let ((case-fold-search semantic-case-fold))
- (with-syntax-table semantic-lex-syntax-table
- (condition-case nil
- (semantic-with-buffer-narrowed-to-command
- (save-excursion
- (skip-chars-forward " \t=")
- (condition-case nil (forward-char 1) (error nil))
- (re-search-backward "[^=]=\\([^=]\\|$\\)")
- ;; We are at an equals sign. Go backwards a sexp, and
- ;; we'll have the variable. Otherwise we threw an error
- (forward-sexp -1)
- (semantic-ctxt-current-symbol)))
- (error nil)))))
-
-(define-overloadable-function semantic-ctxt-current-function (&optional point)
- "Return the current function call the cursor is in at POINT.
-The function returned is the one accepting the arguments that
-the cursor is currently in. It will not return function symbol if the
-cursor is on the text representing that function.")
-
-(defun semantic-ctxt-current-function-default (&optional point)
- "Return the current function call the cursor is in at POINT.
-The call will be identified for C like languages with the form
- NAME ( args ... )"
- (if point (goto-char point))
- (let ((case-fold-search semantic-case-fold))
- (with-syntax-table semantic-lex-syntax-table
- (save-excursion
- (semantic-up-context)
- (when (looking-at "(")
- (semantic-ctxt-current-symbol))))
- ))
-
-(define-overloadable-function semantic-ctxt-current-argument (&optional point)
- "Return the index of the argument position the cursor is on at POINT.")
-
-(defun semantic-ctxt-current-argument-default (&optional point)
- "Return the index of the argument the cursor is on at POINT.
-Depends on `semantic-function-argument-separation-character'."
- (if point (goto-char point))
- (let ((case-fold-search semantic-case-fold))
- (with-syntax-table semantic-lex-syntax-table
- (when (semantic-ctxt-current-function)
- (save-excursion
- ;; Only get the current arg index if we are in function args.
- (let ((p (point))
- (idx 1))
- (semantic-up-context)
- (while (re-search-forward
- (regexp-quote semantic-function-argument-separation-character)
- p t)
- (setq idx (1+ idx)))
- idx))))))
-
-(defun semantic-ctxt-current-thing ()
- "Calculate a thing identified by the current cursor position.
-Calls previously defined `semantic-ctxt-current-...' calls until something
-gets a match. See `semantic-ctxt-current-symbol',
-`semantic-ctxt-current-function', and `semantic-ctxt-current-assignment'
-for details on the return value."
- (or (semantic-ctxt-current-symbol)
- (semantic-ctxt-current-function)
- (semantic-ctxt-current-assignment)))
-
-(define-overloadable-function semantic-ctxt-current-class-list (&optional point)
- "Return a list of tag classes that are allowed at POINT.
-If POINT is nil, the current buffer location is used.
-For example, in Emacs Lisp, the symbol after a ( is most likely
-a function. In a makefile, symbols after a : are rules, and symbols
-after a $( are variables.")
-
-(defun semantic-ctxt-current-class-list-default (&optional point)
- "Return a list of tag classes that are allowed at POINT.
-Assume a functional typed language. Uses very simple rules."
- (save-excursion
- (if point (goto-char point))
-
- (let ((tag (semantic-current-tag)))
- (if tag
- (cond ((semantic-tag-of-class-p tag 'function)
- '(function variable type))
- ((or (semantic-tag-of-class-p tag 'type)
- (semantic-tag-of-class-p tag 'variable))
- '(type))
- (t nil))
- '(type)
- ))))
-
-;;;###autoload
-(define-overloadable-function semantic-ctxt-current-mode (&optional point)
- "Return the major mode active at POINT.
-POINT defaults to the value of point in current buffer.
-You should override this function in multiple mode buffers to
-determine which major mode apply at point.")
-
-(defun semantic-ctxt-current-mode-default (&optional _point)
- "Return the major mode active at POINT.
-POINT defaults to the value of point in current buffer.
-This default implementation returns the current major mode."
- major-mode)
-\f
-;;; Scoped Types
-;;
-;; Scoped types are types that the current code would have access to.
-;; The come from the global namespace or from special commands such as "using"
-(define-overloadable-function semantic-ctxt-scoped-types (&optional point)
- "Return a list of type names currently in scope at POINT.
-The return value can be a mixed list of either strings (names of
-types that are in scope) or actual tags (type declared locally
-that may or may not have a name.)")
-
-(defun semantic-ctxt-scoped-types-default (&optional _point)
- "Return a list of scoped types by name for the current context at POINT.
-This is very different for various languages, and does nothing unless
-overridden."
- nil)
-
-(define-overloadable-function semantic-ctxt-imported-packages (&optional point)
- "Return a list of package tags or names which are being imported at POINT.
-The return value is a list of strings which are package names
-that are implied in code. Thus a C++ symbol:
- foo::bar();
-where there is a statement such as:
- using baz;
-means that the first symbol might be:
- baz::foo::bar();"
- nil)
-
-(provide 'semantic/ctxt)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/ctxt"
-;; End:
-
-;;; semantic/ctxt.el ends here
+++ /dev/null
-;;; semantic/db-debug.el --- Extra level debugging routines for Semantic -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Various routines for debugging SemanticDB issues, or viewing
-;; semanticdb state.
-
-(require 'data-debug)
-(require 'semantic/db)
-(require 'semantic/format)
-
-;;; Code:
-;;
-(defun semanticdb-dump-all-table-summary ()
- "Dump a list of all databases in Emacs memory."
- (interactive)
- (require 'data-debug)
- (let ((db semanticdb-database-list))
- (data-debug-new-buffer "*SEMANTICDB*")
- (data-debug-insert-stuff-list db "*")))
-
-(defalias 'semanticdb-adebug-database-list #'semanticdb-dump-all-table-summary)
-
-(defun semanticdb-adebug-current-database ()
- "Run ADEBUG on the current database."
- (interactive)
- (require 'data-debug)
- (let ((p semanticdb-current-database)
- )
- (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
- (data-debug-insert-stuff-list p "*")))
-
-(defun semanticdb-adebug-current-table ()
- "Run ADEBUG on the current database."
- (interactive)
- (require 'data-debug)
- (let ((p semanticdb-current-table))
- (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
- (data-debug-insert-stuff-list p "*")))
-
-
-(defun semanticdb-adebug-project-database-list ()
- "Run ADEBUG on the current database."
- (interactive)
- (require 'data-debug)
- (let ((p (semanticdb-current-database-list)))
- (data-debug-new-buffer "*SEMANTICDB ADEBUG*")
- (data-debug-insert-stuff-list p "*")))
-
-
-\f
-;;; Sanity Checks
-;;
-
-(defun semanticdb-table-oob-sanity-check (cache)
- "Validate that CACHE tags do not have any overlays in them."
- (while cache
- (when (overlayp (semantic-tag-overlay cache))
- (message "Tag %s has an erroneous overlay!"
- (semantic-format-tag-summarize (car cache))))
- (semanticdb-table-oob-sanity-check
- (semantic-tag-components-with-overlays (car cache)))
- (setq cache (cdr cache))))
-
-(defun semanticdb-table-sanity-check (&optional table)
- "Validate the current semanticdb TABLE."
- (interactive)
- (if (not table) (setq table semanticdb-current-table))
- (let* ((full-filename (semanticdb-full-filename table))
- (buff (find-buffer-visiting full-filename)))
- (if buff
- (with-current-buffer buff
- (semantic-sanity-check))
- ;; We can't use the usual semantic validity check, so hack our own.
- (semanticdb-table-oob-sanity-check (semanticdb-get-tags table)))))
-
-(defun semanticdb-database-sanity-check ()
- "Validate the current semantic database."
- (interactive)
- (let ((tables (semanticdb-get-database-tables
- semanticdb-current-database)))
- (while tables
- (semanticdb-table-sanity-check (car tables))
- (setq tables (cdr tables)))
- ))
-
-
-
-(provide 'semantic/db-debug)
-
-;;; semantic/db-debug.el ends here
+++ /dev/null
-;;; semantic/db-el.el --- Semantic database extensions for Emacs Lisp -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: tags
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; There are a lot of Emacs Lisp functions and variables available for
-;; the asking. This adds on to the semanticdb programming interface to
-;; allow all loaded Emacs Lisp functions to be queried via semanticdb.
-;;
-;; This allows you to use programs written for Semantic using the database
-;; to also work in Emacs Lisp with no compromises.
-;;
-
-(require 'semantic/db)
-(require 'eieio-opt)
-
-(declare-function semantic-elisp-desymbolify "semantic/bovine/el")
-(declare-function semantic-tag-similar-p "semantic/tag-ls")
-
-;;; Code:
-
-;;; Classes:
-(defclass semanticdb-table-emacs-lisp (semanticdb-abstract-table)
- ((major-mode :initform #'emacs-lisp-mode)
- )
- "A table for returning search results from Emacs.")
-
-(cl-defmethod semanticdb-refresh-table ((_obj semanticdb-table-emacs-lisp) &optional _force)
- "Do not refresh Emacs Lisp table.
-It does not need refreshing."
- nil)
-
-(cl-defmethod semanticdb-needs-refresh-p ((_obj semanticdb-table-emacs-lisp))
- "Return nil, we never need a refresh."
- nil)
-
-(cl-defmethod semanticdb-debug-info ((_obj semanticdb-table-emacs-lisp))
- (list "(proxy)"))
-
-(cl-defmethod cl-print-object ((obj semanticdb-table-emacs-lisp) stream)
- "Pretty printer extension for `semanticdb-table-emacs-lisp'."
- (princ (eieio-object-name obj (semanticdb-debug-info obj))
- stream))
-
-(defclass semanticdb-project-database-emacs-lisp
- (semanticdb-project-database eieio-singleton)
- ((new-table-class :initform 'semanticdb-table-emacs-lisp
- :type class
- :documentation
- "New tables created for this database are of this class.")
- )
- "Database representing Emacs core.")
-
-(cl-defmethod semanticdb-debug-info ((obj
- semanticdb-project-database-emacs-lisp))
- (let ((count 0))
- (mapatoms (lambda (_sym) (setq count (1+ count))))
- (append (cl-call-next-method obj)
- (list (format "(%d known syms)" count)))))
-
-(cl-defmethod cl-print-object ((obj semanticdb-project-database-emacs-lisp)
- stream)
- "Pretty printer extension for `semanticdb-table-emacs-lisp'.
-Adds the number of tags in this file to the object print name."
- (princ (eieio-object-name obj (semanticdb-debug-info obj))
- stream))
-
-;; Create the database, and add it to searchable databases for Emacs Lisp mode.
-(defvar-mode-local emacs-lisp-mode semanticdb-project-system-databases
- (list
- (make-instance 'semanticdb-project-database-emacs-lisp))
- "Search Emacs core for symbols.")
-
-(defvar-mode-local emacs-lisp-mode semanticdb-find-default-throttle
- '(project omniscience)
- "Search project files, then search this omniscience database.
-It is not necessary to do system or recursive searching because of
-the omniscience database.")
-
-;;; Filename based methods
-;;
-(cl-defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-emacs-lisp))
- "For an Emacs Lisp database, there are no explicit tables.
-Create one of our special tables that can act as an intermediary."
- ;; We need to return something since there is always the "master table"
- ;; The table can then answer file name type questions.
- (when (not (slot-boundp obj 'tables))
- (let ((newtable (make-instance 'semanticdb-table-emacs-lisp)))
- (oset obj tables (list newtable))
- (oset newtable parent-db obj)
- (oset newtable tags nil)
- ))
- (cl-call-next-method))
-
-(cl-defmethod semanticdb-file-table ((obj semanticdb-project-database-emacs-lisp) _filename)
- "From OBJ, return FILENAME's associated table object.
-For Emacs Lisp, creates a specialized table."
- (car (semanticdb-get-database-tables obj))
- )
-
-(cl-defmethod semanticdb-get-tags ((_table semanticdb-table-emacs-lisp ))
- "Return the list of tags belonging to TABLE."
- ;; specialty table ? Probably derive tags at request time.
- nil)
-
-(cl-defmethod semanticdb-equivalent-mode ((_table semanticdb-table-emacs-lisp) &optional buffer)
- "Return non-nil if TABLE's mode is equivalent to BUFFER.
-Equivalent modes are specified by the `semantic-equivalent-major-modes'
-local variable."
- (with-current-buffer buffer
- (eq (or mode-local-active-mode major-mode) 'emacs-lisp-mode)))
-
-(cl-defmethod semanticdb-full-filename ((_obj semanticdb-table-emacs-lisp))
- "Fetch the full filename that OBJ refers to.
-For Emacs Lisp system DB, there isn't one."
- nil)
-
-;;; Conversion
-;;
-(cl-defmethod semanticdb-normalize-tags ((obj semanticdb-table-emacs-lisp) tags)
- "Convert tags, originating from Emacs OBJ, into standardized form."
- (let ((newtags nil))
- (dolist (T tags)
- (let* ((ot (semanticdb-normalize-one-tag obj T))
- (tag (cdr ot)))
- (setq newtags (cons tag newtags))))
- ;; There is no promise to have files associated.
- (nreverse newtags)))
-
-(cl-defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-emacs-lisp) tag)
- "Convert one TAG, originating from Emacs OBJ, into standardized form.
-If Emacs cannot resolve this symbol to a particular file, then return nil."
- ;; Here's the idea. For each tag, get the name, then use
- ;; Emacs's `symbol-file' to get the source. Once we have that,
- ;; we can use more typical semantic searching techniques to
- ;; get a regularly parsed tag.
- (let* ((type (cond ((semantic-tag-of-class-p tag 'function)
- 'defun)
- ((semantic-tag-of-class-p tag 'variable)
- 'defvar)
- ))
- (sym (intern (semantic-tag-name tag)))
- (file (condition-case nil
- (symbol-file sym type)
- ;; Older [X]Emacs don't have a 2nd argument.
- (error (symbol-file sym))))
- )
- (if (or (not file) (not (file-exists-p file)))
- ;; The file didn't exist. Return nil.
- ;; We can't normalize this tag. Fake it out.
- (cons obj tag)
- (when (string-match "\\.elc" file)
- (setq file (concat (file-name-sans-extension file)
- ".el"))
- (when (and (not (file-exists-p file))
- (file-exists-p (concat file ".gz")))
- ;; Is it a .gz file?
- (setq file (concat file ".gz"))))
-
- (let* ((tab (semanticdb-file-table-object file))
- (newtags (when tab (semanticdb-find-tags-by-name-method
- tab (semantic-tag-name tag))))
- (match nil))
- ;; We might not have a parsed tag in this file, because it
- ;; might be generated through a macro like defstruct.
- (if (null newtags)
- (setq match tag)
- ;; Find the best match.
- (dolist (T newtags)
- (when (semantic-tag-similar-p T tag)
- (setq match T)))
- ;; Backup system.
- (when (not match)
- (setq match (car newtags))))
- ;; Return it.
- (when tab (cons tab match))))))
-
-(autoload 'help-function-arglist "help-fns")
-
-(defun semanticdb-elisp-sym->tag (sym &optional toktype)
- "Convert SYM into a semantic tag.
-TOKTYPE is a hint to the type of tag desired."
- (if (stringp sym)
- (setq sym (intern-soft sym)))
- (when sym
- (cond ((and (eq toktype 'function) (fboundp sym))
- (require 'semantic/bovine/el)
- (let ((arglist (help-function-arglist sym)))
- (when (not (listp arglist))
- ;; Function might be autoloaded, in which case
- ;; the arglist is not available yet.
- (setq arglist nil))
- (semantic-tag-new-function
- (symbol-name sym)
- nil ;; return type
- (semantic-elisp-desymbolify arglist)
- :user-visible-flag (commandp sym))))
- ((and (eq toktype 'variable) (boundp sym))
- (semantic-tag-new-variable
- (symbol-name sym)
- nil ;; type
- nil ;; value - ignore for now
- ))
- ((and (eq toktype 'type) (class-p sym))
- (semantic-tag-new-type
- (symbol-name sym)
- "class"
- (semantic-elisp-desymbolify
- (let ((class (find-class sym)))
- (if (fboundp 'eieio--class-public-a) ; Emacs < 25.1
- (eieio--class-public-a class)
- (mapcar #'eieio-slot-descriptor-name
- (eieio-class-slots class)))))
- (semantic-elisp-desymbolify (eieio-class-parents sym)) ;; parents
- ))
- ((not toktype)
- ;; Figure it out on our own.
- (cond ((class-p sym)
- (semanticdb-elisp-sym->tag sym 'type))
- ((fboundp sym)
- (semanticdb-elisp-sym->tag sym 'function))
- ((boundp sym)
- (semanticdb-elisp-sym->tag sym 'variable))
- (t nil))
- )
- (t nil))))
-
-;;; Search Overrides
-;;
-(defvar semanticdb-elisp-mapatom-collector nil
- "Variable used to collect `mapatoms' output.")
-
-(cl-defmethod semanticdb-find-tags-by-name-method
- ((_table semanticdb-table-emacs-lisp) name &optional tags)
- "Find all tags named NAME in TABLE.
-Uses `intern-soft' to match NAME to Emacs symbols.
-Return a list of tags."
- (if tags (cl-call-next-method)
- ;; No need to search. Use `intern-soft' which does the same thing for us.
- (let* ((sym (intern-soft name))
- (fun (semanticdb-elisp-sym->tag sym 'function))
- (var (semanticdb-elisp-sym->tag sym 'variable))
- (typ (semanticdb-elisp-sym->tag sym 'type))
- (taglst nil)
- )
- (when (or fun var typ)
- ;; If the symbol is any of these things, build the search table.
- (when var (setq taglst (cons var taglst)))
- (when typ (setq taglst (cons typ taglst)))
- (when fun (setq taglst (cons fun taglst)))
- taglst
- ))))
-
-(cl-defmethod semanticdb-find-tags-by-name-regexp-method
- ((_table semanticdb-table-emacs-lisp) regex &optional tags)
- "Find all tags with name matching REGEX in TABLE.
-Optional argument TAGS is a list of tags to search.
-Uses `apropos-internal' to find matches.
-Return a list of tags."
- (if tags (cl-call-next-method)
- (delq nil (mapcar #'semanticdb-elisp-sym->tag
- (apropos-internal regex)))))
-
-(cl-defmethod semanticdb-find-tags-for-completion-method
- ((_table semanticdb-table-emacs-lisp) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- (if tags (cl-call-next-method)
- (delq nil (mapcar #'semanticdb-elisp-sym->tag
- (all-completions prefix obarray)))))
-
-(cl-defmethod semanticdb-find-tags-by-class-method
- ((_table semanticdb-table-emacs-lisp) _class &optional tags)
- "In TABLE, find all occurrences of tags of CLASS.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- (if tags (cl-call-next-method)
- ;; We could implement this, but it could be messy.
- nil))
-
-;;; Deep Searches
-;;
-;; For Emacs Lisp deep searches are like top level searches.
-(cl-defmethod semanticdb-deep-find-tags-by-name-method
- ((table semanticdb-table-emacs-lisp) name &optional tags)
- "Find all tags name NAME in TABLE.
-Optional argument TAGS is a list of tags to search.
-Like `semanticdb-find-tags-by-name-method' for Emacs Lisp."
- (semanticdb-find-tags-by-name-method table name tags))
-
-(cl-defmethod semanticdb-deep-find-tags-by-name-regexp-method
- ((table semanticdb-table-emacs-lisp) regex &optional tags)
- "Find all tags with name matching REGEX in TABLE.
-Optional argument TAGS is a list of tags to search.
-Like `semanticdb-find-tags-by-name-method' for Emacs Lisp."
- (semanticdb-find-tags-by-name-regexp-method table regex tags))
-
-(cl-defmethod semanticdb-deep-find-tags-for-completion-method
- ((table semanticdb-table-emacs-lisp) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
-Optional argument TAGS is a list of tags to search.
-Like `semanticdb-find-tags-for-completion-method' for Emacs Lisp."
- (semanticdb-find-tags-for-completion-method table prefix tags))
-
-;;; Advanced Searches
-;;
-(cl-defmethod semanticdb-find-tags-external-children-of-type-method
- ((_table semanticdb-table-emacs-lisp) type &optional tags)
- "Find all nonterminals which are child elements of TYPE.
-Optional argument TAGS is a list of tags to search.
-Return a list of tags."
- (if tags (cl-call-next-method)
- ;; EIEIO is the only time this matters
- (when (featurep 'eieio)
- (let* ((class (intern-soft type))
- (taglst (when class
- (delq nil
- (mapcar #'semanticdb-elisp-sym->tag
- ;; Fancy eieio function that knows all about
- ;; built in methods belonging to CLASS.
- (cl-generic-all-functions class)))))
- )
- taglst))))
-
-(provide 'semantic/db-el)
-
-;;; semantic/db-el.el ends here
+++ /dev/null
-;;; semantic/db-file.el --- Save a semanticdb to a cache file. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: tags
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; A set of semanticdb classes for persistently saving caches on disk.
-;;
-
-(require 'semantic/db)
-(require 'cedet-files)
-(require 'data-debug)
-
-(defvar semanticdb-file-version "2.2"
- "Version of semanticdb we are writing files to disk with.")
-(defvar semanticdb-file-incompatible-version "1.4"
- "Version of semanticdb we are not reverse compatible with.")
-
-;;; Settings
-;;
-(defcustom semanticdb-default-file-name "semantic.cache"
- "File name of the semantic tag cache."
- :group 'semanticdb
- :type 'string)
-
-(defcustom semanticdb-default-save-directory
- (locate-user-emacs-file "semanticdb" ".semanticdb")
- "Directory name where semantic cache files are stored.
-By default, it is either ~/.emacs.d/semanticdb, or ~/.semanticdb depending
-on which exists.
-If this value is nil, files are saved in the current directory. If the value
-is a valid directory, then it overrides `semanticdb-default-file-name' and
-stores caches in a coded file name in this directory."
- :group 'semanticdb
- :type '(choice :tag "Default-Directory"
- :menu-tag "Default-Directory"
- (const :tag "Use current directory" :value nil)
- (directory)))
-
-(defcustom semanticdb-persistent-path '(always)
- "List of valid paths that semanticdb will cache tags to.
-When `global-semanticdb-minor-mode' is active, tag lists will
-be saved to disk when Emacs exits. Not all directories will have
-tags that should be saved.
-The value should be a list of valid paths. A path can be a string,
-indicating a directory in which to save a variable. An element in the
-list can also be a symbol. Valid symbols are `never', which will
-disable any saving anywhere, `always', which enables saving
-everywhere, or `project', which enables saving in any directory that
-passes a list of predicates in `semanticdb-project-predicate-functions'."
- :group 'semanticdb
- :type '(repeat (choice (string :tag "Directory") (const never) (const always)
- (const project))))
-
-(defcustom semanticdb-save-database-functions nil
- "Abnormal hook run after a database is saved.
-Each function is called with one argument, the object representing
-the database recently written."
- :group 'semanticdb
- :type 'hook)
-
-(defvar semanticdb-dir-sep-char (if (boundp 'directory-sep-char)
- (symbol-value 'directory-sep-char)
- ?/)
- "Character used for directory separation.
-Obsoleted in some versions of Emacs. Needed in others.
-NOTE: This should get deleted from semantic soon.")
-
-(defun semanticdb-fix-pathname (dir)
- "If DIR is broken, fix it.
-Force DIR to end with a /.
-Note: Same as `file-name-as-directory'.
-NOTE: This should get deleted from semantic soon."
- (file-name-as-directory dir))
-;; I didn't initially know about the above fcn. Keep the below as a
-;; reference. Delete it someday once I've proven everything is the same.
-;; (if (not (= semanticdb-dir-sep-char (aref path (1- (length path)))))
-;; (concat path (list semanticdb-dir-sep-char))
-;; path))
-
-;;; Classes
-;;
-;;;###autoload
-(defclass semanticdb-project-database-file (semanticdb-project-database
- eieio-persistent)
- ((file-header-line :initform ";; SEMANTICDB Tags save file")
- (do-backups :initform nil)
- (semantic-tag-version :initarg :semantic-tag-version
- :initform "1.4"
- :documentation
- "The version of the tags saved.
-The default value is 1.4. In semantic 1.4 there was no versioning, so
-when those files are loaded, this becomes the version number.
-To save the version number, we must hand-set this version string.")
- (semanticdb-version :initarg :semanticdb-version
- :initform "1.4"
- :documentation
- "The version of the object system saved.
-The default value is 1.4. In semantic 1.4, there was no versioning,
-so when those files are loaded, this becomes the version number.
-To save the version number, we must hand-set this version string.")
- )
- "Database of file tables saved to disk.")
-
-;;; Code:
-;;
-(cl-defmethod semanticdb-create-database ((dbc (subclass semanticdb-project-database-file))
- directory)
- "Create a new semantic database for DIRECTORY and return it.
-If a database for DIRECTORY has already been loaded, return it.
-If a database for DIRECTORY exists, then load that database, and return it.
-If DIRECTORY doesn't exist, create a new one."
- ;; Make sure this is fully expanded so we don't get duplicates.
- (setq directory (file-truename directory))
- (let* ((fn (semanticdb-cache-filename dbc directory))
- (db (or (semanticdb-file-loaded-p fn)
- (if (file-exists-p fn)
- (progn
- (semanticdb-load-database fn))))))
- (unless db
- (setq db (make-instance
- dbc ; Create the database requested. Perhaps
- (concat (file-name-nondirectory
- (directory-file-name
- directory))
- "/")
- :file fn :tables nil
- :semantic-tag-version semantic-tag-version
- :semanticdb-version semanticdb-file-version)))
- ;; Set this up here. We can't put it in the constructor because it
- ;; would be saved, and we want DB files to be portable.
- (oset db reference-directory directory)
- db))
-
-;;; File IO
-
-(defun semanticdb-load-database (filename)
- "Load the database FILENAME."
- (condition-case foo
- (let* ((r (eieio-persistent-read filename
- 'semanticdb-project-database-file))
- (c (semanticdb-get-database-tables r))
- (tv (oref r semantic-tag-version))
- (fv (oref r semanticdb-version)))
- ;; Restore the parent-db connection
- (while c
- (oset (car c) parent-db r)
- (setq c (cdr c)))
- (unless (and (equal semanticdb-file-version fv)
- (equal semantic-tag-version tv))
- ;; Version is not ok. Flush whole system
- (message "semanticdb file is old. Starting over for %s" filename)
- ;; This database is so old, we need to replace it.
- ;; We also need to delete it from the instance tracker.
- (delete-instance r)
- (setq r nil))
- r)
- (error (message "Cache Error: [%s] %s, Restart"
- filename foo)
- nil)))
-
-(defun semanticdb-file-loaded-p (filename)
- "Return the project belonging to FILENAME if it was already loaded."
- (eieio-instance-tracker-find filename 'file 'semanticdb-database-list))
-
-(cl-defmethod semanticdb-file-directory-exists-p ((DB semanticdb-project-database-file)
- &optional suppress-questions)
- "Does the directory the database DB needs to write to exist?
-If SUPPRESS-QUESTIONS, then do not ask to create the directory."
- (let ((dest (file-name-directory (oref DB file)))
- )
- (cond ((null dest)
- ;; @TODO - If it was never set up... what should we do ?
- nil)
- ((file-exists-p dest) t)
- ((or suppress-questions
- (and (boundp 'semanticdb--inhibit-make-directory)
- semanticdb--inhibit-make-directory))
- nil)
- ((y-or-n-p (format "Create directory %s for SemanticDB? " dest))
- (make-directory dest t)
- t)
- (t
- (if (boundp 'semanticdb--inhibit-make-directory)
- (setq semanticdb--inhibit-make-directory t))
- nil))))
-
-(cl-defmethod semanticdb-save-db ((DB semanticdb-project-database-file)
- &optional
- suppress-questions)
- "Write out the database DB to its file.
-If DB is not specified, then use the current database."
- (let ((objname (oref DB file)))
- (when (and (semanticdb-dirty-p DB)
- (semanticdb-live-p DB)
- (semanticdb-file-directory-exists-p DB suppress-questions)
- (semanticdb-write-directory-p DB)
- )
- ;;(message "Saving tag summary for %s..." objname)
- (condition-case foo
- (eieio-persistent-save (or DB semanticdb-current-database))
- (file-error ; System error saving? Ignore it.
- (message "%S: %s" foo objname))
- (error
- (cond
- ((and (listp foo)
- (stringp (nth 1 foo))
- (string-match "write[- ]protected" (nth 1 foo)))
- (message (nth 1 foo)))
- ((and (listp foo)
- (stringp (nth 1 foo))
- (string-match "no such directory" (nth 1 foo)))
- (message (nth 1 foo)))
- (t
- ;; @todo - It should ask if we are not called from a hook.
- ;; How?
- (if (or suppress-questions
- (y-or-n-p (format "Skip Error: %s ?" (car (cdr foo)))))
- (message "Save Error: %S: %s" (car (cdr foo))
- objname)
- (error "%S" (car (cdr foo))))))))
- (run-hook-with-args 'semanticdb-save-database-functions
- (or DB semanticdb-current-database))
- ;;(message "Saving tag summary for %s...done" objname)
- )
- ))
-
-(cl-defmethod semanticdb-live-p ((obj semanticdb-project-database))
- "Return non-nil if the file associated with OBJ is live.
-Live databases are objects associated with existing directories."
- (and (slot-boundp obj 'reference-directory)
- (file-exists-p (oref obj reference-directory))))
-
-(cl-defmethod semanticdb-live-p ((obj semanticdb-table))
- "Return non-nil if the file associated with OBJ is live.
-Live files are either buffers in Emacs, or files existing on the filesystem."
- (let ((full-filename (semanticdb-full-filename obj)))
- (or (find-buffer-visiting full-filename)
- (file-exists-p full-filename))))
-
-(defvar semanticdb-data-debug-on-write-error nil
- "Run the data debugger on tables that issue errors.
-This variable is set to nil after the first error is encountered
-to prevent overload.")
-
-(declare-function data-debug-insert-thing "data-debug")
-
-(cl-defmethod object-write ((obj semanticdb-table))
- "When writing a table, we have to make sure we deoverlay it first.
-Restore the overlays after writing.
-Argument OBJ is the object to write."
- (when (semanticdb-live-p obj)
- (when (semanticdb-in-buffer-p obj)
- (with-current-buffer (semanticdb-in-buffer-p obj)
- (save-excursion
- ;; Make sure all our tag lists are up to date.
- (semantic-fetch-tags)
-
- ;; Try to get an accurate unmatched syntax table.
- (when (and (boundp semantic-show-unmatched-syntax-mode)
- semantic-show-unmatched-syntax-mode)
- ;; Only do this if the user runs unmatched syntax
- ;; mode display entries.
- (oset obj unmatched-syntax
- (semantic-show-unmatched-lex-tokens-fetch))
- )
-
- ;; Make sure pointmax is up to date
- (oset obj pointmax (point-max))
- )))
-
- ;; Make sure that the file size and other attributes are
- ;; up to date.
- (let ((fattr (file-attributes (semanticdb-full-filename obj))))
- (oset obj fsize (file-attribute-size fattr))
- (oset obj lastmodtime (file-attribute-modification-time fattr))
- )
-
- ;; Do it!
- (condition-case tableerror
- (cl-call-next-method)
- (error
- (when semanticdb-data-debug-on-write-error
- (require 'data-debug)
- (data-debug-new-buffer (concat "*SEMANTICDB ERROR*"))
- (data-debug-insert-thing obj "*" "")
- (setq semanticdb-data-debug-on-write-error nil))
- (message "Error Writing Table: %s" (eieio-object-name obj))
- (error "%S" (car (cdr tableerror)))))
-
- ;; Clear the dirty bit.
- (oset obj dirty nil)
- ))
-
-;;; State queries
-;;
-(cl-defmethod semanticdb-write-directory-p ((obj semanticdb-project-database-file))
- "Return non-nil if OBJ should be written to disk.
-Uses `semanticdb-persistent-path' to determine the return value."
- (let ((path semanticdb-persistent-path))
- (catch 'found
- (while path
- (cond ((stringp (car path))
- (if (string= (oref obj reference-directory) (car path))
- (throw 'found t)))
- ((eq (car path) 'project)
- ;; @TODO - EDE causes us to go in here and disable
- ;; the old default 'always save' setting.
- ;;
- ;; With new default 'always' should I care?
- (if semanticdb-project-predicate-functions
- (if (run-hook-with-args-until-success
- 'semanticdb-project-predicate-functions
- (oref obj reference-directory))
- (throw 'found t))
- ;; If the mode is 'project, and there are no project
- ;; modes, then just always save the file. If users
- ;; wish to restrict the search, modify
- ;; `semanticdb-persistent-path' to include desired paths.
- (if (= (length semanticdb-persistent-path) 1)
- (throw 'found t))
- ))
- ((eq (car path) 'never)
- (throw 'found nil))
- ((eq (car path) 'always)
- (throw 'found t))
- (t (error "Invalid path %S" (car path))))
- (setq path (cdr path)))
- (cl-call-next-method))
- ))
-
-;;; Filename manipulation
-;;
-(cl-defmethod semanticdb-file-table ((obj semanticdb-project-database-file) filename)
- "From OBJ, return FILENAME's associated table object."
- ;; Cheater option. In this case, we always have files directly
- ;; under ourselves. The main project type may not.
- (object-assoc (file-name-nondirectory filename) 'file (oref obj tables)))
-
-(cl-defmethod semanticdb-file-name-non-directory
- ((_dbclass (subclass semanticdb-project-database-file)))
- "Return the file name DBCLASS will use.
-File name excludes any directory part."
- semanticdb-default-file-name)
-
-(cl-defmethod semanticdb-file-name-directory
- ((_dbclass (subclass semanticdb-project-database-file)) directory)
- "Return the relative directory to where DBCLASS will save its cache file.
-The returned path is related to DIRECTORY."
- (if semanticdb-default-save-directory
- (let ((file (cedet-directory-name-to-file-name directory)))
- ;; Now create a filename for the cache file in
- ;; ;`semanticdb-default-save-directory'.
- (expand-file-name
- file (file-name-as-directory semanticdb-default-save-directory)))
- directory))
-
-(cl-defmethod semanticdb-cache-filename
- ((dbclass (subclass semanticdb-project-database-file)) path)
- "For DBCLASS, return a file to a cache file belonging to PATH.
-This could be a cache file in the current directory, or an encoded file
-name in a secondary directory."
- ;; Use concat and not expand-file-name, because the dir part
- ;; may include some of the file name.
- (concat (semanticdb-file-name-directory dbclass path)
- (semanticdb-file-name-non-directory dbclass)))
-
-(cl-defmethod semanticdb-full-filename ((obj semanticdb-project-database-file))
- "Fetch the full filename that OBJ refers to."
- (oref obj file))
-
-;;; FLUSH OLD FILES
-;;
-(defun semanticdb-cleanup-cache-files (&optional noerror)
- "Cleanup any cache files associated with directories that no longer exist.
-Optional NOERROR prevents errors from being displayed."
- (interactive)
- (when (and (not semanticdb-default-save-directory)
- (not noerror))
- (error "No default save directory for semantic-save files"))
-
- (when semanticdb-default-save-directory
-
- ;; Calculate all the cache files we have.
- (let* ((regexp (regexp-quote semanticdb-default-file-name))
- (files (directory-files semanticdb-default-save-directory
- t regexp))
- (orig nil)
- (to-delete nil))
- (dolist (F files)
- (setq orig (cedet-file-name-to-directory-name
- (file-name-nondirectory F)))
- (when (not (file-exists-p (file-name-directory orig)))
- (setq to-delete (cons F to-delete))
- ))
- (if to-delete
- (save-window-excursion
- (let ((buff (get-buffer-create "*Semanticdb Delete*")))
- (with-current-buffer buff
- (erase-buffer)
- (insert "The following Cache files appear to be obsolete.\n\n")
- (dolist (F to-delete)
- (insert F "\n")))
- (pop-to-buffer buff t t)
- (fit-window-to-buffer (get-buffer-window buff) nil 1)
- (when (y-or-n-p "Delete Old Cache Files? ")
- (mapc (lambda (F)
- (message "Deleting to %s..." F)
- (delete-file F))
- to-delete)
- (message "done."))
- ))
- ;; No files to delete
- (when (not noerror)
- (message "No obsolete semanticdb.cache files."))
- ))))
-
-(provide 'semantic/db-file)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/db-file"
-;; End:
-
-;;; semantic/db-file.el ends here
+++ /dev/null
-;;; semantic/db-find.el --- Searching through semantic databases. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: tags
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Databases of various forms can all be searched.
-;; There are a few types of searches that can be done:
-;;
-;; Basic Name Search:
-;; These searches scan a database table collection for tags based
-;; on name.
-;;
-;; Basic Attribute Search:
-;; These searches allow searching on specific attributes of tags,
-;; such as name, type, or other attribute.
-;;
-;; Advanced Search:
-;; These are searches that were needed to accomplish some
-;; specialized tasks as discovered in utilities. Advanced searches
-;; include matching methods defined outside some parent class.
-;;
-;; The reason for advanced searches are so that external
-;; repositories such as the Emacs obarray, or java .class files can
-;; quickly answer these needed questions without dumping the entire
-;; symbol list into Emacs for additional refinement searches via
-;; regular semanticdb search.
-;;
-;; How databases are decided upon is another important aspect of a
-;; database search. When it comes to searching for a name, there are
-;; these types of searches:
-;;
-;; Basic Search:
-;; Basic search means that tags looking for a given name start
-;; with a specific search path. Names are sought on that path
-;; until it is empty or items on the path can no longer be found.
-;; Use `semanticdb-dump-all-table-summary' to test this list.
-;; Use `semanticdb-find-throttle-custom-list' to refine this list.
-;;
-;; Deep Search:
-;; A deep search will search more than just the global namespace.
-;; It will recurse into tags that contain more tags, and search
-;; those too.
-;;
-;; Brute Search:
-;; Brute search means that all tables in all databases in a given
-;; project are searched. Brute searches are the search style as
-;; written for semantic version 1.x.
-;;
-;; How does the search path work?
-;;
-;; A basic search starts with three parameters:
-;;
-;; (FINDME &optional PATH FIND-FILE-MATCH)
-;;
-;; FINDME is key to be searched for dependent on the type of search.
-;; PATH is an indicator of which tables are to be searched.
-;; FIND-FILE-MATCH indicates that any time a match is found, the
-;; file associated with the tag should be read into a file.
-;;
-;; The PATH argument is then the most interesting argument. It can
-;; have these values:
-;;
-;; nil - Take the current buffer, and use its include list
-;; buffer - Use that buffer's include list.
-;; filename - Use that file's include list. If the file is not
-;; in a buffer, see of there is a semanticdb table for it. If
-;; not, read that file into a buffer.
-;; tag - Get that tag's buffer of file file. See above.
-;; table - Search that table, and its include list.
-;;
-;; Search Results:
-;;
-;; Semanticdb returns the results in a specific format. There are a
-;; series of routines for using those results, and results can be
-;; passed in as a search-path for refinement searches with
-;; semanticdb. Apropos for semanticdb.*find-result for more.
-;;
-;; Application:
-;;
-;; Here are applications where different searches are needed which
-;; exist as of semantic 1.4.x
-;;
-;; eldoc - popup help
-;; => Requires basic search using default path. (Header files ok)
-;; tag jump - jump to a named tag
-;; => Requires a brute search using whole project. (Source files only)
-;; completion - Completing symbol names in a smart way
-;; => Basic search (headers ok)
-;; type analysis - finding type definitions for variables & fcns
-;; => Basic search (headers ok)
-;; Class browser - organize types into some structure
-;; => Brute search, or custom navigation.
-
-;; TODO:
-;; During a search, load any unloaded DB files based on paths in the
-;; current project.
-
-(require 'semantic/db)
-(require 'semantic/db-ref)
-(eval-when-compile
- (require 'semantic/find))
-
-;;; Code:
-
-(defvar data-debug-thing-alist)
-(declare-function data-debug-insert-stuff-list "data-debug")
-(declare-function data-debug-new-buffer "data-debug")
-;;;(declare-function data-debug-insert-tag-list "adebug")
-(declare-function semantic-scope-reset-cache "semantic/scope")
-(declare-function semanticdb-typecache-notify-reset "semantic/db-typecache")
-(declare-function ede-current-project "ede")
-
-(defvar semanticdb-find-throttle-custom-list
- '(set (const local)
- (const project)
- (const unloaded)
- (const system)
- (const recursive)
- (const omniscience))
- "Customization values for semanticdb find throttle.
-See `semanticdb-find-throttle' for details.")
-
-;;;###autoload
-(defcustom semanticdb-find-default-throttle
- '(local project unloaded system recursive)
- "The default throttle for `semanticdb-find' routines.
-The throttle controls how detailed the list of database
-tables is for a symbol lookup. The value is a list with
-the following keys:
- `file' - The file the search is being performed from.
- This option is here for completeness only, and
- is assumed to always be on.
- `local' - Tables from the same local directory are included.
- This includes files directly referenced by a file name
- which might be in a different directory.
- `project' - Tables from the same local project are included
- If `project' is specified, then `local' is assumed.
- `unloaded' - If a table is not in memory, load it. If it is not cached
- on disk either, get the source, parse it, and create
- the table.
- `system' - Tables from system databases. These are specifically
- tables from system header files, or language equivalent.
- `recursive' - For include based searches, includes tables referenced
- by included files.
- `omniscience' - Included system databases which are omniscience, or
- somehow know everything. Omniscience databases are found
- in `semanticdb-project-system-databases'.
- The Emacs Lisp system DB is an omniscience database."
- :group 'semanticdb
- :type semanticdb-find-throttle-custom-list)
-
-(make-variable-buffer-local 'semanticdb-find-default-throttle)
-
-(defun semanticdb-find-throttle-active-p (access-type)
- "Non-nil if ACCESS-TYPE is an active throttle type."
- (or (memq access-type semanticdb-find-default-throttle)
- (eq access-type 'file)
- (and (eq access-type 'local)
- (memq 'project semanticdb-find-default-throttle))
- ))
-
-;;; Index Class
-;;
-;; The find routines spend a lot of time looking stuff up.
-;; Use this handy search index to cache data between searches.
-;; This should allow searches to start running faster.
-(defclass semanticdb-find-search-index (semanticdb-abstract-search-index)
- ((include-path :initform nil
- :documentation
- "List of semanticdb tables from the include path.")
- (type-cache :initform nil
- :documentation
- "Cache of all the data types accessible from this file.
-Includes all types from all included files, merged namespaces, and
-expunge duplicates.")
- )
- "Concrete search index for `semanticdb-find'.
-This class will cache data derived during various searches.")
-
-(cl-defmethod semantic-reset ((idx semanticdb-find-search-index))
- "Reset the object IDX."
- (require 'semantic/scope)
- ;; Clear the include path.
- (oset idx include-path nil)
- (when (oref idx type-cache)
- (semantic-reset (oref idx type-cache)))
- ;; Clear the scope. Scope doesn't have the data it needs to track
- ;; its own reset.
- (semantic-scope-reset-cache)
- )
-
-(cl-defmethod semanticdb-synchronize ((idx semanticdb-find-search-index)
- _new-tags)
- "Synchronize the search index IDX with some NEW-TAGS."
- ;; Reset our parts.
- (semantic-reset idx)
- ;; Notify dependants by clearing their indices.
- (semanticdb-notify-references
- (oref idx table)
- (lambda (tab _me)
- (semantic-reset (semanticdb-get-table-index tab))))
- )
-
-(cl-defmethod semanticdb-partial-synchronize ((idx semanticdb-find-search-index)
- new-tags)
- "Synchronize the search index IDX with some changed NEW-TAGS."
- ;; Only reset if include statements changed.
- (if (semantic-find-tags-by-class 'include new-tags)
- (progn
- (semantic-reset idx)
- ;; Notify dependants by clearing their indices.
- (semanticdb-notify-references
- (oref idx table)
- (lambda (tab _me)
- (semantic-reset (semanticdb-get-table-index tab))))
- )
- ;; Else, not an include, by just a type.
- (when (oref idx type-cache)
- (when (semanticdb-partial-synchronize (oref idx type-cache) new-tags)
- ;; If the synchronize returns true, we need to notify.
- ;; Notify dependants by clearing their indices.
- (semanticdb-notify-references
- (oref idx table)
- (lambda (tab _me)
- (let ((tab-idx (semanticdb-get-table-index tab)))
- ;; Not a full reset?
- (when (oref tab-idx type-cache)
- (require 'semantic/db-typecache)
- (semanticdb-typecache-notify-reset
- (oref tab-idx type-cache)))
- )))
- ))
- ))
-
-
-;;; Path Translations
-;;
-;;; OVERLOAD Functions
-;;
-;; These routines needed to be overloaded by specific language modes.
-;; They are needed for translating an INCLUDE tag into a semanticdb
-;; TABLE object.
-;;;###autoload
-(define-overloadable-function semanticdb-find-translate-path (path brutish)
- "Translate PATH into a list of semantic tables.
-Path translation involves identifying the PATH input argument
-in one of the following ways:
- nil - Take the current buffer, and use its include list
- buffer - Use that buffer's include list.
- filename - Use that file's include list. If the file is not
- in a buffer, see of there is a semanticdb table for it. If
- not, read that file into a buffer.
- tag - Get that tag's buffer of file file. See above.
- table - Search that table, and its include list.
- find result - Search the results of a previous find.
-
-In addition, once the base path is found, there is the possibility of
-each added table adding yet more tables to the path, so this routine
-can return a lengthy list.
-
-If argument BRUTISH is non-nil, then instead of using the include
-list, use all tables found in the parent project of the table
-identified by translating PATH. Such searches use brute force to
-scan every available table.
-
-The return value is a list of objects of type `semanticdb-table' or
-their children. In the case of passing in a find result, the result
-is returned unchanged.
-
-This routine uses `semanticdb-find-table-for-include' to translate
-specific include tags into a semanticdb table.
-
-Note: When searching using a non-brutish method, the list of
-included files will be cached between runs. Database-references
-are used to track which files need to have their include lists
-refreshed when things change. See `semanticdb-ref-test'.
-
-Note for overloading: If you opt to overload this function for your
-major mode, and your routine takes a long time, be sure to call
-
- (semantic-throw-on-input \\='your-symbol-here)
-
-so that it can be called from the idle work handler."
- )
-
-(defun semanticdb-find-translate-path-default (path brutish)
- "Translate PATH into a list of semantic tables.
-If BRUTISH is non-nil, return all tables associated with PATH.
-Default action as described in `semanticdb-find-translate-path'."
- (if (semanticdb-find-results-p path)
- ;; nil means perform the search over these results.
- nil
- (if brutish
- (semanticdb-find-translate-path-brutish-default path)
- (semanticdb-find-translate-path-includes-default path))))
-
-;;;###autoload
-(define-overloadable-function semanticdb-find-table-for-include (includetag &optional table)
- "For a single INCLUDETAG found in TABLE, find a `semanticdb-table' object.
-INCLUDETAG is a semantic TAG of class `include'.
-TABLE is a semanticdb table that identifies where INCLUDETAG came from.
-TABLE is optional if INCLUDETAG has an overlay of :filename attribute."
- )
-
-(defun semanticdb-find-translate-path-brutish-default (path)
- "Translate PATH into a list of semantic tables.
-Default action as described in `semanticdb-find-translate-path'."
- (let ((basedb
- (cond ((null path) semanticdb-current-database)
- ((semanticdb-table-p path) (oref path parent-db))
- (t (let ((tt (semantic-something-to-tag-table path)))
- (if tt
- ;; @todo - What does this DO ??!?!
- (with-current-buffer (semantic-tag-buffer (car tt))
- semanticdb-current-database)
- semanticdb-current-database))))))
- (apply
- #'nconc
- (mapcar
- (lambda (db)
- (let ((tabs (semanticdb-get-database-tables db))
- (ret nil))
- ;; Only return tables of the same language (major-mode)
- ;; as the current search environment.
- (while tabs
-
- (semantic-throw-on-input 'translate-path-brutish)
-
- (if (semanticdb-equivalent-mode-for-search (car tabs)
- (current-buffer))
- (setq ret (cons (car tabs) ret)))
- (setq tabs (cdr tabs)))
- ret))
- ;; FIXME:
- ;; This should scan the current project directory list for all
- ;; semanticdb files, perhaps handling proxies for them.
- (semanticdb-current-database-list
- (if basedb (oref basedb reference-directory)
- default-directory))))
- ))
-
-(defun semanticdb-find-incomplete-cache-entries-p (cache)
- "Are there any incomplete entries in CACHE?"
- (let ((ans nil))
- (dolist (tab cache)
- (when (and (cl-typep tab 'semanticdb-table)
- (not (number-or-marker-p (oref tab pointmax))))
- (setq ans t))
- )
- ans))
-
-(defun semanticdb-find-need-cache-update-p (table)
- "Non-nil if the semanticdb TABLE cache needs to be updated."
- ;; If we were passed in something related to a TABLE,
- ;; do a caching lookup.
- (let* ((index (semanticdb-get-table-index table))
- (cache (when index (oref index include-path)))
- (incom (semanticdb-find-incomplete-cache-entries-p cache))
- (unl (semanticdb-find-throttle-active-p 'unloaded))
- )
- (if (and
- cache ;; Must have a cache
- (or
- ;; If all entries are "full", or if 'unloaded
- ;; OR
- ;; is not in the throttle, it is ok to use the cache.
- (not incom) (not unl)
- ))
- nil
- ;;cache
- ;; ELSE
- ;;
- ;; We need an update.
- t))
- )
-
-(defun semanticdb-find-translate-path-includes-default (path)
- "Translate PATH into a list of semantic tables.
-Default action as described in `semanticdb-find-translate-path'."
- (let ((table (cond ((null path)
- semanticdb-current-table)
- ((bufferp path)
- (buffer-local-value 'semanticdb-current-table path))
- ((and (stringp path) (file-exists-p path))
- (semanticdb-file-table-object path t))
- ((cl-typep path 'semanticdb-abstract-table)
- path)
- (t nil))))
- (if table
- ;; If we were passed in something related to a TABLE,
- ;; do a caching lookup.
- (let ((index (semanticdb-get-table-index table)))
- (if (semanticdb-find-need-cache-update-p table)
- ;; Let's go look up our indices.
- (let ((ans (semanticdb-find-translate-path-includes--internal path)))
- (oset index include-path ans)
- ;; Once we have our new indices set up, notify those
- ;; who depend on us if we found something for them to
- ;; depend on.
- (when ans (semanticdb-refresh-references table))
- ans)
- ;; ELSE
- ;;
- ;; Just return the cache.
- (oref index include-path)))
- ;; If we were passed in something like a tag list, or other boring
- ;; searchable item, then instead do the regular thing without caching.
- (semanticdb-find-translate-path-includes--internal path))))
-
-(defvar-local semanticdb-find-lost-includes nil
- "Include files that we cannot find associated with this buffer.")
-
-(defvar-local semanticdb-find-scanned-include-tags nil
- "All include tags scanned, plus action taken on the tag.
-Each entry is an alist:
- (ACTION . TAG)
-where ACTION is one of `scanned', `duplicate', `lost'
-and TAG is a clone of the include tag that was found.")
-
-(defvar semanticdb-implied-include-tags nil
- "Include tags implied for all files of a given mode.
-Set this variable with `defvar-mode-local' for a particular mode so
-that any symbols that exist for all files for that mode are included.
-
-Note: This could be used as a way to write a file in a language
-to declare all the built-ins for that language.")
-
-(defun semanticdb-find-translate-path-includes--internal (path)
- "Internal implementation of `semanticdb-find-translate-path-includes-default'.
-This routine does not depend on the cache, but will always derive
-a new path from the provided PATH."
- (let ((includetags nil)
- (curtable nil)
- (matchedtables (list semanticdb-current-table))
- (matchedincludes nil)
- (lostincludes nil)
- (scannedincludes nil)
- (incfname nil)
- nexttable)
- (cond ((null path)
- (semantic-refresh-tags-safe)
- (setq includetags (append
- (semantic-find-tags-included (current-buffer))
- semanticdb-implied-include-tags)
- curtable semanticdb-current-table
- incfname (buffer-file-name))
- )
- ((semanticdb-table-p path)
- (setq includetags (semantic-find-tags-included path)
- curtable path
- incfname (semanticdb-full-filename path))
- )
- ((bufferp path)
- (with-current-buffer path
- (semantic-refresh-tags-safe))
- (setq includetags (semantic-find-tags-included path)
- curtable (with-current-buffer path
- semanticdb-current-table)
- incfname (buffer-file-name path)))
- (t
- (setq includetags (semantic-find-tags-included path))
- (when includetags
- ;; If we have some tags, derive a table from them.
- ;; else we will do nothing, so the table is useless.
-
- ;; @todo - derive some tables
- (message "Need to derive tables for %S in translate-path-includes--default."
- path)
- )))
-
- ;; Make sure each found include tag has an originating file name associated
- ;; with it.
- (when incfname
- (dolist (it includetags)
- (semantic--tag-put-property it :filename incfname)))
-
- ;; Loop over all include tags adding to matchedtables
- (while includetags
- (semantic-throw-on-input 'semantic-find-translate-path-includes-default)
-
- ;; If we've seen this include string before, lets skip it.
- (if (member (semantic-tag-name (car includetags)) matchedincludes)
- (progn
- (setq nexttable nil)
- (push (cons 'duplicate (semantic-tag-clone (car includetags)))
- scannedincludes)
- )
- (setq nexttable (semanticdb-find-table-for-include (car includetags) curtable))
- (when (not nexttable)
- ;; Save the lost include.
- (push (car includetags) lostincludes)
- (push (cons 'lost (semantic-tag-clone (car includetags)))
- scannedincludes)
- )
- )
-
- ;; Push the include file, so if we can't find it, we only
- ;; can't find it once.
- (push (semantic-tag-name (car includetags)) matchedincludes)
-
- ;; (message "Scanning %s" (semantic-tag-name (car includetags)))
- (when (and nexttable
- (not (memq nexttable matchedtables))
- (semanticdb-equivalent-mode-for-search nexttable
- (current-buffer))
- )
- ;; Add to list of tables
- (push nexttable matchedtables)
-
- ;; Queue new includes to list
- (if (semanticdb-find-throttle-active-p 'recursive)
- ;; @todo - recursive includes need to have the originating
- ;; buffer's location added to the path.
- (let ((newtags
- (cond
- ((semanticdb-table-p nexttable)
- (semanticdb-refresh-table nexttable)
- ;; Use the method directly, or we will recurse
- ;; into ourselves here.
- (semanticdb-find-tags-by-class-method
- nexttable 'include))
- (t ;; @todo - is this ever possible???
- (message "semanticdb-ftp - how did you do that?")
- (semantic-find-tags-included
- (semanticdb-get-tags nexttable)))
- ))
- (newincfname (semanticdb-full-filename nexttable))
- )
-
- (push (cons 'scanned (semantic-tag-clone (car includetags)))
- scannedincludes)
-
- ;; Setup new tags so we know where they are.
- (dolist (it newtags)
- (semantic--tag-put-property it :filename
- newincfname))
-
- (setq includetags (nconc includetags newtags)))
- ;; ELSE - not recursive throttle
- (push (cons 'scanned-no-recurse
- (semantic-tag-clone (car includetags)))
- scannedincludes)
- )
- )
- (setq includetags (cdr includetags)))
-
- (setq semanticdb-find-lost-includes lostincludes)
- (setq semanticdb-find-scanned-include-tags (reverse scannedincludes))
-
- ;; Find all the omniscient databases for this major mode, and
- ;; add them if needed
- (when (and (semanticdb-find-throttle-active-p 'omniscience)
- semanticdb-search-system-databases)
- ;; We can append any mode-specific omniscience databases into
- ;; our search list here.
- (let ((systemdb semanticdb-project-system-databases)
- (ans nil))
- (while systemdb
- (setq ans (semanticdb-file-table
- (car systemdb)
- ;; I would expect most omniscient to return the same
- ;; thing regardless of filename, but we may have
- ;; one that can return a table of all things the
- ;; current file needs.
- (buffer-file-name (current-buffer))))
- (when (not (memq ans matchedtables))
- (setq matchedtables (cons ans matchedtables)))
- (setq systemdb (cdr systemdb))))
- )
- (nreverse matchedtables)))
-
-(define-overloadable-function semanticdb-find-load-unloaded (filename)
- "Create a database table for FILENAME if it hasn't been parsed yet.
-Assumes that FILENAME exists as a source file.
-Assumes that a preexisting table does not exist, even if it
-isn't in memory yet."
- (if (semanticdb-find-throttle-active-p 'unloaded)
- (:override)
- (semanticdb-file-table-object filename t)))
-
-(defun semanticdb-find-load-unloaded-default (filename)
- "Load an unloaded file in FILENAME using the default semanticdb loader."
- (semanticdb-file-table-object filename))
-
-;; The creation of the overload occurs above.
-(defun semanticdb-find-table-for-include-default (includetag &optional table)
- "Default implementation of `semanticdb-find-table-for-include'.
-Uses `semanticdb-current-database-list' as the search path.
-INCLUDETAG and TABLE are documented in `semanticdb-find-table-for-include'.
-Included databases are filtered based on `semanticdb-find-default-throttle'."
- (if (not (eq (semantic-tag-class includetag) 'include))
- (signal 'wrong-type-argument (list includetag 'include)))
-
- (let ((name
- ;; Note, some languages (like Emacs or Java) use include tag names
- ;; that don't represent files! We want to have file names.
- (semantic-tag-include-filename includetag))
- (originfiledir nil)
- (roots nil)
- (tmp nil)
- (ans nil))
-
- ;; INCLUDETAG should have some way to reference where it came
- ;; from! If not, TABLE should provide the way. Each time we
- ;; look up a tag, we may need to find it in some relative way
- ;; and must set our current buffer eto the origin of includetag
- ;; or nothing may work.
- (setq originfiledir
- (cond ((semantic-tag-file-name includetag)
- ;; A tag may have a buffer, or a :filename property.
- (file-name-directory (semantic-tag-file-name includetag)))
- (table
- (file-name-directory (semanticdb-full-filename table)))
- (t
- ;; @todo - what to do here? Throw an error maybe
- ;; and fix usage bugs?
- default-directory)))
-
- (cond
- ;; Step 1: Relative path name
- ;;
- ;; If the name is relative, then it should be findable as relative
- ;; to the source file that this tag originated in, and be fast.
- ;;
- ((and (semanticdb-find-throttle-active-p 'local)
- (file-exists-p (expand-file-name name originfiledir)))
-
- (setq ans (semanticdb-find-load-unloaded
- (expand-file-name name originfiledir)))
- )
- ;; Step 2: System or Project level includes
- ;;
- ((or
- ;; First, if it a system include, we can investigate that tags
- ;; dependency file
- (and (semanticdb-find-throttle-active-p 'system)
-
- ;; Sadly, not all languages make this distinction.
- ;;(semantic-tag-include-system-p includetag)
-
- ;; Here, we get local and system files.
- (setq tmp (semantic-dependency-tag-file includetag))
- )
- ;; Second, project files are active, we and we have EDE,
- ;; we can find it using the same tool.
- (and (semanticdb-find-throttle-active-p 'project)
- ;; Make sure EDE is available, and we have a project
- (featurep 'ede) (ede-current-project originfiledir)
- ;; The EDE query is hidden in this call.
- (setq tmp (semantic-dependency-tag-file includetag))
- )
- )
- (setq ans (semanticdb-find-load-unloaded tmp))
- )
- ;; Somewhere in our project hierarchy
- ;;
- ;; Remember: Roots includes system databases which can create
- ;; specialized tables we can search.
- ;;
- ;; NOTE: Not used if EDE is active!
- ((and (semanticdb-find-throttle-active-p 'project)
- ;; And don't do this if it is a system include. Not supported by all languages,
- ;; but when it is, this is a nice fast way to skip this step.
- (not (semantic-tag-include-system-p includetag))
- ;; Don't do this if we have an EDE project.
- (not (and (featurep 'ede)
- ;; Note: We don't use originfiledir here because
- ;; we want to know about the source file we are
- ;; starting from.
- (ede-current-project)))
- )
-
- (setq roots (semanticdb-current-database-list))
-
- (while (and (not ans) roots)
- (let* ((ref (if (slot-boundp (car roots) 'reference-directory)
- (oref (car roots) reference-directory)))
- (fname (cond ((null ref) nil)
- ((file-exists-p (expand-file-name name ref))
- (expand-file-name name ref))
- ((file-exists-p (expand-file-name (file-name-nondirectory name) ref))
- (expand-file-name (file-name-nondirectory name) ref)))))
- (when (and ref fname)
- ;; There is an actual file. Grab it.
- (setq ans (semanticdb-find-load-unloaded fname)))
-
- ;; ELSE
- ;;
- ;; NOTE: We used to look up omniscient databases here, but that
- ;; is now handled one layer up.
- ;;
- ;; Missing: a database that knows where missing files are. Hmm.
- ;; perhaps I need an override function for that?
-
- )
-
- (setq roots (cdr roots))))
- )
- ans))
-
-\f
-;;; Perform interactive tests on the path/search mechanisms.
-;;
-;;;###autoload
-(defun semanticdb-find-test-translate-path (&optional arg)
- "Call and output results of `semanticdb-find-translate-path'.
-With ARG non-nil, specify a BRUTISH translation.
-See `semanticdb-find-default-throttle' and `semanticdb-project-roots'
-for details on how this list is derived."
- (interactive "P")
- (semantic-fetch-tags)
- (require 'data-debug)
- (let ((start (current-time))
- (p (semanticdb-find-translate-path nil arg))
- (end (current-time))
- )
- (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*")
- (message "Search of tags took %.2f seconds."
- (semantic-elapsed-time start end))
-
- (data-debug-insert-stuff-list p "*")))
-
-(defun semanticdb-find-test-translate-path-no-loading (&optional arg)
- "Call and output results of `semanticdb-find-translate-path'.
-With ARG non-nil, specify a BRUTISH translation.
-See `semanticdb-find-default-throttle' and `semanticdb-project-roots'
-for details on how this list is derived."
- (interactive "P")
- (semantic-fetch-tags)
- (require 'data-debug)
- (let* ((semanticdb-find-default-throttle
- (if (featurep 'semantic/db-find)
- (remq 'unloaded semanticdb-find-default-throttle)
- nil))
- (start (current-time))
- (p (semanticdb-find-translate-path nil arg))
- (end (current-time))
- )
- (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*")
- (message "Search of tags took %.2f seconds."
- (semantic-elapsed-time start end))
-
- (data-debug-insert-stuff-list p "*")))
-
-;;;###autoload
-(defun semanticdb-find-adebug-lost-includes ()
- "Translate the current path, then display the lost includes.
-Examines the variable `semanticdb-find-lost-includes'."
- (interactive)
- (require 'data-debug)
- (semanticdb-find-translate-path nil nil)
- (let ((lost semanticdb-find-lost-includes)
- )
-
- (if (not lost)
- (message "There are no unknown includes for %s"
- (buffer-name))
-
- (data-debug-new-buffer "*SEMANTICDB lost-includes ADEBUG*")
- ;; (data-debug-insert-tag-list lost "*")
- )))
-
-(defun semanticdb-find-adebug-insert-scanned-tag-cons (consdata prefix prebuttontext)
- "Insert a button representing scanned include CONSDATA.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between prefix and the overlay button."
- (let* ((start (point))
- (end nil)
- (mode (car consdata))
- (tag (cdr consdata))
- (name (semantic-tag-name tag))
- (file (semantic-tag-file-name tag))
- (str1 (format "%S %s" mode name))
- (str2 (format " : %s" file))
- ;; (tip nil)
- )
- (insert prefix prebuttontext str1)
- (setq end (point))
- (insert str2)
- (put-text-property start end 'face
- (cond ((eq mode 'scanned)
- 'font-lock-function-name-face)
- ((eq mode 'duplicate)
- 'font-lock-comment-face)
- ((eq mode 'lost)
- 'font-lock-variable-name-face)
- ((eq mode 'scanned-no-recurse)
- 'font-lock-type-face)))
- (put-text-property start end 'ddebug (cdr consdata))
- (put-text-property start end 'ddebug-indent(length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- ;; (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-tag-parts-from-point)
- (insert "\n")
- )
- )
-
-(defun semanticdb-find-adebug-scanned-includes ()
- "Translate the current path, then display the lost includes.
-Examines the variable `semanticdb-find-lost-includes'."
- (interactive)
- (require 'data-debug)
- (semanticdb-find-translate-path nil nil)
- (let ((scanned semanticdb-find-scanned-include-tags)
- (data-debug-thing-alist
- (cons
- '((lambda (thing) (and (consp thing)
- (symbolp (car thing))
- (memq (car thing)
- '(scanned scanned-no-recurse
- lost duplicate))))
- . semanticdb-find-adebug-insert-scanned-tag-cons)
- data-debug-thing-alist))
- )
-
- (if (not scanned)
- (message "There are no includes scanned %s"
- (buffer-name))
-
- (data-debug-new-buffer "*SEMANTICDB scanned-includes ADEBUG*")
- (data-debug-insert-stuff-list scanned "*")
- )))
-\f
-;;; API Functions
-;;
-;; Once you have a search result, use these routines to operate
-;; on the search results at a higher level
-
-;;;###autoload
-(defun semanticdb-strip-find-results (results &optional find-file-match)
- "Strip a semanticdb search RESULTS to exclude objects.
-This makes it appear more like the results of a `semantic-find-' call.
-Optional FIND-FILE-MATCH loads all files associated with RESULTS
-into buffers. This has the side effect of enabling `semantic-tag-buffer' to
-return a value.
-If FIND-FILE-MATCH is `name', then only the filename is stored
-in each tag instead of loading each file into a buffer.
-If the input RESULTS are not going to be used again, and if
-FIND-FILE-MATCH is nil, you can use `semanticdb-fast-strip-find-results'
-instead."
- (if find-file-match
- ;; Load all files associated with RESULTS.
- (let ((tmp results)
- (output nil))
- (while tmp
- (let ((tab (car (car tmp)))
- (tags (cdr (car tmp))))
- (dolist (T tags)
- ;; Normalization gives specialty database tables a chance
- ;; to convert into a more stable tag format.
- (let* ((norm (semanticdb-normalize-one-tag tab T))
- (ntab (car norm))
- (ntag (cdr norm))
- (nametable ntab))
-
- ;; If it didn't normalize, use what we had.
- (if (not norm)
- (setq nametable tab)
- (setq output (append output (list ntag))))
-
- ;; Find-file-match allows a tool to make sure the tag is
- ;; 'live', somewhere in a buffer.
- (cond ((eq find-file-match 'name)
- (or (semantic--tag-get-property ntag :filename)
- (let ((f (semanticdb-full-filename nametable)))
- (semantic--tag-put-property ntag :filename f))))
- ((and find-file-match ntab)
- (semanticdb-get-buffer ntab))
- )
- ))
- )
- (setq tmp (cdr tmp)))
- output)
- ;; @todo - I could use nconc, but I don't know what the caller may do with
- ;; RESULTS after this is called. Right now semantic-complete will
- ;; recycling the input after calling this routine.
- (apply #'append (mapcar #'cdr results))))
-
-(defun semanticdb-fast-strip-find-results (results)
- "Destructively strip a semanticdb search RESULTS to exclude objects.
-This makes it appear more like the results of a `semantic-find-' call.
-This is like `semanticdb-strip-find-results', except the input list RESULTS
-will be changed."
- (mapcan #'cdr results))
-
-(defun semanticdb-find-results-p (resultp)
- "Non-nil if RESULTP is in the form of a semanticdb search result.
-This query only really tests the first entry in the list that is RESULTP,
-but should be good enough for debugging assertions."
- (and (listp resultp)
- (listp (car resultp))
- (cl-typep (car (car resultp)) 'semanticdb-abstract-table)
- (or (semantic-tag-p (car (cdr (car resultp))))
- (null (car (cdr (car resultp)))))))
-
-(defun semanticdb-find-result-prin1-to-string (result)
- "If RESULT satisfies `semanticdb-find-results-p', provide a short PRIN1 output."
- (if (< (length result) 2)
- (concat "#<FIND RESULT "
- (mapconcat (lambda (a)
- (concat "(" (eieio-object-name (car a) ) " . "
- "#<TAG LIST " (number-to-string (length (cdr a))) ">)"))
- result
- " ")
- ">")
- ;; Longer results should have an abbreviated form.
- (format "#<FIND RESULT %d TAGS in %d FILES>"
- (semanticdb-find-result-length result)
- (length result))))
-
-(cl-deftype semanticdb-find-result-with-nil ()
- '(satisfies semanticdb-find-result-with-nil-p))
-
-(defun semanticdb-find-result-with-nil-p (resultp)
- "Non-nil if RESULTP is in the form of a semanticdb search result.
-The value nil is valid where a TABLE usually is, but only if the TAG
-results include overlays.
-This query only really tests the first entry in the list that is RESULTP,
-but should be good enough for debugging assertions."
- (and (listp resultp)
- (listp (car resultp))
- (let ((tag-to-test (car-safe (cdr (car resultp)))))
- (or (and (cl-typep (car (car resultp)) 'semanticdb-abstract-table)
- (or (semantic-tag-p tag-to-test)
- (null tag-to-test)))
- (and (null (car (car resultp)))
- (or (semantic-tag-with-position-p tag-to-test)
- (null tag-to-test))))
- )))
-
-;;;###autoload
-(defun semanticdb-find-result-length (result)
- "Number of tags found in RESULT."
- (let ((count 0))
- (mapc (lambda (onetable)
- (setq count (+ count (1- (length onetable)))))
- result)
- count))
-
-;;;###autoload
-(defun semanticdb-find-result-nth (result n)
- "In RESULT, return the Nth search result.
-This is a 0 based search result, with the first match being element 0.
-
-The returned value is a cons cell: (TAG . TABLE) where TAG
-is the tag at the Nth position. TABLE is the semanticdb table where
-the TAG was found. Sometimes TABLE can be nil."
- (let ((ans nil)
- (anstable nil))
- ;; Loop over each single table hit.
- (while (and (not ans) result)
- ;; For each table result, get local length, and modify
- ;; N to be that much less.
- (let ((ll (length (cdr (car result))))) ;; local length
- (if (> ll n)
- ;; We have a local match.
- (setq ans (nth n (cdr (car result)))
- anstable (car (car result)))
- ;; More to go. Decrement N.
- (setq n (- n ll))))
- ;; Keep moving.
- (setq result (cdr result)))
- (cons ans anstable)))
-
-(defun semanticdb-find-result-test (result)
- "Test RESULT by accessing all the tags in the list."
- (if (not (semanticdb-find-results-p result))
- (error "Does not pass `semanticdb-find-results-p.\n"))
- (let ((len (semanticdb-find-result-length result))
- (i 0))
- (while (< i len)
- (let ((tag (semanticdb-find-result-nth result i)))
- (if (not (semantic-tag-p (car tag)))
- (error "%d entry is not a tag" i)))
- (setq i (1+ i)))))
-
-;;;###autoload
-(defun semanticdb-find-result-nth-in-buffer (result n)
- "In RESULT, return the Nth search result.
-Like `semanticdb-find-result-nth', except that only the TAG
-is returned, and the buffer it is found it will be made current.
-If the result tag has no position information, the originating buffer
-is still made current."
- (let* ((ret (semanticdb-find-result-nth result n))
- (ans (car ret))
- (anstable (cdr ret)))
- ;; If we have a hit, double-check the find-file
- ;; entry. If the file must be loaded, then gat that table's
- ;; source file into a buffer.
-
- (if anstable
- (let ((norm (semanticdb-normalize-one-tag anstable ans)))
- (when norm
- ;; The normalized tags can now be found based on that
- ;; tags table.
- (condition-case nil
- (progn
- (semanticdb-set-buffer (car norm))
- ;; Now reset ans
- (setq ans (cdr norm)))
- ;; Don't error for this case, but don't store
- ;; the thing either.
- (no-method-definition nil))
- ))
- )
- ;; Return the tag.
- ans))
-
-(defun semanticdb-find-result-mapc (fcn result)
- "Apply FCN to each element of find RESULT for side-effects only.
-FCN takes two arguments. The first is a TAG, and the
-second is a DB from whence TAG originated.
-Returns result."
- (mapc (lambda (sublst-icky)
- (mapc (lambda (tag-icky)
- (funcall fcn tag-icky (car sublst-icky)))
- (cdr sublst-icky)))
- result)
- result)
-
-;;; Search Logging
-;;
-;; Basic logging to see what the search routines are doing.
-(defvar semanticdb-find-log-flag nil
- "Non-nil means log the process of searches.")
-
-(defvar semanticdb-find-log-buffer-name "*SemanticDB Find Log*"
- "The name of the logging buffer.")
-
-(defun semanticdb-find-toggle-logging ()
- "Toggle semanticdb logging."
- (interactive)
- (setq semanticdb-find-log-flag (null semanticdb-find-log-flag))
- (message "Semanticdb find logging is %sabled"
- (if semanticdb-find-log-flag "en" "dis")))
-
-(defun semanticdb-reset-log ()
- "Reset the log buffer."
- (interactive)
- (when semanticdb-find-log-flag
- (with-current-buffer (get-buffer-create semanticdb-find-log-buffer-name)
- (erase-buffer)
- )))
-
-(defun semanticdb-find-log-move-to-end ()
- "Move to the end of the semantic log."
- (let ((cb (current-buffer))
- (cw (selected-window)))
- (unwind-protect
- (progn
- (set-buffer semanticdb-find-log-buffer-name)
- (if (get-buffer-window (current-buffer) 'visible)
- (select-window (get-buffer-window (current-buffer) 'visible)))
- (goto-char (point-max)))
- (if cw (select-window cw))
- (set-buffer cb))))
-
-(defun semanticdb-find-log-new-search (forwhat)
- "Start a new search FORWHAT."
- (when semanticdb-find-log-flag
- (with-current-buffer (get-buffer-create semanticdb-find-log-buffer-name)
- (insert (format "New Search: %S\n" forwhat))
- )
- (semanticdb-find-log-move-to-end)))
-
-(defun semanticdb-find-log-activity (table result)
- "Log that TABLE has been searched and RESULT was found."
- (when semanticdb-find-log-flag
- (with-current-buffer semanticdb-find-log-buffer-name
- (insert "Table: " (cl-prin1-to-string table)
- " Result: " (int-to-string (length result)) " tags"
- "\n")
- )
- (semanticdb-find-log-move-to-end)))
-
-;;; Semanticdb find API functions
-;; These are the routines actually used to perform searches.
-;;
-(defun semanticdb-find-tags-collector (function &optional path find-file-match
- brutish)
- "Collect all tags returned by FUNCTION over PATH.
-The FUNCTION must take two arguments. The first is TABLE,
-which is a semanticdb table containing tags. The second argument
-to FUNCTION is TAGS. TAGS may be a list of tags. If TAGS is non-nil,
-then FUNCTION should search the TAG list, not through TABLE.
-
-See `semanticdb-find-translate-path' for details on PATH.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer.
-
-Note: You should leave FIND-FILE-MATCH as nil. It is far more
-efficient to take the results from any search and use
-`semanticdb-strip-find-results' instead. This argument is here
-for backward compatibility.
-
-If optional argument BRUTISH is non-nil, then ignore include statements,
-and search all tables in this project tree."
- (let (found match)
- (save-current-buffer
- ;; If path is a buffer, set ourselves up in that buffer
- ;; so that the override methods work correctly.
- (when (bufferp path) (set-buffer path))
- (if (semanticdb-find-results-p path)
- ;; When we get find results, loop over that.
- (dolist (tableandtags path)
- (semantic-throw-on-input 'semantic-find-translate-path)
- ;; If FIND-FILE-MATCH is non-nil, skip tables of class
- ;; `semanticdb-search-results-table', since those are system
- ;; databases and not associated with a file.
- (unless (and find-file-match
- (obj-of-class-p
- (car tableandtags) 'semanticdb-search-results-table))
- (when (setq match (funcall function
- (car tableandtags) (cdr tableandtags)))
- (when find-file-match
- (save-excursion (semanticdb-set-buffer (car tableandtags))))
- (push (cons (car tableandtags) match) found)))
- )
- ;; Only log searches across data bases.
- (semanticdb-find-log-new-search nil)
- ;; If we get something else, scan the list of tables resulting
- ;; from translating it into a list of objects.
- (dolist (table (semanticdb-find-translate-path path brutish))
- (semantic-throw-on-input 'semantic-find-translate-path)
- ;; If FIND-FILE-MATCH is non-nil, skip tables of class
- ;; `semanticdb-search-results-table', since those are system
- ;; databases and not associated with a file.
- (unless (and find-file-match
- (obj-of-class-p table 'semanticdb-search-results-table))
- (when (and table (setq match (funcall function table nil)))
- (semanticdb-find-log-activity table match)
- (when find-file-match
- (save-excursion (semanticdb-set-buffer table)))
- (push (cons table match) found))))))
- ;; At this point, FOUND has had items pushed onto it.
- ;; This means items are being returned in REVERSE order
- ;; of the tables searched, so if you just get th CAR, then
- ;; too-bad, you may have some system-tag that has no
- ;; buffer associated with it.
-
- ;; It must be reversed.
- (nreverse found)))
-
-;;;###autoload
-(defun semanticdb-find-tags-by-name (name &optional path find-file-match)
- "Search for all tags matching NAME on PATH.
-See `semanticdb-find-translate-path' for details on PATH.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-by-name-method table name tags))
- path find-file-match))
-
-;;;###autoload
-(defun semanticdb-find-tags-by-name-regexp (regexp &optional path find-file-match)
- "Search for all tags matching REGEXP on PATH.
-See `semanticdb-find-translate-path' for details on PATH.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-by-name-regexp-method table regexp tags))
- path find-file-match))
-
-;;;###autoload
-(defun semanticdb-find-tags-for-completion (prefix &optional path find-file-match)
- "Search for all tags matching PREFIX on PATH.
-See `semanticdb-find-translate-path' for details on PATH.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-for-completion-method table prefix tags))
- path find-file-match))
-
-;;;###autoload
-(defun semanticdb-find-tags-by-class (class &optional path find-file-match)
- "Search for all tags of CLASS on PATH.
-See `semanticdb-find-translate-path' for details on PATH.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-by-class-method table class tags))
- path find-file-match))
-
-;;; Deep Searches
-(defun semanticdb-deep-find-tags-by-name (name &optional path find-file-match)
- "Search for all tags matching NAME on PATH.
-Search also in all components of top level tags founds.
-See `semanticdb-find-translate-path' for details on PATH.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-by-name-method table name tags))
- path find-file-match))
-
-(defun semanticdb-deep-find-tags-by-name-regexp (regexp &optional path find-file-match)
- "Search for all tags matching REGEXP on PATH.
-Search also in all components of top level tags founds.
-See `semanticdb-find-translate-path' for details on PATH.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-by-name-regexp-method table regexp tags))
- path find-file-match))
-
-(defun semanticdb-deep-find-tags-for-completion (prefix &optional path find-file-match)
- "Search for all tags matching PREFIX on PATH.
-Search also in all components of top level tags founds.
-See `semanticdb-find-translate-path' for details on PATH.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-for-completion-method table prefix tags))
- path find-file-match))
-
-;;; Brutish Search Routines
-;;
-(defun semanticdb-brute-deep-find-tags-by-name (name &optional path find-file-match)
- "Search for all tags matching NAME on PATH.
-See `semanticdb-find-translate-path' for details on PATH.
-The argument BRUTISH will be set so that searching includes all tables
-in the current project.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-by-name-method table name tags))
- path find-file-match t))
-
-(defun semanticdb-brute-deep-find-tags-for-completion (prefix &optional path find-file-match)
- "Search for all tags matching PREFIX on PATH.
-See `semanticdb-find-translate-path' for details on PATH.
-The argument BRUTISH will be set so that searching includes all tables
-in the current project.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-deep-find-tags-for-completion-method table prefix tags))
- path find-file-match t))
-
-(defun semanticdb-brute-find-tags-by-class (class &optional path find-file-match)
- "Search for all tags of CLASS on PATH.
-See `semanticdb-find-translate-path' for details on PATH.
-The argument BRUTISH will be set so that searching includes all tables
-in the current project.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-by-class-method table class tags))
- path find-file-match t))
-
-;;; Specialty Search Routines
-(defun semanticdb-find-tags-external-children-of-type
- (type &optional path find-file-match)
- "Search for all tags defined outside of TYPE with TYPE as a parent.
-See `semanticdb-find-translate-path' for details on PATH.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-external-children-of-type-method table type tags))
- path find-file-match t))
-
-(defun semanticdb-find-tags-subclasses-of-type
- (type &optional path find-file-match)
- "Search for all tags of class type defined that subclass TYPE.
-See `semanticdb-find-translate-path' for details on PATH.
-FIND-FILE-MATCH indicates that any time a match is found, the file
-associated with that tag should be loaded into a buffer."
- (semanticdb-find-tags-collector
- (lambda (table tags)
- (semanticdb-find-tags-subclasses-of-type-method table type tags))
- path find-file-match t))
-\f
-;;; METHODS
-;;
-;; Default methods for semanticdb database and table objects.
-;; Override these with system databases to as new types of back ends.
-
-;;; Top level Searches
-(cl-defmethod semanticdb-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags)
- "In TABLE, find all occurrences of tags with NAME.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- (semantic-find-tags-by-name name
- (or tags (and (slot-boundp table 'tags)
- (semanticdb-get-tags table)))))
-
-(cl-defmethod semanticdb-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags)
- "In TABLE, find all occurrences of tags matching REGEXP.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- (semantic-find-tags-by-name-regexp regexp
- (or tags (and (slot-boundp table 'tags)
- (semanticdb-get-tags table)))))
-
-(cl-defmethod semanticdb-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- (semantic-find-tags-for-completion prefix
- (or tags (and (slot-boundp table 'tags)
- (semanticdb-get-tags table)))))
-
-(cl-defmethod semanticdb-find-tags-by-class-method ((table semanticdb-abstract-table) class &optional tags)
- "In TABLE, find all occurrences of tags of CLASS.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- ;; Delegate 'include' to the overridable
- ;; `semantic-find-tags-included', which by default will just call
- ;; `semantic-find-tags-by-class'.
- (if (eq class 'include)
- (semantic-find-tags-included
- (or tags (and (slot-boundp table 'tags)
- (semanticdb-get-tags table))))
- (semantic-find-tags-by-class class
- (or tags (and (slot-boundp table 'tags)
- (semanticdb-get-tags table))))))
-
-(declare-function semantic-find-tags-external-children-of-type
- "semantic/find" (type &optional table))
-
-(cl-defmethod semanticdb-find-tags-external-children-of-type-method ((table semanticdb-abstract-table) parent &optional tags)
- "In TABLE, find all occurrences of tags whose parent is the PARENT type.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- (require 'semantic/find)
- (semantic-find-tags-external-children-of-type
- parent (or tags (and (slot-boundp table 'tags)
- (semanticdb-get-tags table)))))
-
-(declare-function semantic-find-tags-subclasses-of-type
- "semantic/find" (type &optional table))
-
-(cl-defmethod semanticdb-find-tags-subclasses-of-type-method ((table semanticdb-abstract-table) parent &optional tags)
- "In TABLE, find all occurrences of tags whose parent is the PARENT type.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- (require 'semantic/find)
- (semantic-find-tags-subclasses-of-type
- parent (or tags (and (slot-boundp table 'tags)
- (semanticdb-get-tags table)))))
-
-;;; Deep Searches
-(cl-defmethod semanticdb-deep-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags)
- "In TABLE, find all occurrences of tags with NAME.
-Search in all tags in TABLE, and all components of top level tags in
-TABLE.
-Optional argument TAGS is a list of tags to search.
-Return a table of all matching tags."
- (semantic-find-tags-by-name
- name (semantic-flatten-tags-table
- (or tags (and (slot-boundp table 'tags)
- (semanticdb-get-tags table))))))
-
-(cl-defmethod semanticdb-deep-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags)
- "In TABLE, find all occurrences of tags matching REGEXP.
-Search in all tags in TABLE, and all components of top level tags in
-TABLE.
-Optional argument TAGS is a list of tags to search.
-Return a table of all matching tags."
- (semantic-find-tags-by-name-regexp
- regexp (semantic-flatten-tags-table
- (or tags (and (slot-boundp table 'tags)
- (semanticdb-get-tags table))))))
-
-(cl-defmethod semanticdb-deep-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
-Search in all tags in TABLE, and all components of top level tags in
-TABLE.
-Optional argument TAGS is a list of tags to search.
-Return a table of all matching tags."
- (semantic-find-tags-for-completion
- prefix
- (semantic-flatten-tags-table
- (or tags (and (slot-boundp table 'tags)
- (semanticdb-get-tags table))))))
-
-(provide 'semantic/db-find)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/db-find"
-;; End:
-
-;;; semantic/db-find.el ends here
+++ /dev/null
-;;; semantic/db-global.el --- Semantic database extensions for GLOBAL -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2002-2006, 2008-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: tags
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Use GNU Global for by-name database searches.
-;;
-;; This will work as an "omniscient" database for a given project.
-;;
-
-(require 'cedet-global)
-(require 'semantic/db-find)
-(require 'semantic/symref/global)
-
-(eval-when-compile
- ;; For generic function searching.
- (require 'eieio)
- (require 'eieio-opt)
- )
-
-;;; Code:
-
-(defvar semanticdb--ih)
-
-;;;###autoload
-(defun semanticdb-enable-gnu-global-databases (mode &optional noerror)
- "Enable the use of the GNU Global SemanticDB back end for all files of MODE.
-This will add an instance of a GNU Global database to each buffer
-in a GNU Global supported hierarchy.
-
-Two sanity checks are performed to assure (a) that GNU global program exists
-and (b) that the GNU global program version is compatibility with the database
-version. If optional NOERROR is nil, then an error may be signaled on version
-mismatch. If NOERROR is not nil, then no error will be signaled. Instead
-return value will indicate success or failure with non-nil or nil respective
-values."
- (interactive
- (list (completing-read
- "Enable in Mode: " obarray
- (lambda (s) (get s 'mode-local-symbol-table))
- t (symbol-name major-mode))))
-
- ;; First, make sure the version is ok.
- (if (not (cedet-gnu-global-version-check noerror))
- nil
- ;; Make sure mode is a symbol.
- (when (stringp mode)
- (setq mode (intern mode)))
-
- (let ((semanticdb--ih (mode-local-value mode 'semantic-init-mode-hook)))
- (eval `(setq-mode-local
- ,mode semantic-init-mode-hook
- (cons 'semanticdb-enable-gnu-global-hook ',semanticdb--ih))
- t))
- t
- )
- )
-
-(defun semanticdb-enable-gnu-global-hook ()
- "Add support for GNU Global in the current buffer via `semantic-init-hook'.
-MODE is the major mode to support."
- (semanticdb-enable-gnu-global-in-buffer t))
-
-(defclass semanticdb-project-database-global
- ;; @todo - convert to one DB per directory.
- (semanticdb-project-database eieio-instance-tracker)
-
- ;; @todo - use instance tracker symbol.
- ()
- "Database representing a GNU Global tags file.")
-
-(defun semanticdb-enable-gnu-global-in-buffer (&optional dont-err-if-not-available)
- "Enable a GNU Global database in the current buffer.
-When GNU Global is not available for this directory, display a message
-if optional DONT-ERR-IF-NOT-AVAILABLE is non-nil; else throw an error."
- (interactive "P")
- (if (cedet-gnu-global-root)
- (setq
- ;; Add to the system database list.
- semanticdb-project-system-databases
- (cons (make-instance 'semanticdb-project-database-global)
- semanticdb-project-system-databases)
- ;; Apply the throttle.
- semanticdb-find-default-throttle
- (append semanticdb-find-default-throttle
- '(omniscience))
- )
- (if dont-err-if-not-available
- nil; (message "No Global support in %s" default-directory)
- (error "No Global support in %s" default-directory))
- ))
-
-;;; Classes:
-(defclass semanticdb-table-global (semanticdb-search-results-table)
- ((major-mode :initform nil)
- )
- "A table for returning search results from GNU Global.")
-
-(cl-defmethod semanticdb-debug-info ((_obj semanticdb-table-global))
- (list "(proxy)"))
-
-(cl-defmethod cl-print-object ((obj semanticdb-table-global) stream)
- "Pretty printer extension for `semanticdb-table-global'.
-Adds the number of tags in this file to the object print name."
- (princ (eieio-object-name obj (semanticdb-debug-info obj))
- stream))
-
-(cl-defmethod semanticdb-equivalent-mode ((_table semanticdb-table-global) &optional _buffer)
- "Return t, pretend that this table's mode is equivalent to BUFFER.
-Equivalent modes are specified by the `semantic-equivalent-major-modes'
-local variable."
- ;; @todo - hack alert!
- t)
-
-;;; Filename based methods
-;;
-(cl-defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-global))
- "For a global database, there are no explicit tables.
-For each file hit, get the traditional semantic table from that file."
- ;; We need to return something since there is always the "master table"
- ;; The table can then answer file name type questions.
- (when (not (slot-boundp obj 'tables))
- (let ((newtable (make-instance 'semanticdb-table-global)))
- (oset obj tables (list newtable))
- (oset newtable parent-db obj)
- (oset newtable tags nil)
- ))
-
- (cl-call-next-method))
-
-(cl-defmethod semanticdb-file-table ((obj semanticdb-project-database-global) _filename)
- "From OBJ, return FILENAME's associated table object."
- ;; We pass in "don't load". I wonder if we need to avoid that or not?
- (car (semanticdb-get-database-tables obj))
- )
-
-;;; Search Overrides
-;;
-;; Only NAME based searches work with GLOBAL as that is all it tracks.
-;;
-(cl-defmethod semanticdb-find-tags-by-name-method
- ((_table semanticdb-table-global) name &optional tags)
- "Find all tags named NAME in TABLE.
-Return a list of tags."
- (if tags
- ;; If TAGS are passed in, then we don't need to do work here.
- (cl-call-next-method)
- ;; Call out to GNU Global for some results.
- (let* ((semantic-symref-tool 'global)
- (result (semantic-symref-find-tags-by-name name 'project))
- )
- (when result
- ;; We could ask to keep the buffer open, but that annoys
- ;; people.
- (semantic-symref-result-get-tags result))
- )))
-
-(cl-defmethod semanticdb-find-tags-by-name-regexp-method
- ((_table semanticdb-table-global) regex &optional tags)
- "Find all tags with name matching REGEX in TABLE.
-Optional argument TAGS is a list of tags to search.
-Return a list of tags."
- (if tags (cl-call-next-method)
- (let* ((semantic-symref-tool 'global)
- (result (semantic-symref-find-tags-by-regexp regex 'project))
- )
- (when result
- (semantic-symref-result-get-tags result))
- )))
-
-(cl-defmethod semanticdb-find-tags-for-completion-method
- ((_table semanticdb-table-global) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- (if tags (cl-call-next-method)
- (let* ((semantic-symref-tool 'global)
- (result (semantic-symref-find-tags-by-completion prefix 'project))
- (faketags nil)
- )
- (when result
- (dolist (T (oref result hit-text))
- ;; We should look up each tag one at a time, but I'm lazy!
- ;; Doing this may be good enough.
- (setq faketags (cons
- (semantic-tag T 'function :faux t)
- faketags))
- )
- faketags))))
-
-;;; Deep Searches
-;;
-;; If your language does not have a `deep' concept, these can be left
-;; alone, otherwise replace with implementations similar to those
-;; above.
-;;
-(cl-defmethod semanticdb-deep-find-tags-by-name-method
- ((table semanticdb-table-global) name &optional tags)
- "Find all tags name NAME in TABLE.
-Optional argument TAGS is a list of tags to search.
-Like `semanticdb-find-tags-by-name-method' for global."
- (semanticdb-find-tags-by-name-method table name tags))
-
-(cl-defmethod semanticdb-deep-find-tags-by-name-regexp-method
- ((table semanticdb-table-global) regex &optional tags)
- "Find all tags with name matching REGEX in TABLE.
-Optional argument TAGS is a list of tags to search.
-Like `semanticdb-find-tags-by-name-method' for global."
- (semanticdb-find-tags-by-name-regexp-method table regex tags))
-
-(cl-defmethod semanticdb-deep-find-tags-for-completion-method
- ((table semanticdb-table-global) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
-Optional argument TAGS is a list of tags to search.
-Like `semanticdb-find-tags-for-completion-method' for global."
- (semanticdb-find-tags-for-completion-method table prefix tags))
-
-(provide 'semantic/db-global)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/db-global"
-;; End:
-
-;;; semantic/db-global.el ends here
+++ /dev/null
-;;; semantic/db-javascript.el --- Semantic database extensions for javascript -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-
-;; Author: Joakim Verona
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semanticdb database for Javascript.
-;;
-;; This is an omniscient database with a hard-coded list of symbols for
-;; Javascript. See the doc at the end of this file for adding or modifying
-;; the list of tags.
-;;
-
-(require 'semantic/db)
-(require 'semantic/db-find)
-
-(eval-when-compile
- ;; For generic function searching.
- (require 'eieio)
- (require 'eieio-opt))
-
-;;; Code:
-(defvar semanticdb-javascript-tags
- '(("eval" function
- (:arguments
- (("x" variable nil nil nil)))
- nil nil)
- ("parseInt" function
- (:arguments
- (("string" variable nil nil nil)
- ("radix" variable nil nil nil)))
- nil nil)
- ("parseFloat" function
- (:arguments
- (("string" variable nil nil nil)))
- nil nil)
- ("isNaN" function
- (:arguments
- (("number" variable nil nil nil)))
- nil nil)
- ("isFinite" function
- (:arguments
- (("number" variable nil nil nil)))
- nil nil)
- ("decodeURI" function
- (:arguments
- (("encodedURI" variable nil nil nil)))
- nil nil)
- ("decodeURIComponent" function
- (:arguments
- (("encodedURIComponent" variable nil nil nil)))
- nil nil)
- ("encodeURI" function
- (:arguments
- (("uri" variable nil nil nil)))
- nil nil)
- ("encodeURIComponent" function
- (:arguments
- (("uriComponent" variable nil nil nil)))
- nil nil))
- "Hard-coded list of javascript tags for semanticdb.
-See bottom of this file for instructions on managing this list.")
-
-;;; Classes:
-(defclass semanticdb-table-javascript (semanticdb-search-results-table)
- ((major-mode :initform #'javascript-mode)
- )
- "A table for returning search results from javascript.")
-
-(defclass semanticdb-project-database-javascript
- (semanticdb-project-database
- eieio-singleton ;this db is for js globals, so singleton is appropriate
- )
- ((new-table-class :initform 'semanticdb-table-javascript
- :type class
- :documentation
- "New tables created for this database are of this class.")
- )
- "Database representing javascript.")
-
-;; Create the database, and add it to searchable databases for javascript mode.
-(defvar-mode-local javascript-mode semanticdb-project-system-databases
- (list
- (semanticdb-project-database-javascript))
- "Search javascript for symbols.")
-
-;; NOTE: Be sure to modify this to the best advantage of your
-;; language.
-(defvar-mode-local javascript-mode semanticdb-find-default-throttle
- '(project omniscience)
- "Search project files, then search this omniscience database.
-It is not necessary to do system or recursive searching because of
-the omniscience database.")
-
-;;; Filename based methods
-;;
-(cl-defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-javascript))
- "For a javascript database, there are no explicit tables.
-Create one of our special tables that can act as an intermediary."
- ;; NOTE: This method overrides an accessor for the `tables' slot in
- ;; a database. You can either construct your own (like newtable here
- ;; or you can manage any number of tables.
-
- ;; We need to return something since there is always the "master table"
- ;; The table can then answer file name type questions.
- (when (not (slot-boundp obj 'tables))
- (let ((newtable (semanticdb-table-javascript)))
- (oset obj tables (list newtable))
- (oset newtable parent-db obj)
- (oset newtable tags nil)
- ))
- (cl-call-next-method)
- )
-
-(cl-defmethod semanticdb-file-table ((obj semanticdb-project-database-javascript) _filename)
- "From OBJ, return FILENAME's associated table object."
- ;; NOTE: See not for `semanticdb-get-database-tables'.
- (car (semanticdb-get-database-tables obj))
- )
-
-(cl-defmethod semanticdb-get-tags ((_table semanticdb-table-javascript ))
- "Return the list of tags belonging to TABLE."
- ;; NOTE: Omniscient databases probably don't want to keep large tables
- ;; lolly-gagging about. Keep internal Emacs tables empty and
- ;; refer to alternate databases when you need something.
- semanticdb-javascript-tags)
-
-(cl-defmethod semanticdb-equivalent-mode ((_table semanticdb-table-javascript) &optional buffer)
- "Return non-nil if TABLE's mode is equivalent to BUFFER.
-Equivalent modes are specified by the `semantic-equivalent-major-modes'
-local variable."
- (with-current-buffer buffer
- (eq (or mode-local-active-mode major-mode) 'javascript-mode)))
-
-;;; Usage
-;;
-;; Unlike other tables, an omniscient database does not need to
-;; be associated with a path. Use this routine to always add ourselves
-;; to a search list.
-(define-mode-local-override semanticdb-find-translate-path javascript-mode
- (path brutish)
- "Return a list of semanticdb tables associated with PATH.
-If brutish, do the default action.
-If not brutish, do the default action, and append the system
-database (if available.)"
- (let ((default
- ;; When we recurse, disable searching of system databases
- ;; so that our Javascript database only shows up once when
- ;; we append it in this iteration.
- (let ((semanticdb-search-system-databases nil)
- )
- (semanticdb-find-translate-path-default path brutish))))
- ;; Don't add anything if BRUTISH is on (it will be added in that fcn)
- ;; or if we aren't supposed to search the system.
- (if (or brutish (not semanticdb-search-system-databases))
- default
- (let ((tables (apply #'append
- (mapcar
- (lambda (db) (semanticdb-get-database-tables db))
- semanticdb-project-system-databases))))
- (append default tables)))))
-
-;;; Search Overrides
-;;
-;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining
-;; how your new search routines are implemented.
-;;
-(defun semanticdb-javascript-regexp-search (regexp)
- "Search for REGEXP in our fixed list of javascript tags."
- (let* ((tags semanticdb-javascript-tags)
- (result nil))
- (while tags
- (if (string-match regexp (caar tags))
- (setq result (cons (car tags) result)))
- (setq tags (cdr tags)))
- result))
-
-(cl-defmethod semanticdb-find-tags-by-name-method
- ((_table semanticdb-table-javascript) name &optional tags)
- "Find all tags named NAME in TABLE.
-Return a list of tags."
- (if tags
- ;; If TAGS are passed in, then we don't need to do work here.
- (cl-call-next-method)
- (assoc-string name semanticdb-javascript-tags)
- ))
-
-(cl-defmethod semanticdb-find-tags-by-name-regexp-method
- ((_table semanticdb-table-javascript) regex &optional tags)
- "Find all tags with name matching REGEX in TABLE.
-Optional argument TAGS is a list of tags to search.
-Return a list of tags."
- (if tags (cl-call-next-method)
- ;; YOUR IMPLEMENTATION HERE
- (semanticdb-javascript-regexp-search regex)
-
- ))
-
-(cl-defmethod semanticdb-find-tags-for-completion-method
- ((_table semanticdb-table-javascript) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- (if tags (cl-call-next-method)
- ;; YOUR IMPLEMENTATION HERE
- (semanticdb-javascript-regexp-search (concat "^" prefix ".*"))
- ))
-
-(cl-defmethod semanticdb-find-tags-by-class-method
- ((_table semanticdb-table-javascript) _class &optional tags)
- "In TABLE, find all occurrences of tags of CLASS.
-Optional argument TAGS is a list of tags to search.
-Returns a table of all matching tags."
- (if tags (cl-call-next-method)
- ;; YOUR IMPLEMENTATION HERE
- ;;
- ;; Note: This search method could be considered optional in an
- ;; omniscient database. It may be unwise to return all tags
- ;; that exist for a language that are a variable or function.
- ;;
- ;; If it is optional, you can just delete this method.
- nil))
-
-;;; Deep Searches
-;;
-;; If your language does not have a `deep' concept, these can be left
-;; alone, otherwise replace with implementations similar to those
-;; above.
-;;
-(cl-defmethod semanticdb-deep-find-tags-by-name-method
- ((table semanticdb-table-javascript) name &optional tags)
- "Find all tags name NAME in TABLE.
-Optional argument TAGS is a list of tags to search.
-Like `semanticdb-find-tags-by-name-method' for javascript."
- (semanticdb-find-tags-by-name-method table name tags))
-
-(cl-defmethod semanticdb-deep-find-tags-by-name-regexp-method
- ((table semanticdb-table-javascript) regex &optional tags)
- "Find all tags with name matching REGEX in TABLE.
-Optional argument TAGS is a list of tags to search.
-Like `semanticdb-find-tags-by-name-method' for javascript."
- (semanticdb-find-tags-by-name-regexp-method table regex tags))
-
-(cl-defmethod semanticdb-deep-find-tags-for-completion-method
- ((table semanticdb-table-javascript) prefix &optional tags)
- "In TABLE, find all occurrences of tags matching PREFIX.
-Optional argument TAGS is a list of tags to search.
-Like `semanticdb-find-tags-for-completion-method' for javascript."
- (semanticdb-find-tags-for-completion-method table prefix tags))
-
-;;; Advanced Searches
-;;
-(cl-defmethod semanticdb-find-tags-external-children-of-type-method
- ((_table semanticdb-table-javascript) _type &optional tags)
- "Find all nonterminals which are child elements of TYPE.
-Optional argument TAGS is a list of tags to search.
-Return a list of tags."
- (if tags (cl-call-next-method)
- ;; YOUR IMPLEMENTATION HERE
- ;;
- ;; OPTIONAL: This could be considered an optional function. It is
- ;; used for `semantic-adopt-external-members' and may not
- ;; be possible to do in your language.
- ;;
- ;; If it is optional, you can just delete this method.
- ))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun semanticdb-javascript-strip-tags (tags)
- "Strip TAGS from overlays and reparse symbols."
- (cond ((and (consp tags) (eq 'reparse-symbol (car tags)))
- nil)
- ((overlayp tags) nil)
- ((atom tags) tags)
- (t (cons (semanticdb-javascript-strip-tags
- (car tags)) (semanticdb-javascript-strip-tags
- (cdr tags))))))
-
-;this list was made from a javascript file, and the above function
-;; function eval(x){}
-;; function parseInt(string,radix){}
-;; function parseFloat(string){}
-;; function isNaN(number){}
-;; function isFinite(number){}
-;; function decodeURI(encodedURI){}
-;; function decodeURIComponent (encodedURIComponent){}
-;; function encodeURI (uri){}
-;; function encodeURIComponent (uriComponent){}
-
-(provide 'semantic/db-javascript)
-
-;;; semantic/db-javascript.el ends here
+++ /dev/null
-;;; semantic/db-mode.el --- Semanticdb Minor Mode -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Major mode for managing Semantic Databases automatically.
-
-;;; Code:
-
-(require 'semantic/db)
-
-(declare-function semantic-lex-spp-set-dynamic-table "semantic/lex-spp")
-
-;;; Start/Stop database use
-;;
-(defvar semanticdb-hooks
- '((semanticdb-semantic-init-hook-fcn semantic-init-db-hook)
- (semanticdb-synchronize-table semantic-after-toplevel-cache-change-hook)
- (semanticdb-partial-synchronize-table semantic-after-partial-cache-change-hook)
- (semanticdb-revert-hook before-revert-hook)
- (semanticdb-kill-hook kill-buffer-hook)
- (semanticdb-kill-hook change-major-mode-hook) ;; Not really a kill, but we need the same effect.
- (semanticdb-kill-emacs-hook kill-emacs-hook)
- )
- "List of hooks and values to add/remove when configuring semanticdb.")
-
-;;; SEMANTICDB-MODE
-;;
-;;;###autoload
-(defun semanticdb-minor-mode-p ()
- "Return non-nil if `semanticdb-minor-mode' is active."
- (member (car (car semanticdb-hooks))
- (symbol-value (car (cdr (car semanticdb-hooks))))))
-
-(defvaralias 'semanticdb-mode-hook 'global-semanticdb-minor-mode-hook)
-(defvaralias 'semanticdb-global-mode 'global-semanticdb-minor-mode)
-
-;;;###autoload
-(define-minor-mode global-semanticdb-minor-mode
- "Toggle Semantic DB mode.
-
-In Semantic DB mode, Semantic parsers store results in a
-database, which can be saved for future Emacs sessions."
- :global t
- :group 'semantic
- (if global-semanticdb-minor-mode
- ;; Enable
- (dolist (elt semanticdb-hooks)
- (add-hook (cadr elt) (car elt)))
- ;; Disable
- (dolist (elt semanticdb-hooks)
- (remove-hook (cadr elt) (car elt)))))
-
-(defun semanticdb-toggle-global-mode ()
- "Toggle use of the Semantic Database feature.
-Update the environment of Semantic enabled buffers accordingly."
- (interactive)
- (if (semanticdb-minor-mode-p)
- ;; Save databases before disabling semanticdb.
- (semanticdb-save-all-db))
- ;; Toggle semanticdb minor mode.
- (global-semanticdb-minor-mode 'toggle))
-
-;;; Hook Functions:
-;;
-;; Functions used in hooks to keep SemanticDB operating.
-;;
-(defun semanticdb-semantic-init-hook-fcn ()
- "Function saved in `semantic-init-db-hook'.
-Sets up the semanticdb environment."
- ;; Only initialize semanticdb if we have a file name.
- ;; There is no reason to cache a tag table if there is no
- ;; way to load it back in later.
- (when (buffer-file-name)
- (let* ((ans (semanticdb-create-table-for-file (buffer-file-name)))
- (cdb (car ans))
- (ctbl (cdr ans))
- )
- ;; Get the current DB for this directory
- (setq semanticdb-current-database cdb)
- ;; We set the major mode because we know what it is.
- (oset ctbl major-mode major-mode)
- ;; Local state
- (setq semanticdb-current-table ctbl)
- (oset ctbl buffer (current-buffer))
- ;; Try to swap in saved tags
- (if (or (not (slot-boundp ctbl 'tags)) (not (oref ctbl tags))
- (/= (or (oref ctbl pointmax) 0) (point-max))
- )
- (semantic-clear-toplevel-cache)
- ;; Unmatched syntax
- (condition-case nil
- (semantic-set-unmatched-syntax-cache
- (oref ctbl unmatched-syntax))
- (unbound-slot
- ;; Old version of the semanticdb table can miss the unmatched
- ;; syntax slot. If so, just clear the unmatched syntax cache.
- (semantic-clear-unmatched-syntax-cache)
- ;; Make sure it has a value.
- (oset ctbl unmatched-syntax nil)
- ))
- ;; Keep lexical tables up to date. Don't load
- ;; semantic-spp if it isn't needed.
- (let ((lt (oref ctbl lexical-table)))
- (when lt
- (require 'semantic/lex-spp)
- (semantic-lex-spp-set-dynamic-table lt)))
- ;; Set the main tag cache.
- ;; This must happen after setting up buffer local variables
- ;; since this will turn around and re-save those variables.
- (semantic--set-buffer-cache (oref ctbl tags))
- ;; Don't need it to be dirty. Set dirty due to hooks from above.
- (oset ctbl dirty nil) ;; Special case here.
- ;; Bind into the buffer.
- (semantic--tag-link-cache-to-buffer)
- )
- )))
-
-(defun semanticdb-revert-hook ()
- "Hook run before a revert buffer.
-We can't track incremental changes due to a revert, so just clear the cache.
-This will prevent the next batch of hooks from wasting time parsing things
-that don't need to be parsed."
- (if (and (semantic-active-p)
- semantic--buffer-cache
- semanticdb-current-table)
- (semantic-clear-toplevel-cache)))
-
-(defun semanticdb-kill-hook ()
- "Function run when a buffer is killed.
-If there is a semantic cache, slurp out the overlays, and store
-it in our database. If that buffer has no cache, ignore it, we'll
-handle it later if need be."
- (when (and (semantic-active-p)
- semantic--buffer-cache
- semanticdb-current-table)
-
- ;; Try to get a fast update.
- (semantic-fetch-tags-fast)
-
- ;; If the buffer is in a bad state, don't save anything...
- (if (semantic-parse-tree-needs-rebuild-p)
- ;; If this is the case, don't save anything.
- (progn
- (semantic-clear-toplevel-cache)
- (oset semanticdb-current-table pointmax 0)
- (oset semanticdb-current-table fsize 0)
- (oset semanticdb-current-table lastmodtime nil)
- )
- ;; We have a clean buffer, save it off.
- (condition-case nil
- (progn
- (semantic--tag-unlink-cache-from-buffer)
- ;; Set pointmax only if we had some success in the unlink.
- (oset semanticdb-current-table pointmax (point-max))
- (let ((fattr (file-attributes
- (semanticdb-full-filename
- semanticdb-current-table))))
- (oset semanticdb-current-table fsize (file-attribute-size fattr))
- (oset semanticdb-current-table lastmodtime
- (file-attribute-modification-time fattr))
- (oset semanticdb-current-table buffer nil)
- ))
- ;; If this messes up, just clear the system
- (error
- (semantic-clear-toplevel-cache)
- (message "semanticdb: Failed to deoverlay tag cache.")))
- )
- ))
-
-(defun semanticdb-kill-emacs-hook ()
- "Function called when Emacs is killed.
-Save all the databases."
- (semanticdb-save-all-db))
-
-;;; SYNCHRONIZATION HOOKS
-;;
-(defun semanticdb-synchronize-table (new-table)
- "Function run after parsing.
-Argument NEW-TABLE is the new table of tags."
- (when semanticdb-current-table
- (semanticdb-synchronize semanticdb-current-table new-table)))
-
-(defun semanticdb-partial-synchronize-table (new-table)
- "Function run after parsing.
-Argument NEW-TABLE is the new table of tags."
- (when semanticdb-current-table
- (semanticdb-partial-synchronize semanticdb-current-table new-table)))
-
-
-(provide 'semantic/db-mode)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/db-mode"
-;; End:
-
-;;; semantic/db-mode.el ends here
+++ /dev/null
-;;; semantic/db-ref.el --- Handle cross-db file references -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handle cross-database file references.
-;;
-;; Any given database may be referred to by some other database. For
-;; example, if a .cpp file has a #include in a header, then that
-;; header file should have a reference to the .cpp file that included
-;; it.
-;;
-;; This is critical for purposes where a file (such as a .cpp file)
-;; needs to have its caches flushed because of changes in the
-;; header. Changing a header may cause a referring file to be
-;; reparsed due to account for changes in defined macros, or perhaps
-;; a change to files the header includes.
-
-
-;;; Code:
-(require 'eieio)
-(require 'cl-generic)
-(require 'semantic)
-(require 'semantic/db)
-(require 'semantic/tag)
-
-;; For the semantic-find-tags-by-name-regexp macro.
-(eval-when-compile (require 'semantic/find))
-
-(cl-defmethod semanticdb-add-reference ((dbt semanticdb-abstract-table)
- include-tag)
- "Add a reference for the database table DBT based on INCLUDE-TAG.
-DBT is the database table that owns the INCLUDE-TAG. The reference
-will be added to the database that INCLUDE-TAG refers to."
- ;; NOTE: I should add a check to make sure include-tag is in DB.
- ;; but I'm too lazy.
- (let* ((semanticdb-find-default-throttle
- (if (featurep 'semantic/db-find)
- (remq 'unloaded semanticdb-find-default-throttle)
- nil))
- (refdbt (semanticdb-find-table-for-include include-tag dbt))
- ;;(fullfile (semanticdb-full-filename dbt))
- )
- (when refdbt
- ;; Add our filename (full path)
- ;; (object-add-to-list refdbt 'file-refs fullfile)
-
- ;; Add our database.
- (object-add-to-list refdbt 'db-refs dbt)
- t)))
-
-(cl-defmethod semanticdb-check-references ((_dbt semanticdb-abstract-table))
- "Check and cleanup references in the database DBT.
-Abstract tables would be difficult to reference."
- ;; Not sure how an abstract table can have references.
- nil)
-
-(cl-defmethod semanticdb-includes-in-table ((dbt semanticdb-abstract-table))
- "Return a list of direct includes in table DBT."
- (semantic-find-tags-by-class 'include (semanticdb-get-tags dbt)))
-
-
-(cl-defmethod semanticdb-check-references ((dbt semanticdb-table))
- "Check and cleanup references in the database DBT.
-Any reference to a file that cannot be found, or whose file no longer
-refers to DBT will be removed."
- (let ((refs (oref dbt db-refs))
- (myexpr (concat "\\<" (oref dbt file)))
- )
- (while refs
- (let* ((ok t)
- (db (car refs))
- (f (when (cl-typep db 'semanticdb-table)
- (semanticdb-full-filename db)))
- )
-
- ;; The file was deleted
- (when (and f (not (file-exists-p f)))
- (setq ok nil))
-
- ;; The reference no longer includes the textual reference?
- (let* ((refs (semanticdb-includes-in-table db))
- (inc (semantic-find-tags-by-name-regexp
- myexpr refs)))
- (when (not inc)
- (setq ok nil)))
-
- ;; Remove not-ok databases from the list.
- (when (not ok)
- (object-remove-from-list dbt 'db-refs db)
- ))
- (setq refs (cdr refs)))))
-
-(cl-defmethod semanticdb-refresh-references ((_dbt semanticdb-abstract-table))
- "Refresh references to DBT in other files."
- ;; alternate tables can't be edited, so can't be changed.
- nil
- )
-
-(cl-defmethod semanticdb-refresh-references ((dbt semanticdb-table))
- "Refresh references to DBT in other files."
- (let ((refs (semanticdb-includes-in-table dbt))
- )
- (while refs
- (if (semanticdb-add-reference dbt (car refs))
- nil
- ;; If we succeeded, then do... nothing?
- nil
- )
- (setq refs (cdr refs)))
- ))
-
-(cl-defmethod semanticdb-notify-references ((dbt semanticdb-table)
- method)
- "Notify all references of the table DBT using method.
-METHOD takes two arguments.
- (METHOD TABLE-TO-NOTIFY DBT)
-TABLE-TO-NOTIFY is a semanticdb-table which is being notified.
-DBT, the second argument is DBT."
- (mapc (lambda (R) (funcall method R dbt))
- (oref dbt db-refs)))
-
-;;; DEBUG
-;;
-(defclass semanticdb-ref-adebug ()
- ((i-depend-on :initarg :i-depend-on)
- (local-table :initarg :local-table)
- (i-include :initarg :i-include))
- "Simple class to allow ADEBUG to show a nice list.")
-
-(declare-function data-debug-new-buffer "data-debug")
-(declare-function data-debug-insert-object-slots "eieio-datadebug")
-
-(defun semanticdb-ref-test (refresh)
- "Dump out the list of references for the current buffer.
-If REFRESH is non-nil, cause the current table to have its references
-refreshed before dumping the result."
- (interactive "p")
- (require 'eieio-datadebug)
- ;; If we need to refresh... then do so.
- (when refresh
- (semanticdb-refresh-references semanticdb-current-table))
- ;; Do the debug system
- (let* ((tab semanticdb-current-table)
- (myrefs (oref tab db-refs))
- (myinc (semanticdb-includes-in-table tab))
- (adbc (semanticdb-ref-adebug :i-depend-on myrefs
- :local-table tab
- :i-include myinc)))
- (data-debug-new-buffer "*References ADEBUG*")
- (data-debug-insert-object-slots adbc "!"))
- )
-
-(provide 'semantic/db-ref)
-
-;;; semantic/db-ref.el ends here
+++ /dev/null
-;;; semantic/db-typecache.el --- Manage Datatypes -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Manage a datatype cache.
-;;
-;; For typed languages like C++ collect all known types from various
-;; headers, merge namespaces, and expunge duplicates.
-;;
-;; It is likely this feature will only be needed for C/C++.
-
-(require 'semantic)
-(require 'semantic/db)
-(require 'semantic/db-find)
-(require 'semantic/analyze/fcn)
-
-;; For semantic-find-tags-by-* macros
-(eval-when-compile (require 'semantic/find))
-
-(declare-function data-debug-insert-thing "data-debug")
-(declare-function data-debug-new-buffer "data-debug")
-(declare-function semantic-sort-tags-by-name-then-type-increasing "semantic/sort")
-(declare-function semantic-scope-tag-clone-with-scope "semantic/scope")
-
-;;; Code:
-
-\f
-;;; TABLE TYPECACHE
-;;;###autoload
-(defclass semanticdb-typecache ()
- ((filestream :initform nil
- :documentation
- "Fully sorted/merged list of tags within this buffer.")
- (includestream :initform nil
- :documentation
- "Fully sorted/merged list of tags from this file's includes list.")
- (stream :initform nil
- :documentation
- "The searchable tag stream for this cache.
-NOTE: Can I get rid of this? Use a hash table instead?")
- (dependants :initform nil
- :documentation
- "Any other object that is dependent on typecache results.
-Said object must support `semantic-reset' methods.")
- ;; @todo - add some sort of fast-hash.
- ;; @note - Rebuilds in large projects already take a while, and the
- ;; actual searches are pretty fast. Really needed?
- )
- "Structure for maintaining a typecache.")
-
-(cl-defmethod semantic-reset ((tc semanticdb-typecache))
- "Reset the object IDX."
- (oset tc filestream nil)
- (oset tc includestream nil)
-
- (oset tc stream nil)
-
- (mapc #'semantic-reset (oref tc dependants))
- (oset tc dependants nil)
- )
-
-(cl-defmethod semanticdb-typecache-notify-reset ((tc semanticdb-typecache))
- "Do a reset from a notify from a table we depend on."
- (oset tc includestream nil)
- (mapc #'semantic-reset (oref tc dependants))
- (oset tc dependants nil)
- )
-
-(cl-defmethod semanticdb-partial-synchronize ((tc semanticdb-typecache)
- new-tags)
- "Reset the typecache based on a partial reparse."
- (when (semantic-find-tags-by-class 'include new-tags)
- (oset tc includestream nil)
- (mapc #'semantic-reset (oref tc dependants))
- (oset tc dependants nil)
- )
-
- (when (semantic-find-tags-by-class 'type new-tags)
- ;; Reset our index
- (oset tc filestream nil)
- t ;; Return true, our core file tags have changed in a relevant way.
- )
-
- ;; NO CODE HERE
- )
-
-(defun semanticdb-typecache-add-dependant (dep)
- "Add into the local typecache a dependant DEP."
- (let* ((table semanticdb-current-table)
- ;;(idx (semanticdb-get-table-index table))
- (cache (semanticdb-get-typecache table))
- )
- (object-add-to-list cache 'dependants dep)))
-
-(defun semanticdb-typecache-length (thing)
- "How long is THING?
-Debugging function."
- (cond ((cl-typep thing 'semanticdb-typecache)
- (length (oref thing stream)))
- ((semantic-tag-p thing)
- (length (semantic-tag-type-members thing)))
- ((and (listp thing) (semantic-tag-p (car thing)))
- (length thing))
- ((null thing)
- 0)
- (t -1) ))
-
-
-(cl-defmethod semanticdb-get-typecache ((table semanticdb-abstract-table))
- "Retrieve the typecache from the semanticdb TABLE.
-If there is no table, create one, and fill it in."
- (semanticdb-refresh-table table)
- (let* ((idx (semanticdb-get-table-index table))
- (cache (oref idx type-cache))
- )
-
- ;; Make sure we have a cache object in the DB index.
- (when (not cache)
- ;; The object won't change as we fill it with stuff.
- (setq cache (semanticdb-typecache (semanticdb-full-filename table)))
- (oset idx type-cache cache))
-
- cache))
-
-(cl-defmethod semanticdb-have-typecache-p ((table semanticdb-abstract-table))
- "Return non-nil (the typecache) if TABLE has a pre-calculated typecache."
- (let* ((idx (semanticdb-get-table-index table)))
- (oref idx type-cache)))
-
-\f
-;;; DATABASE TYPECACHE
-;;
-;; A full database can cache the types across its files.
-;;
-;; Unlike file based caches, this one is a bit simpler, and just needs
-;; to get reset when a table gets updated.
-
-;;;###autoload
-(defclass semanticdb-database-typecache (semanticdb-abstract-db-cache)
- ((stream :initform nil
- :documentation
- "The searchable tag stream for this cache.")
- )
- "Structure for maintaining a typecache.")
-
-(cl-defmethod semantic-reset ((tc semanticdb-database-typecache))
- "Reset the object IDX."
- (oset tc stream nil)
- )
-
-(cl-defmethod semanticdb-synchronize ((_cache semanticdb-database-typecache)
- _new-tags)
- "Synchronize a CACHE with some NEW-TAGS."
- nil)
-
-(cl-defmethod semanticdb-partial-synchronize ((_cache semanticdb-database-typecache)
- _new-tags)
- "Synchronize a CACHE with some changed NEW-TAGS."
- nil)
-
-(cl-defmethod semanticdb-get-typecache ((db semanticdb-project-database))
- "Retrieve the typecache from the semantic database DB.
-If there is no table, create one, and fill it in."
- (semanticdb-cache-get db 'semanticdb-database-typecache)
- )
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; MERGING
-;;
-;; Managing long streams of tags representing data types.
-;;
-(defun semanticdb-typecache-apply-filename (file stream)
- "Apply the filename FILE to all tags in STREAM."
- (let ((new nil))
- (while stream
- (setq new (cons (semantic-tag-copy (car stream) nil file)
- new))
- ;The below is handled by the tag-copy fcn.
- ;(semantic--tag-put-property (car new) :filename file)
- (setq stream (cdr stream)))
- (nreverse new)))
-
-
-(defsubst semanticdb-typecache-safe-tag-members (tag)
- "Return a list of members for TAG that are safe to permute."
- (let ((mem (semantic-tag-type-members tag))
- (fname (semantic-tag-file-name tag)))
- (if fname
- (setq mem (semanticdb-typecache-apply-filename fname mem))
- (copy-sequence mem))))
-
-(defsubst semanticdb-typecache-safe-tag-list (tags table)
- "Make the tag list TAGS found in TABLE safe for the typecache.
-Adds a filename and copies the tags."
- (semanticdb-typecache-apply-filename
- (semanticdb-full-filename table)
- tags))
-
-(defun semanticdb-typecache-faux-namespace (name members)
- "Create a new namespace tag with NAME and a set of MEMBERS.
-The new tag will be a faux tag, used as a placeholder in a typecache."
- (let ((tag (semantic-tag-new-type name "namespace" members nil)))
- ;; Make sure we mark this as a fake tag.
- (semantic-tag-set-faux tag)
- tag))
-
-(defun semanticdb-typecache-merge-streams (cache1 cache2)
- "Merge into CACHE1 and CACHE2 together. The Caches will be merged in place."
- (if (or (and (not cache1) (not cache2))
- (and (not (cdr cache1)) (not cache2))
- (and (not cache1) (not (cdr cache2))))
- ;; If all caches are empty OR
- ;; cache1 is length 1 and no cache2 OR
- ;; no cache1 and length 1 cache2
- ;;
- ;; then just return the cache, and skip all this merging stuff.
- (or cache1 cache2)
-
- ;; Assume we always have datatypes, as this typecache isn't really
- ;; useful without a typed language.
- (require 'semantic/sort)
- (let ((S (semantic-sort-tags-by-name-then-type-increasing
- ;; I used to use append, but it copied cache1 but not cache2.
- ;; Since sort was permuting cache2, I already had to make sure
- ;; the caches were permute-safe. Might as well use nconc here.
- (nconc cache1 cache2)))
- (ans nil)
- (next nil)
- (prev nil)
- (type nil))
- ;; With all the tags in order, we can loop over them, and when
- ;; two have the same name, we can either throw one away, or construct
- ;; a fresh new tag merging the items together.
- (while S
- (setq prev (car ans))
- (setq next (car S))
- (if (or
- ;; CASE 1 - First item
- (null prev)
- ;; CASE 2 - New name
- (not (string= (semantic-tag-name next)
- (semantic-tag-name prev))))
- (setq ans (cons next ans))
- ;; ELSE - We have a NAME match.
- (setq type (semantic-tag-type next))
- (if (or (semantic-tag-of-type-p prev type) ; Are they the same datatype
- (semantic-tag-faux-p prev)
- (semantic-tag-faux-p next) ; or either a faux tag?
- )
- ;; Same Class, we can do a merge.
- (cond
- ((and (semantic-tag-of-class-p next 'type)
- (string= type "namespace"))
- ;; Namespaces - merge the children together.
- (setcar ans
- (semanticdb-typecache-faux-namespace
- (semantic-tag-name prev) ; - they are the same
- (semanticdb-typecache-merge-streams
- (semanticdb-typecache-safe-tag-members prev)
- (semanticdb-typecache-safe-tag-members next))
- ))
- )
- ((semantic-tag-prototype-p next)
- ;; NEXT is a prototype... so keep previous.
- nil ; - keep prev, do nothing
- )
- ((semantic-tag-prototype-p prev)
- ;; PREV is a prototype, but not next.. so keep NEXT.
- ;; setcar - set by side-effect on top of prev
- (setcar ans next)
- )
- (t
- ;;(message "Don't know how to merge %s. Keeping first entry." (semantic-tag-name next))
- ))
- ;; Not same class... but same name
- ;(message "Same name, different type: %s, %s!=%s"
- ; (semantic-tag-name next)
- ; (semantic-tag-type next)
- ; (semantic-tag-type prev))
- (setq ans (cons next ans))
- ))
- (setq S (cdr S)))
- (nreverse ans))))
-\f
-;;; Refresh / Query API
-;;
-;; Queries that can be made for the typecache.
-(define-overloadable-function semanticdb-expand-nested-tag (tag)
- "Expand TAG from fully qualified names.
-If TAG has fully qualified names, expand it to a series of nested
-namespaces instead."
- tag)
-
-(cl-defmethod semanticdb-typecache-file-tags ((_table semanticdb-abstract-table))
- "No tags available from non-file based tables."
- nil)
-
-(cl-defmethod semanticdb-typecache-file-tags ((table semanticdb-table))
- "Update the typecache for TABLE, and return the file-tags.
-File-tags are those that belong to this file only, and excludes
-all included files."
- (let* (;(idx (semanticdb-get-table-index table))
- (cache (semanticdb-get-typecache table))
- )
-
- ;; Make sure our file-tags list is up to date.
- (when (not (oref cache filestream))
- (let ((tags (semantic-find-tags-by-class 'type table))
- (exptags nil))
- (when tags
- (setq tags (semanticdb-typecache-safe-tag-list tags table))
- (dolist (T tags)
- (push (semanticdb-expand-nested-tag T) exptags))
- (oset cache filestream (semanticdb-typecache-merge-streams exptags nil)))))
-
- ;; Return our cache.
- (oref cache filestream)
- ))
-
-(cl-defmethod semanticdb-typecache-include-tags ((_table semanticdb-abstract-table))
- "No tags available from non-file based tables."
- nil)
-
-(cl-defmethod semanticdb-typecache-include-tags ((table semanticdb-table))
- "Update typecache for TABLE, and return the merged types from the include tags.
-Include-tags are the tags brought in via includes, all merged together into
-a master list."
- (let* ((cache (semanticdb-get-typecache table))
- )
-
- ;; Make sure our file-tags list is up to date.
- (when (not (oref cache includestream))
- (let (;; Calc the path first. This will have a nice side -effect of
- ;; getting the cache refreshed if a refresh is needed. Most of the
- ;; time this value is itself cached, so the query is fast.
- (incpath (semanticdb-find-translate-path table nil))
- (incstream nil))
- ;; Get the translated path, and extract all the type tags, then merge
- ;; them all together.
- (dolist (i incpath)
- ;; don't include ourselves in this crazy list.
- (when (and i (not (eq i table))
- ;; @todo - This eieio fcn can be slow! Do I need it?
- ;; (cl-typep i 'semanticdb-table)
- )
- (setq incstream
- (semanticdb-typecache-merge-streams
- incstream
- ;; Getting the cache from this table will also cause this
- ;; file to update its cache from its descendants.
- ;;
- ;; In theory, caches are only built for most includes
- ;; only once (in the loop before this one), so this ends
- ;; up being super fast as we edit our file.
- (copy-sequence
- (semanticdb-typecache-file-tags i))))
- ))
-
- ;; Save...
- (oset cache includestream incstream)))
-
- ;; Return our cache.
- (oref cache includestream)
- ))
-
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; Search Routines
-;;
-;;;###autoload
-(define-overloadable-function semanticdb-typecache-find (type &optional path find-file-match)
- "Search the typecache for TYPE in PATH.
-If type is a string, split the string, and search for the parts.
-If type is a list, treat the type as a pre-split string.
-PATH can be nil for the current buffer, or a semanticdb table.
-FIND-FILE-MATCH is non-nil to force all found tags to be loaded into a buffer.")
-
-(defun semanticdb-typecache-find-default (type &optional path find-file-match)
- "Default implementation of `semanticdb-typecache-find'.
-TYPE is the datatype to find.
-PATH is the search path, which should be one table object.
-If FIND-FILE-MATCH is non-nil, then force the file belonging to the
-found tag to be loaded."
- (if (not (and (featurep 'semantic/db) semanticdb-current-database))
- nil ;; No DB, no search
- (save-excursion
- (semanticdb-typecache-find-method (or path semanticdb-current-table)
- type find-file-match))))
-
-(defun semanticdb-typecache-find-by-name-helper (name table)
- "Find the tag with NAME in TABLE, which is from a typecache.
-If more than one tag has NAME in TABLE, we will prefer the tag that
-is of class `type'."
- (let* ((names (semantic-find-tags-by-name name table))
- (nmerge (semanticdb-typecache-merge-streams names nil))
- (types (semantic-find-tags-by-class 'type nmerge)))
- (or (car-safe types) (car-safe nmerge))))
-
-(cl-defmethod semanticdb-typecache-find-method ((table semanticdb-abstract-table)
- type find-file-match)
- "Search the typecache in TABLE for the datatype TYPE.
-If type is a string, split the string, and search for the parts.
-If type is a list, treat the type as a pre-split string.
-If FIND-FILE-MATCH is non-nil, then force the file belonging to the
-found tag to be loaded."
- ;; convert string to a list.
- (when (stringp type) (setq type (semantic-analyze-split-name type)))
- (when (stringp type) (setq type (list type)))
-
- ;; Search for the list in our typecache.
- (let* ((file (semanticdb-typecache-file-tags table))
- (inc (semanticdb-typecache-include-tags table))
- (stream nil)
- (f-ans nil)
- (i-ans nil)
- (ans nil)
- (notdone t)
- (lastfile nil)
- (thisfile nil)
- (lastans nil)
- (calculated-scope nil)
- )
- ;; 1) Find first symbol in the two master lists and then merge
- ;; the found streams.
-
- ;; We stripped duplicates, so these will be super-fast!
- (setq f-ans (semantic-find-first-tag-by-name (car type) file))
- (setq i-ans (semantic-find-first-tag-by-name (car type) inc))
- (if (and f-ans i-ans)
- (progn
- ;; This trick merges the two identified tags, making sure our lists are
- ;; complete. The second find then gets the new 'master' from the list of 2.
- (setq ans (semanticdb-typecache-merge-streams (list f-ans) (list i-ans)))
- (setq ans (semantic-find-first-tag-by-name (car type) ans))
- )
-
- ;; The answers are already sorted and merged, so if one misses,
- ;; no need to do any special work.
- (setq ans (or f-ans i-ans)))
-
- ;; 2) Loop over the remaining parts.
- (while (and type notdone)
-
- ;; For pass > 1, stream will be non-nil, so do a search, otherwise
- ;; ans is from outside the loop.
- (when stream
- (setq ans (semanticdb-typecache-find-by-name-helper (car type) stream))
-
- ;; NOTE: The below test to make sure we get a type is only relevant
- ;; for the SECOND pass or later. The first pass can only ever
- ;; find a type/namespace because everything else is excluded.
-
- ;; If this is not the last entry from the list, then it
- ;; must be a type or a namespace. Let's double check.
- (when (cdr type)
-
- ;; From above, there is only one tag in ans, and we prefer
- ;; types.
- (when (not (semantic-tag-of-class-p ans 'type))
-
- (setq ans nil)))
- )
-
- ;; The typecache holds all the known types and elements. Some databases
- ;; may provide tags that are simplified by name, and are proxies. These
- ;; proxies must be resolved in order to extract type members.
- (setq ans (semantic-tag-resolve-proxy ans))
-
- (push ans calculated-scope)
-
- ;; Track most recent file.
- (setq thisfile (semantic-tag-file-name ans))
- (when (and thisfile (stringp thisfile))
- (setq lastfile thisfile))
-
- ;; If we have a miss, exit, otherwise, update the stream to
- ;; the next set of members.
- (if (not ans)
- (setq notdone nil)
- (setq stream (semantic-tag-type-members ans)))
-
- (setq lastans ans
- ans nil
- type (cdr type)))
-
- (if (or type (not notdone))
- ;; If there is stuff left over, then we failed. Just return
- ;; nothing.
- nil
-
- ;; We finished, so return everything.
-
- (if (and find-file-match lastfile)
- ;; This won't liven up the tag since we have a copy, but
- ;; we ought to be able to get there and go to the right line.
- (find-file-noselect lastfile)
- ;; We don't want to find-file match, so instead let's
- ;; push the filename onto the return tag.
- (when lastans
- (setq lastans (semantic-tag-copy lastans nil lastfile))
- ;; We used to do the below, but we would erroneously be putting
- ;; attributes on tags being shred with other lists.
- ;;(semantic--tag-put-property lastans :filename lastfile)
- )
- )
-
- (if (and lastans calculated-scope)
-
- ;; Put our discovered scope into the tag if we have a tag
- (progn
- (require 'semantic/scope)
- (semantic-scope-tag-clone-with-scope
- lastans (reverse (cdr calculated-scope))))
-
- ;; Else, just return
- lastans
- ))))
-\f
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;; BRUTISH Typecache
-;;
-;; Routines for a typecache that crosses all tables in a given database
-;; for a matching major-mode.
-(cl-defmethod semanticdb-typecache-for-database ((db semanticdb-project-database)
- &optional mode)
- "Return the typecache for the project database DB.
-If there isn't one, create it."
- (let ((lmode (or mode major-mode))
- (cache (semanticdb-get-typecache db))
- (stream nil)
- )
- (dolist (table (semanticdb-get-database-tables db))
- (when (eq lmode (oref table major-mode))
- (setq stream
- (semanticdb-typecache-merge-streams
- stream
- (copy-sequence
- (semanticdb-typecache-file-tags table))))
- ))
- (oset cache stream stream)
- cache))
-
-(defun semanticdb-typecache-refresh-for-buffer (buffer)
- "Refresh the typecache for BUFFER."
- (with-current-buffer buffer
- (let* ((tab semanticdb-current-table)
- ;(idx (semanticdb-get-table-index tab))
- (tc (semanticdb-get-typecache tab)))
- (semanticdb-typecache-file-tags tab)
- (semanticdb-typecache-include-tags tab)
- tc)))
-
-\f
-;;; DEBUG
-;;
-(defun semanticdb-typecache-complete-flush ()
- "Flush all typecaches referenced by the current buffer."
- (interactive)
- (let* ((path (semanticdb-find-translate-path nil nil)))
- (dolist (P path)
- (condition-case nil
- (oset P pointmax nil)
- ;; Pointmax may not exist for all tables discovered in the
- ;; path.
- (error nil))
- (semantic-reset (semanticdb-get-typecache P)))))
-
-(defun semanticdb-typecache-dump ()
- "Dump the typecache for the current buffer."
- (interactive)
- (require 'data-debug)
- (let* ((start (current-time))
- (tc (semanticdb-typecache-refresh-for-buffer (current-buffer)))
- (end (current-time))
- )
- (data-debug-new-buffer "*TypeCache ADEBUG*")
- (message "Calculating Cache took %.2f seconds."
- (semantic-elapsed-time start end))
-
- (data-debug-insert-thing tc "]" "")
-
- ))
-
-(defun semanticdb-db-typecache-dump ()
- "Dump the typecache for the current buffer's database."
- (interactive)
- (require 'data-debug)
- (let* ((tab semanticdb-current-table)
- (idx (semanticdb-get-table-index tab))
- (_ (oset idx type-cache nil)) ;; flush!
- (start (current-time))
- (tc (semanticdb-typecache-for-database (oref tab parent-db)))
- (end (current-time))
- )
- (data-debug-new-buffer "*TypeCache ADEBUG*")
- (message "Calculating Cache took %.2f seconds."
- (semantic-elapsed-time start end))
-
- (data-debug-insert-thing tc "]" "")
-
- ))
-
-(provide 'semantic/db-typecache)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/db-typecache"
-;; End:
-
-;;; semantic/db-typecache.el ends here
+++ /dev/null
-;;; semantic/db.el --- Semantic tag database manager -*- lexical-binding:t -*-
-
-;; Copyright (C) 2000-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: tags
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Maintain a database of tags for a group of files and enable
-;; queries into the database.
-;;
-;; By default, assume one database per directory.
-;;
-
-;;; Code:
-
-(require 'eieio-base)
-(require 'semantic)
-
-(eval-when-compile
- (require 'semantic/find))
-
-(declare-function semantic-lex-spp-save-table "semantic/lex-spp")
-
-;; Use autoload to avoid recursive require of semantic/db-ref
-(autoload 'semanticdb-refresh-references "semantic/db-ref"
- "Refresh references to DBT in other files.")
-
-;;; Variables:
-(defgroup semanticdb nil
- "Parser Generator Persistent Database interface."
- :group 'semantic)
-
-(defvar semanticdb-database-list nil
- "List of all active databases.")
-
-(defvar-local semanticdb-new-database-class 'semanticdb-project-database-file
- "The default type of database created for new files.
-This can be changed on a per file basis, so that some directories
-are saved using one mechanism, and some directories via a different
-mechanism.")
-
-(defvar-local semanticdb-default-find-index-class 'semanticdb-find-search-index
- "The default type of search index to use for a `semanticdb-table's.
-This can be changed to try out new types of search indices.")
-
-;;;###autoload
-(defvar-local semanticdb-current-database nil
- "For a given buffer, this is the currently active database.")
-
-;;;###autoload
-(defvar-local semanticdb-current-table nil
- "For a given buffer, this is the currently active database table.")
-
-;;; ABSTRACT CLASSES
-;;
-(defclass semanticdb-abstract-table ()
- ((parent-db ;; :initarg :parent-db
- ;; Do not set an initarg, or you get circular writes to disk.
- :documentation "Database Object containing this table.")
- (major-mode :initarg :major-mode
- :initform nil
- :documentation "Major mode this table belongs to.
-Sometimes it is important for a program to know if a given table has the
-same major mode as the current buffer.")
- (tags :initarg :tags
- :accessor semanticdb-get-tags
- :printer semantic-tag-write-list-slot-value
- :documentation "The tags belonging to this table.")
- (db-refs :initform nil
- :documentation
- "List of `semanticdb-table' objects referring to this one.
-These aren't saved, but are instead recalculated after load.
-See the file semanticdb-ref.el for how this slot is used.")
- (index :type semanticdb-abstract-search-index
- :documentation "The search index.
-Used by semanticdb-find to store additional information about
-this table for searching purposes.
-
-Note: This index will not be saved in a persistent file.")
- (cache :type list
- :initform nil
- :documentation "List of cache information for tools.
-Any particular tool can cache data to a database at runtime
-with `semanticdb-cache-get'.
-
-Using a semanticdb cache does not save any information to a file,
-so your cache will need to be recalculated at runtime. Caches can be
-referenced even when the file is not in a buffer.
-
-Note: This index will not be saved in a persistent file.")
- )
- "A simple table for semantic tags.
-This table is the root of tables, and contains the minimum needed
-for a new table not associated with a buffer."
- :abstract t)
-
-(cl-defmethod semanticdb-in-buffer-p ((_obj semanticdb-abstract-table))
- "Return a nil, meaning abstract table OBJ is not in a buffer."
- nil)
-
-(cl-defgeneric semanticdb-get-buffer (_obj)
- "Return a buffer associated with semanticdb table OBJ.
-If the buffer is not in memory, load it with `find-file-noselect'."
- nil)
-
-;; FIXME: Should we merge `semanticdb-get-buffer' and
-;; `semantic-tag-parent-buffer'?
-;; This generic method allows for sloppier coding. Many
-;; functions treat "table" as something that could be a buffer,
-;; file name, or other. This makes use of table more robust.
-(cl-defmethod semanticdb-full-filename (buffer-or-string)
- "Fetch the full filename that BUFFER-OR-STRING refers to.
-This uses semanticdb to get a better file name."
- (cond ((bufferp buffer-or-string)
- (with-current-buffer buffer-or-string
- (semanticdb-full-filename semanticdb-current-table)))
- ((and (stringp buffer-or-string) (file-exists-p buffer-or-string))
- (expand-file-name buffer-or-string))))
-
-(cl-defmethod semanticdb-full-filename ((_obj semanticdb-abstract-table))
- "Fetch the full filename that OBJ refers to.
-Abstract tables do not have file names associated with them."
- nil)
-
-(cl-defmethod semanticdb-dirty-p ((_obj semanticdb-abstract-table))
- "Return non-nil if OBJ is dirty."
- nil)
-
-(cl-defmethod semanticdb-set-dirty ((_obj semanticdb-abstract-table))
- "Mark the abstract table OBJ dirty.
-Abstract tables can not be marked dirty, as there is nothing
-for them to synchronize against."
- ;; The abstract table can not be dirty.
- nil)
-
-(cl-defmethod semanticdb-normalize-tags ((_obj semanticdb-abstract-table) tags)
- "For the table OBJ, convert a list of TAGS, into standardized form.
-The default is to return TAGS.
-Some databases may default to searching and providing simplified tags
-based on whichever technique used. This method provides a hook for
-them to convert TAG into a more complete form."
- tags)
-
-(cl-defmethod semanticdb-normalize-one-tag ((obj semanticdb-abstract-table) tag)
- "For the table OBJ, convert a TAG, into standardized form.
-This method returns a list of the form (DATABASE . NEWTAG).
-
-The default is to just return (OBJ TAG).
-
-Some databases may default to searching and providing simplified tags
-based on whichever technique used. This method provides a hook for
-them to convert TAG into a more complete form."
- (cons obj tag))
-
-;;; Index Cache
-;;
-(defclass semanticdb-abstract-search-index ()
- ((table :initarg :table
- :type semanticdb-abstract-table
- :documentation "XRef to the table this belongs to.")
- )
- "A place where semanticdb-find can store search index information.
-The search index will store data about which other tables might be
-needed, or perhaps create hash or index tables for the current buffer."
- :abstract t)
-
-(cl-defmethod semanticdb-get-table-index ((obj semanticdb-abstract-table))
- "Return the search index for the table OBJ.
-If one doesn't exist, create it."
- (if (slot-boundp obj 'index)
- (oref obj index)
- (let ((idx nil))
- (setq idx (funcall semanticdb-default-find-index-class
- (concat (eieio-object-name obj) " index")
- ;; Fill in the defaults
- :table obj
- ))
- (setf (slot-value obj 'index) idx)
- idx)))
-
-(cl-defmethod semanticdb-synchronize ((_idx semanticdb-abstract-search-index)
- _new-tags)
- "Synchronize the search index IDX with some NEW-TAGS."
- ;; The abstract class will do... NOTHING!
- )
-
-(cl-defmethod semanticdb-partial-synchronize
- ((_idx semanticdb-abstract-search-index)
- _new-tags)
- "Synchronize the search index IDX with some changed NEW-TAGS."
- ;; The abstract class will do... NOTHING!
- )
-
-
-;;; SEARCH RESULTS TABLE
-;;
-;; Needed for system databases that may not provide
-;; a semanticdb-table associated with a file.
-;;
-(defclass semanticdb-search-results-table (semanticdb-abstract-table)
- ()
- "Table used for search results when there is no file or table association.
-Examples include search results from external sources such as from
-Emacs's own symbol table, or from external libraries.")
-
-(cl-defmethod semanticdb-refresh-table ((_obj semanticdb-search-results-table)
- &optional _force)
- "If the tag list associated with OBJ is loaded, refresh it.
-This will call `semantic-fetch-tags' if that file is in memory."
- nil)
-
-;;; CONCRETE TABLE CLASSES
-;;
-(defclass semanticdb-table (semanticdb-abstract-table)
- ((file :initarg :file
- :documentation "File name relative to the parent database.
-This is for the file whose tags are stored in this TABLE object.")
- (buffer :initform nil
- :documentation "The buffer associated with this table.
-If nil, the table's buffer is no in Emacs. If it has a value, then
-it is in Emacs.")
- (dirty :initform nil
- :documentation
- "Non-nil if this table needs to be `Saved'.")
- (db-refs :initform nil
- :documentation
- "List of `semanticdb-table' objects referring to this one.
-These aren't saved, but are instead recalculated after load.
-See the file semantic/db-ref.el for how this slot is used.")
- (pointmax :initarg :pointmax
- :initform nil
- :documentation "Size of buffer when written to disk.
-Checked on retrieval to make sure the file is the same.")
- (fsize :initarg :fsize
- :initform nil
- :documentation "Size of the file when it was last referenced.
-Checked when deciding if a loaded table needs updating from changes
-outside of Semantic's control.")
- (lastmodtime :initarg :lastmodtime
- :initform nil
- :documentation "Last modification time of the file referenced.
-Checked when deciding if a loaded table needs updating from changes outside of
-Semantic's control.")
- ;; @todo - need to add `last parsed time', so we can also have
- ;; refresh checks if spp tables or the parser gets rebuilt.
- (unmatched-syntax :initarg :unmatched-syntax
- :documentation
- "List of vectors specifying unmatched syntax.")
-
- (lexical-table :initarg :lexical-table
- :initform nil
- :printer semantic-lex-spp-table-write-slot-value
- :documentation
- "Table that might be needed by the lexical analyzer.
-For C/C++, the C preprocessor macros can be saved here.")
- )
- "A single table of tags derived from file.")
-
-(cl-defmethod semantic-tag-parent-buffer ((parent semanticdb-table))
- (semanticdb-get-buffer parent)) ;FIXME: η-redex!
-
-(cl-defmethod semanticdb-in-buffer-p ((obj semanticdb-table))
- "Return a buffer associated with OBJ.
-If the buffer is in memory, return that buffer."
- (let ((buff (oref obj buffer)))
- (if (buffer-live-p buff)
- buff
- (setf (slot-value obj 'buffer) nil))))
-
-(cl-defmethod semanticdb-get-buffer ((obj semanticdb-table))
- "Return a buffer associated with OBJ.
-If the buffer is in memory, return that buffer.
-If the buffer is not in memory, load it with `find-file-noselect'."
- (or (semanticdb-in-buffer-p obj)
- ;; Save match data to protect against odd stuff in mode hooks.
- (save-match-data
- (find-file-noselect (semanticdb-full-filename obj) t))))
-
-(cl-defmethod semanticdb-set-buffer ((obj semanticdb-table))
- "Set the current buffer to be a buffer owned by OBJ.
-If OBJ's file is not loaded, read it in first."
- (set-buffer (semanticdb-get-buffer obj)))
-
-(cl-defmethod semanticdb-dirty-p ((obj semanticdb-table))
- "Return non-nil if OBJ is dirty."
- (oref obj dirty))
-
-(cl-defmethod semanticdb-set-dirty ((obj semanticdb-table))
- "Mark the abstract table OBJ dirty."
- (setf (slot-value obj 'dirty) t)
- )
-
-(cl-defmethod semanticdb-debug-info ((obj semanticdb-table))
- (list (format "(%d tags)%s"
- (length (semanticdb-get-tags obj))
- (if (oref obj dirty)
- ", DIRTY"
- ""))))
-
-(cl-defmethod cl-print-object ((obj semanticdb-table) stream)
- "Pretty printer extension for `semanticdb-table'.
-Adds the number of tags in this file to the object print name."
- (princ (eieio-object-name obj (semanticdb-debug-info obj))
- stream))
-
-;;; DATABASE BASE CLASS
-;;
-(cl-deftype semanticdb-abstract-table-list ()
- '(list-of semanticdb-abstract-table))
-
-(defclass semanticdb-project-database (eieio-instance-tracker)
- ((tracking-symbol :initform 'semanticdb-database-list)
- (reference-directory :type string
- :documentation "Directory this database refers to.
-When a cache directory is specified, then this refers to the directory
-this database contains symbols for.")
- (new-table-class :initform 'semanticdb-table
- :type class
- :documentation
- "New tables created for this database are of this class.")
- (cache :type list
- :initform nil
- :documentation "List of cache information for tools.
-Any particular tool can cache data to a database at runtime
-with `semanticdb-cache-get'.
-
-Using a semanticdb cache does not save any information to a file,
-so your cache will need to be recalculated at runtime.
-
-Note: This index will not be saved in a persistent file.")
- (tables :initarg :tables
- :type semanticdb-abstract-table-list
- ;; Need this protection so apps don't try to access
- ;; the tables without using the accessor.
- :accessor semanticdb-get-database-tables
- :protection :protected
- :documentation "List of `semanticdb-table' objects."))
- "Database of file tables.")
-
-(cl-defmethod semanticdb-full-filename ((obj semanticdb-table))
- "Fetch the full filename that OBJ refers to."
- (expand-file-name (oref obj file)
- (oref (oref obj parent-db) reference-directory)))
-
-(cl-defmethod semanticdb-full-filename ((_obj semanticdb-project-database))
- "Fetch the full filename that OBJ refers to.
-Abstract tables do not have file names associated with them."
- nil)
-
-(cl-defmethod semanticdb-dirty-p ((DB semanticdb-project-database))
- "Return non-nil if DB is dirty.
-A database is dirty if the state of the database changed in a way
-where it may need to resynchronize with some persistent storage."
- (let ((dirty nil)
- (tabs (oref DB tables)))
- (while (and (not dirty) tabs)
- (setq dirty (semanticdb-dirty-p (car tabs)))
- (setq tabs (cdr tabs)))
- dirty))
-
-(cl-defmethod semanticdb-debug-info ((obj semanticdb-project-database))
- (list (format "(%d tables%s)"
- (length (semanticdb-get-database-tables obj))
- (if (semanticdb-dirty-p obj)
- " DIRTY" ""))))
-
-(cl-defmethod cl-print-object ((obj semanticdb-project-database) stream)
- "Pretty printer extension for `semanticdb-project-database'.
-Adds the number of tables in this file to the object print name."
- (princ (eieio-object-name obj (semanticdb-debug-info obj))
- stream))
-
-(cl-defmethod semanticdb-create-database ((_dbc (subclass semanticdb-project-database)) directory)
- "Create a new semantic database of class DBC for DIRECTORY and return it.
-If a database for DIRECTORY has already been created, return it.
-If DIRECTORY doesn't exist, create a new one."
- (let ((db (semanticdb-directory-loaded-p directory)))
- (unless db
- (setq db (semanticdb-project-database :tables nil))
- ;; Set this up here. We can't put it in the constructor because it
- ;; would be saved, and we want DB files to be portable.
- (setf (slot-value db 'reference-directory) (file-truename directory)))
- db))
-
-(cl-defmethod semanticdb-flush-database-tables ((db semanticdb-project-database))
- "Reset the tables in DB to be empty."
- (setf (slot-value db 'tables) nil))
-
-(cl-defmethod semanticdb-create-table ((db semanticdb-project-database) file)
- "Create a new table in DB for FILE and return it.
-The class of DB contains the class name for the type of table to create.
-If the table for FILE exists, return it.
-If the table for FILE does not exist, create one."
- (let ((newtab (semanticdb-file-table db file)))
- (unless newtab
- ;; This implementation will satisfy autoloaded classes
- ;; for tables.
- (setq newtab (funcall (oref db new-table-class)
- (file-name-nondirectory file)
- :file (file-name-nondirectory file)
- ))
- (setf (slot-value newtab 'parent-db) db)
- (object-add-to-list db 'tables newtab t))
- newtab))
-
-(cl-defmethod semanticdb-file-table ((obj semanticdb-project-database) filename)
- "From OBJ, return FILENAME's associated table object."
- (object-assoc (file-relative-name (file-truename filename)
- (oref obj reference-directory))
- 'file (oref obj tables)))
-
-;; DATABASE FUNCTIONS
-(defun semanticdb-get-database (filename)
- "Get a database for FILENAME.
-If one isn't found, create one."
- (semanticdb-create-database semanticdb-new-database-class (file-truename filename)))
-
-(defun semanticdb-directory-loaded-p (path)
- "Return the project belonging to PATH if it was already loaded."
- (eieio-instance-tracker-find path 'reference-directory 'semanticdb-database-list))
-
-(defun semanticdb-create-table-for-file (filename)
- "Initialize a database table for FILENAME, and return it.
-If FILENAME exists in the database already, return that.
-If there is no database for the table to live in, create one."
- (let ((cdb nil)
- (tbl nil)
- (dd (file-name-directory (file-truename filename)))
- )
- ;; Allow a database override function
- (setq cdb (semanticdb-create-database semanticdb-new-database-class
- dd))
- ;; Get a table for this file.
- (setq tbl (semanticdb-create-table cdb filename))
-
- ;; Return the pair.
- (cons cdb tbl)
- ))
-
-;;; Cache Cache.
-;;
-(defclass semanticdb-abstract-cache ()
- ((table :initarg :table
- :type semanticdb-abstract-table
- :documentation
- "Cross reference to the table this belongs to.")
- )
- "Abstract baseclass for tools to use to cache information in semanticdb.
-Tools needing a per-file cache must subclass this, and then get one as
-needed. Cache objects are identified in semanticdb by subclass.
-In order to keep your cache up to date, be sure to implement
-`semanticdb-synchronize', and `semanticdb-partial-synchronize'.
-See the file semantic/scope.el for an example."
- :abstract t)
-
-(cl-defmethod semanticdb-cache-get ((table semanticdb-abstract-table)
- desired-class)
- "Get a cache object on TABLE of class DESIRED-CLASS.
-This method will create one if none exists with no init arguments
-other than :table."
- (unless (child-of-class-p desired-class 'semanticdb-abstract-cache)
- (error "Invalid SemanticDB cache"))
- (let ((cache (oref table cache))
- (obj nil))
- (while (and (not obj) cache)
- (if (eq (eieio-object-class (car cache)) desired-class)
- (setq obj (car cache)))
- (setq cache (cdr cache)))
- (if obj
- obj ;; Just return it.
- ;; No object, let's create a new one and return that.
- (setq obj (funcall desired-class "Cache" :table table))
- (object-add-to-list table 'cache obj)
- obj)))
-
-(cl-defmethod semanticdb-cache-remove ((table semanticdb-abstract-table)
- cache)
- "Remove from TABLE the cache object CACHE."
- (object-remove-from-list table 'cache cache))
-
-(cl-defmethod semanticdb-synchronize ((_cache semanticdb-abstract-cache)
- _new-tags)
- "Synchronize a CACHE with some NEW-TAGS."
- ;; The abstract class will do... NOTHING!
- )
-
-(cl-defmethod semanticdb-partial-synchronize ((_cache semanticdb-abstract-cache)
- _new-tags)
- "Synchronize a CACHE with some changed NEW-TAGS."
- ;; The abstract class will do... NOTHING!
- )
-
-(defclass semanticdb-abstract-db-cache ()
- ((db :initarg :db
- :type semanticdb-project-database
- :documentation
- "Cross reference to the database this belongs to.")
- )
- "Abstract baseclass for tools to use to cache information in semanticdb.
-Tools needing a database cache must subclass this, and then get one as
-needed. Cache objects are identified in semanticdb by subclass.
-In order to keep your cache up to date, be sure to implement
-`semanticdb-synchronize', and `semanticdb-partial-synchronize'.
-See the file semantic/scope.el for an example."
- :abstract t)
-
-(cl-defmethod semanticdb-cache-get ((db semanticdb-project-database)
- desired-class)
- "Get a cache object on DB of class DESIRED-CLASS.
-This method will create one if none exists with no init arguments
-other than :table."
- (unless (child-of-class-p desired-class 'semanticdb-abstract-cache)
- (error "Invalid SemanticDB cache"))
- (let ((cache (oref db cache))
- (obj nil))
- (while (and (not obj) cache)
- (if (eq (eieio-object-class (car cache)) desired-class)
- (setq obj (car cache)))
- (setq cache (cdr cache)))
- (if obj
- obj ;; Just return it.
- ;; No object, let's create a new one and return that.
- (setq obj (funcall desired-class "Cache" :db db))
- (object-add-to-list db 'cache obj)
- obj)))
-
-(cl-defmethod semanticdb-cache-remove ((db semanticdb-project-database)
- cache)
- "Remove from TABLE the cache object CACHE."
- (object-remove-from-list db 'cache cache))
-
-
-(cl-defmethod semanticdb-synchronize ((_cache semanticdb-abstract-db-cache)
- _new-tags)
- "Synchronize a CACHE with some NEW-TAGS."
- ;; The abstract class will do... NOTHING!
- )
-
-(cl-defmethod semanticdb-partial-synchronize ((_cache semanticdb-abstract-db-cache)
- _new-tags)
- "Synchronize a CACHE with some changed NEW-TAGS."
- ;; The abstract class will do... NOTHING!
- )
-
-;;; REFRESH
-
-(cl-defmethod semanticdb-refresh-table ((obj semanticdb-table) &optional force)
- "If the tag list associated with OBJ is loaded, refresh it.
-Optional argument FORCE will force a refresh even if the file in question
-is not in a buffer. Avoid using FORCE for most uses, as an old cache
-may be sufficient for the general case. Forced updates can be slow.
-This will call `semantic-fetch-tags' if that file is in memory."
- (cond
- ;;
- ;; Already in a buffer, just do it.
- ((semanticdb-in-buffer-p obj)
- (save-excursion
- (semanticdb-set-buffer obj)
- (semantic-fetch-tags)))
- ;;
- ;; Not in a buffer. Forcing a load.
- (force
- ;; Patch from Iain Nicol. --
- ;; @TODO: I wonder if there is a way to recycle
- ;; semanticdb-create-table-for-file-not-in-buffer
- (save-excursion
- (let ((buff (semantic-find-file-noselect
- (semanticdb-full-filename obj) t)))
- (set-buffer buff)
- (semantic-fetch-tags)
- ;; Kill off the buffer if it didn't exist when we were called.
- (kill-buffer buff))))))
-
-(cl-defmethod semanticdb-needs-refresh-p ((obj semanticdb-table))
- "Return non-nil if OBJ's tag list is out of date.
-The file associated with OBJ does not need to be in a buffer."
- (let* ((ff (semanticdb-full-filename obj))
- (buff (semanticdb-in-buffer-p obj))
- )
- (if buff
- (with-current-buffer buff
- ;; Use semantic's magic tracker to determine of the buffer is up
- ;; to date or not.
- (not (semantic-parse-tree-up-to-date-p))
- ;; We assume that semanticdb is keeping itself up to date.
- ;; via all the clever hooks
- )
- ;; Buffer isn't loaded. The only clue we have is if the file
- ;; is somehow different from our mark in the semanticdb table.
- (let* ((stats (file-attributes ff))
- (actualsize (file-attribute-size stats))
- (actualmod (file-attribute-modification-time stats))
- )
-
- (or (not (slot-boundp obj 'tags))
- ;; (not (oref obj tags)) --> not needed anymore?
- (/= (or (oref obj fsize) 0) actualsize)
- (not (time-equal-p (oref obj lastmodtime) actualmod))
- )
- ))))
-
-\f
-;;; Synchronization
-;;
-(cl-defmethod semanticdb-synchronize ((table semanticdb-abstract-table)
- new-tags)
- "Synchronize the table TABLE with some NEW-TAGS."
- (setf (slot-value table 'tags) new-tags)
- (setf (slot-value table 'pointmax) (point-max))
- (let ((fattr (file-attributes (semanticdb-full-filename table))))
- (setf (slot-value table 'fsize) (file-attribute-size fattr))
- (setf (slot-value table 'lastmodtime)
- (file-attribute-modification-time fattr)))
-
- ;; Assume it is now up to date.
- (setf (slot-value table 'unmatched-syntax) semantic-unmatched-syntax-cache)
- ;; The lexical table should be good too.
- (when (featurep 'semantic/lex-spp)
- (setf (slot-value table 'lexical-table) (semantic-lex-spp-save-table)))
- ;; this implies dirtiness
- (semanticdb-set-dirty table)
-
- ;; Synchronize the index
- (when (slot-boundp table 'index)
- (let ((idx (oref table index)))
- (when idx (semanticdb-synchronize idx new-tags))))
-
- ;; Synchronize application caches.
- (dolist (C (oref table cache))
- (semanticdb-synchronize C new-tags)
- )
-
- ;; Update cross references
- (semanticdb-refresh-references table)
- )
-
-(cl-defmethod semanticdb-partial-synchronize ((table semanticdb-abstract-table)
- new-tags)
- "Synchronize the table TABLE where some NEW-TAGS changed."
- ;; You might think we need to reset the tags, but since the partial
- ;; parser splices the lists, we don't need to do anything
- ;;(setf (slot-value table 'tags) new-tags)
- ;; We do need to mark ourselves dirty.
- (semanticdb-set-dirty table)
-
- ;; The lexical table may be modified.
- (when (featurep 'semantic/lex-spp)
- (setf (slot-value table 'lexical-table) (semantic-lex-spp-save-table)))
-
- ;; Incremental parser doesn't monkey around with this.
- (setf (slot-value table 'unmatched-syntax) semantic-unmatched-syntax-cache)
-
- ;; Synchronize the index
- (when (slot-boundp table 'index)
- (let ((idx (oref table index)))
- (when idx (semanticdb-partial-synchronize idx new-tags))))
-
- ;; Synchronize application caches.
- (dolist (C (oref table cache))
- (semanticdb-synchronize C new-tags)
- )
-
- ;; Update cross references
- (when (semantic-find-tags-by-class 'include new-tags)
- (semanticdb-refresh-references table))
- )
-
-;;; SAVE/LOAD
-;;
-(cl-defmethod semanticdb-save-db ((_DB semanticdb-project-database)
- &optional _suppress-questions)
- "Cause a database to save itself.
-The database base class does not save itself persistently.
-Subclasses could save themselves to a file, or to a database, or other
-form."
- nil)
-
-(defun semanticdb-save-current-db ()
- "Save the current tag database."
- (interactive)
- (unless noninteractive
- (message "Saving current tag summaries..."))
- (semanticdb-save-db semanticdb-current-database)
- (unless noninteractive
- (message "Saving current tag summaries...done")))
-
-;; This prevents Semanticdb from querying multiple times if the users
-;; answers "no" to creating the Semanticdb directory.
-(defvar semanticdb--inhibit-make-directory)
-
-(defun semanticdb-save-all-db ()
- "Save all semantic tag databases."
- (interactive)
- (unless noninteractive
- (message "Saving tag summaries..."))
- (let ((semanticdb--inhibit-make-directory noninteractive))
- (mapc #'semanticdb-save-db semanticdb-database-list))
- (unless noninteractive
- (message "Saving tag summaries...done")))
-
-(defun semanticdb-save-all-db-idle ()
- "Save all semantic tag databases from idle time.
-Exit the save between databases if there is user input."
- (semantic-safe "Auto-DB Save: %S"
- ;; FIXME: Use `while-no-input'?
- (semantic-exit-on-input 'semanticdb-idle-save
- (mapc (lambda (db)
- (semantic-throw-on-input 'semanticdb-idle-save)
- (semanticdb-save-db db t))
- semanticdb-database-list))
- ))
-
-;;; Directory Project support
-;;
-(defvar semanticdb-project-predicate-functions nil
- "List of predicates to try that indicate a directory belongs to a project.
-This list is used when `semanticdb-persistent-path' contains the value
-`project'. If the predicate list is nil, then presume all paths are valid.
-
-Project Management software (such as EDE and JDE) should add their own
-predicates with `add-hook' to this variable, and semanticdb will save tag
-caches in directories controlled by them.")
-
-(cl-defmethod semanticdb-write-directory-p ((_obj semanticdb-project-database))
- "Return non-nil if OBJ should be written to disk.
-Uses `semanticdb-persistent-path' to determine the return value."
- nil)
-
-;;; Utilities
-;;
-;; What is the current database, are two tables of an equivalent mode,
-;; and what databases are a part of the same project.
-(defun semanticdb-current-database ()
- "Return the currently active database."
- (or semanticdb-current-database
- (and default-directory
- (semanticdb-create-database semanticdb-new-database-class
- default-directory)
- )
- nil))
-
-(defvar semanticdb-match-any-mode nil
- "Non-nil to temporarily search any major mode for a tag.
-If a particular major mode wants to search any mode, put the
-`semantic-match-any-mode' symbol onto the symbol of that major mode.
-Do not set the value of this variable permanently.")
-
-(defmacro semanticdb-with-match-any-mode (&rest body)
- "A Semanticdb search occurring within BODY will search tags in all modes.
-This temporarily sets `semanticdb-match-any-mode' while executing BODY."
- (declare (indent 0) (debug t))
- `(let ((semanticdb-match-any-mode t))
- ,@body))
-
-(cl-defmethod semanticdb-equivalent-mode-for-search (table &optional buffer)
- "Return non-nil if TABLE's mode is equivalent to BUFFER.
-See `semanticdb-equivalent-mode' for details.
-This version is used during searches. Major-modes that opt
-to set the `semantic-match-any-mode' property will be able to search
-all files of any type."
- (or (get major-mode 'semantic-match-any-mode)
- semanticdb-match-any-mode
- (semanticdb-equivalent-mode table buffer))
- )
-
-(cl-defmethod semanticdb-equivalent-mode ((_table semanticdb-abstract-table) &optional _buffer)
- "Return non-nil if TABLE's mode is equivalent to BUFFER.
-Equivalent modes are specified by the `semantic-equivalent-major-modes'
-local variable."
- nil)
-
-(cl-defmethod semanticdb-equivalent-mode ((table semanticdb-table) &optional buffer)
- "Return non-nil if TABLE's mode is equivalent to BUFFER.
-Equivalent modes are specified by the `semantic-equivalent-major-modes'
-local variable."
- (save-excursion
- (if buffer (set-buffer buffer))
- (or
- ;; nil major mode in table means we don't know yet. Assume yes for now?
- (null (oref table major-mode))
- ;; nil means the same as major-mode
- (and (not semantic-equivalent-major-modes)
- (provided-mode-derived-p major-mode (oref table major-mode)))
- (and semantic-equivalent-major-modes
- (member (oref table major-mode) semantic-equivalent-major-modes))
- )
- ))
-
-
-;;; Associations
-;;
-;; These routines determine associations between a file, and multiple
-;; associated databases.
-
-(defcustom semanticdb-project-roots nil
- "List of directories, where each directory is the root of some project.
-All subdirectories of a root project are considered a part of one project.
-Values in this string can be overridden by project management programs
-via the `semanticdb-project-root-functions' variable."
- :type '(repeat string))
-
-(defvar semanticdb-project-root-functions nil
- "List of functions used to determine a given directories project root.
-Functions in this variable can override `semanticdb-project-roots'.
-Functions set in the variable are given one argument (a directory) and
-must return a string, (the root directory) or a list of strings (multiple
-root directories in a more complex system). This variable should be used
-by project management programs like EDE or JDE.")
-
-(defvar-local semanticdb-project-system-databases nil
- "List of databases containing system library information.
-Mode authors can create their own system databases which know
-detailed information about the system libraries for querying purposes.
-Put those into this variable as a buffer-local, or mode-local
-value.")
-
-(defvar semanticdb-search-system-databases t
- "Non-nil if search routines are to include a system database.")
-
-(defun semanticdb-current-database-list (&optional dir)
- "Return a list of databases associated with the current buffer.
-If optional argument DIR is non-nil, then use DIR as the starting directory.
-If this buffer has a database, but doesn't have a project associated
-with it, return nil.
-First, it checks `semanticdb-project-root-functions', and if that
-has no results, it checks `semanticdb-project-roots'. If that fails,
-it returns the results of function `semanticdb-current-database'.
-Always append `semanticdb-project-system-databases' if
-`semanticdb-search-system' is non-nil."
- (let ((root nil) ; found root directory
- (dbs nil) ; collected databases
- (roots semanticdb-project-roots) ;all user roots
- (dir (file-truename (or dir default-directory)))
- )
- ;; Find the root based on project functions.
- (setq root (run-hook-with-args-until-success
- 'semanticdb-project-root-functions
- dir))
- (if root
- (setq root (file-truename root))
- ;; Else, Find roots based on strings
- (while roots
- (let ((r (file-truename (car roots))))
- (if (string-match (concat "^" (regexp-quote r)) dir)
- (setq root r)))
- (setq roots (cdr roots))))
-
- ;; If no roots are found, use this directory.
- (unless root (setq root dir))
-
- ;; Find databases based on the root directory.
- (when root
- ;; The rootlist allows the root functions to possibly
- ;; return several roots which are in different areas but
- ;; all apart of the same system.
- (let ((regexp (concat "^" (regexp-quote root)))
- (adb semanticdb-database-list) ; all databases
- )
- (while adb
- ;; I don't like this part, but close enough.
- (if (and (slot-boundp (car adb) 'reference-directory)
- (string-match regexp (oref (car adb) reference-directory)))
- (setq dbs (cons (car adb) dbs)))
- (setq adb (cdr adb))))
- )
- ;; Add in system databases
- (when semanticdb-search-system-databases
- (setq dbs (nconc dbs semanticdb-project-system-databases)))
- ;; Return
- dbs))
-
-\f
-;;; Generic Accessor Routines
-;;
-;; These routines can be used to get at tags in files w/out
-;; having to know a lot about semanticDB.
-(defvar semanticdb-file-table-hash (make-hash-table :test 'equal)
- "Hash table mapping file names to database tables.")
-
-(defun semanticdb-file-table-object-from-hash (file)
- "Retrieve a DB table from the hash for FILE.
-Does not use `file-truename'."
- (gethash file semanticdb-file-table-hash 'no-hit))
-
-(defun semanticdb-file-table-object-put-hash (file dbtable)
- "For FILE, associate DBTABLE in the hash table."
- (puthash file dbtable semanticdb-file-table-hash))
-
-;;;###autoload
-(defun semanticdb-file-table-object (file &optional dontload)
- "Return a semanticdb table belonging to FILE, make it up to date.
-If file has database tags available in the database, return it.
-If file does not have tags available, and DONTLOAD is nil,
-then load the tags for FILE, and create a new table object for it.
-DONTLOAD does not affect the creation of new database objects."
- ;; (message "Object Translate: %s" file)
- (when (and file (file-exists-p file) (file-regular-p file))
- (let* ((default-directory (file-name-directory file))
- (tab (semanticdb-file-table-object-from-hash file))
- (fullfile nil))
-
- ;; If it is not in the cache, then extract the more traditional
- ;; way by getting the database, and finding a table in that database.
- ;; Once we have a table, add it to the hash.
- (when (eq tab 'no-hit)
- (setq fullfile (file-truename file))
- (let ((db (or ;; This line will pick up system databases.
- (semanticdb-directory-loaded-p default-directory)
- ;; this line will make a new one if needed.
- (semanticdb-get-database default-directory))))
- (setq tab (semanticdb-file-table db fullfile))
- (when tab
- (semanticdb-file-table-object-put-hash file tab)
- (when (not (string= fullfile file))
- (semanticdb-file-table-object-put-hash fullfile tab)
- ))
- ))
-
- (cond
- ((and tab
- ;; Is this in a buffer?
- ;;(find-buffer-visiting (semanticdb-full-filename tab))
- (semanticdb-in-buffer-p tab)
- )
- (save-excursion
- ;;(set-buffer (find-buffer-visiting (semanticdb-full-filename tab)))
- (semanticdb-set-buffer tab)
- (semantic-fetch-tags)
- ;; Return the table.
- tab))
- ((and tab dontload)
- ;; If we have table, and we don't want to load it, just return it.
- tab)
- ((and tab
- ;; Is table fully loaded, or just a proxy?
- (number-or-marker-p (oref tab pointmax))
- ;; Is this table up to date with the file?
- (not (semanticdb-needs-refresh-p tab)))
- ;; A-ok!
- tab)
- ((or (and fullfile (get-file-buffer fullfile))
- (get-file-buffer file))
- ;; are these two calls this faster than `find-buffer-visiting'?
-
- ;; If FILE is being visited, but none of the above state is
- ;; true (meaning, there is no table object associated with it)
- ;; then it is a file not supported by Semantic, and can be safely
- ;; ignored.
- nil)
- ((not dontload) ;; We must load the file.
- ;; Full file should have been set by now. Debug why not?
- (when (and (not tab) (not fullfile))
- ;; This case is if a 'nil is erroneously put into the hash table. This
- ;; would need fixing
- (setq fullfile (file-truename file))
- )
-
- ;; If we have a table, but no fullfile, that's ok. Let's get the filename
- ;; from the table which is pre-truenamed.
- (when (and (not fullfile) tab)
- (setq fullfile (semanticdb-full-filename tab)))
-
- (setq tab (semanticdb-create-table-for-file-not-in-buffer fullfile))
-
- ;; Save the new table.
- (semanticdb-file-table-object-put-hash file tab)
- (when (not (string= fullfile file))
- (semanticdb-file-table-object-put-hash fullfile tab)
- )
- ;; Done!
- tab)
- (t
- ;; Full file should have been set by now. Debug why not?
- ;; One person found this. Is it a file that failed to parse
- ;; in the past?
- (when (not fullfile)
- (setq fullfile (file-truename file)))
-
- ;; We were asked not to load the file in and parse it.
- ;; Instead just create a database table with no tags
- ;; and a claim of being empty.
- ;;
- ;; This will give us a starting point for storing
- ;; database cross-references so when it is loaded,
- ;; the cross-references will fire and caches will
- ;; be cleaned.
- (let ((ans (semanticdb-create-table-for-file file)))
- (setq tab (cdr ans))
-
- ;; Save the new table.
- (semanticdb-file-table-object-put-hash file tab)
- (when (not (string= fullfile file))
- (semanticdb-file-table-object-put-hash fullfile tab)
- )
- ;; Done!
- tab))
- )
- )))
-
-(defvar-local semanticdb-out-of-buffer-create-table-fcn nil
- "When non-nil, a function for creating a semanticdb table.
-This should take a filename to be parsed.")
-
-(defun semanticdb-create-table-for-file-not-in-buffer (filename)
- "Create a table for the file FILENAME.
-If there are no language specific configurations, this
-function will read in the buffer, parse it, and kill the buffer."
- (if (and semanticdb-out-of-buffer-create-table-fcn
- (not (file-remote-p filename)))
- ;; Use external parser only of the file is accessible to the
- ;; local file system.
- (funcall semanticdb-out-of-buffer-create-table-fcn filename)
- (save-excursion
- (let* ( ;; Remember the buffer to kill
- (kill-buffer-flag (find-buffer-visiting filename))
- (buffer-to-kill (or kill-buffer-flag
- (semantic-find-file-noselect filename t))))
-
- ;; This shouldn't ever be set. Debug some issue here?
- ;; (when kill-buffer-flag (debug))
-
- (set-buffer buffer-to-kill)
- ;; Find file should automatically do this for us.
- ;; Sometimes the DB table doesn't contains tags and needs
- ;; a refresh. For example, when the file is loaded for
- ;; the first time, and the idle scheduler didn't get a
- ;; chance to trigger a parse before the file buffer is
- ;; killed.
- (when semanticdb-current-table
- (semantic-fetch-tags))
- (prog1
- semanticdb-current-table
- (when (not kill-buffer-flag)
- ;; If we had to find the file, then we should kill it
- ;; to keep the master buffer list clean.
- (kill-buffer buffer-to-kill)
- )))))
- )
-
-(defun semanticdb-file-stream (file)
- "Return a list of tags belonging to FILE.
-If file has database tags available in the database, return them.
-If file does not have tags available, then load the file, and create them."
- (let ((table (semanticdb-file-table-object file)))
- (when table
- (semanticdb-get-tags table))))
-
-(provide 'semantic/db)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/db"
-;; End:
-
-;;; semantic/db.el ends here
+++ /dev/null
-;;; semantic/debug.el --- Language Debugger framework -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2003-2005, 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; To provide better support for debugging parsers, this framework
-;; provides the interface for debugging. The work of parsing and
-;; controlling and stepping through the parsing work must be implemented
-;; by the parser.
-;;
-;; Fortunately, the nature of language support files means that the parser
-;; may not need to be instrumented first.
-;;
-;; The debugger uses EIEIO objects. One object controls the user
-;; interface, including stepping, data-view, queries. A second
-;; object implemented here represents the parser itself. A third represents
-;; a parser independent frame which knows how to highlight the parser buffer.
-;; Each parser must implement the interface and override any methods as needed.
-;;
-
-(require 'semantic)
-(require 'eieio)
-(require 'cl-generic)
-(eval-when-compile (require 'semantic/find))
-
-;;; Code:
-
-;;;###autoload
-(defvar-local semantic-debug-parser-source nil
- "For any buffer, the file name (no path) of the parser.
-This would be a parser for a specific language, not the source
-to one of the parser generators.")
-
-;;;###autoload
-(defvar-local semantic-debug-parser-class nil
- "Class to create when building a debug parser object.")
-
-;;;###autoload
-(defvar-local semantic-debug-parser-debugger-source nil
- "Location of the debug parser class.")
-
-(defvar semantic-debug-enabled nil
- "Non-nil when debugging a parser.")
-
-;;; Variables used during a debug session.
-(defvar semantic-debug-current-interface nil
- "The debugger interface currently active for this buffer.")
-
-(defvar semantic-debug-current-parser nil
- "The parser current active for this buffer.")
-
-;;; User Interface Portion
-;;
-(defclass semantic-debug-interface ()
- ((parser-buffer :initarg :parser-buffer
- :type buffer
- :documentation
- "The buffer containing the parser we are debugging.")
- (parser-local-map :initarg :parser-local-map
- :type keymap
- :documentation
- "The local keymap originally in the PARSER buffer.")
- (parser-location :type marker
- :documentation
- "A marker representing where we are in the parser buffer.")
- (source-buffer :initarg :source-buffer
- :type buffer
- :documentation
- "The buffer containing the source we are parsing.
-The :parser-buffer defines a parser that can parse the text in the
-:source-buffer.")
- (source-local-map :initarg :source-local-map
- :type keymap
- :documentation
- "The local keymap originally in the SOURCE buffer.")
- (source-location :type marker
- :documentation
- "A marker representing where we are in the parser buffer.")
- (data-buffer :initarg :data-buffer
- :type buffer
- :documentation
- "Buffer being used to display some useful data.
-These buffers are brought into view when layout occurs.")
- (current-frame :type semantic-debug-frame
- :documentation
- "The currently displayed frame.")
- (overlays :type list
- :initarg nil
- :initform nil
- :documentation
- "Any active overlays being used to show the debug position.")
- )
- "Controls action when in `semantic-debug-mode'.")
-
-;; Methods
-(cl-defmethod semantic-debug-set-frame ((iface semantic-debug-interface) frame)
- "Set the current frame on IFACE to FRAME."
- (if frame
- (oset iface current-frame frame)
- (slot-makeunbound iface 'current-frame)))
-
-(cl-defmethod semantic-debug-set-parser-location ((iface semantic-debug-interface) point)
- "Set the parser location in IFACE to POINT."
- (with-current-buffer (oref iface parser-buffer)
- (if (not (slot-boundp iface 'parser-location))
- (oset iface parser-location (make-marker)))
- (move-marker (oref iface parser-location) point))
- )
-
-(cl-defmethod semantic-debug-set-source-location ((iface semantic-debug-interface) point)
- "Set the source location in IFACE to POINT."
- (with-current-buffer (oref iface source-buffer)
- (if (not (slot-boundp iface 'source-location))
- (oset iface source-location (make-marker)))
- (move-marker (oref iface source-location) point))
- )
-
-(cl-defmethod semantic-debug-interface-layout ((iface semantic-debug-interface))
- "Layout windows in the current frame to facilitate debugging."
- (delete-other-windows)
- ;; Deal with the data buffer
- (when (slot-boundp iface 'data-buffer)
- (let ((lines (/ (frame-height (selected-frame)) 3))
- (cnt (with-current-buffer (oref iface data-buffer)
- (count-lines (point-min) (point-max))))
- )
- ;; Set the number of lines to 1/3, or the size of the data buffer.
- (if (< cnt lines) (setq cnt lines))
-
- (split-window-vertically cnt)
- (switch-to-buffer (oref iface data-buffer))
- )
- (other-window 1))
- ;; Parser
- (switch-to-buffer (oref iface parser-buffer))
- (when (slot-boundp iface 'parser-location)
- (goto-char (oref iface parser-location)))
- (split-window-vertically)
- (other-window 1)
- ;; Source
- (switch-to-buffer (oref iface source-buffer))
- (when (slot-boundp iface 'source-location)
- (goto-char (oref iface source-location)))
- )
-
-(cl-defmethod semantic-debug-highlight-lexical-token ((iface semantic-debug-interface) token)
- "For IFACE, highlight TOKEN in the source buffer .
-TOKEN is a lexical token."
- (set-buffer (oref iface source-buffer))
-
- (object-add-to-list iface 'overlays
- (semantic-lex-highlight-token token))
-
- (semantic-debug-set-source-location iface (semantic-lex-token-start token))
- )
-
-(cl-defmethod semantic-debug-highlight-rule ((iface semantic-debug-interface) nonterm &optional rule match)
- "For IFACE, highlight NONTERM in the parser buffer.
-NONTERM is the name of the rule currently being processed that shows up
-as a nonterminal (or tag) in the source buffer.
-If RULE and MATCH indices are specified, highlight those also."
- (set-buffer (oref iface parser-buffer))
-
- (let* ((rules (semantic-find-tags-by-class 'nonterminal (current-buffer)))
- (nt (semantic-find-first-tag-by-name nonterm rules))
- (o nil)
- )
- (when nt
- ;; I know it is the first symbol appearing in the body of this token.
- (goto-char (semantic-tag-start nt))
-
- (setq o (make-overlay (point) (progn (forward-sexp 1) (point))))
- (overlay-put o 'face 'highlight)
-
- (object-add-to-list iface 'overlays o)
-
- (semantic-debug-set-parser-location iface (overlay-start o))
-
- (when (and rule match)
-
- ;; Rule, an int, is the rule inside the nonterminal we are following.
- (re-search-forward ":\\s-*")
- (while (/= 0 rule)
- (re-search-forward "^\\s-*|\\s-*")
- (setq rule (1- rule)))
-
- ;; Now find the match inside the rule
- (while (/= 0 match)
- (forward-sexp 1)
- (skip-chars-forward " \t")
- (setq match (1- match)))
-
- ;; Now highlight the thingy we find there.
- (setq o (make-overlay (point) (progn (forward-sexp 1) (point))))
- (overlay-put o 'face 'highlight)
-
- (object-add-to-list iface 'overlays o)
-
- ;; If we have a match for a sub-rule, have the parser position
- ;; move so we can see it in the output window for very long rules.
- (semantic-debug-set-parser-location iface (overlay-start o))
-
- ))))
-
-(cl-defmethod semantic-debug-unhighlight ((iface semantic-debug-interface))
- "Remove all debugging overlays."
- (mapc #'delete-overlay (oref iface overlays))
- (oset iface overlays nil))
-
-;; Call from the parser at a breakpoint
-(defvar semantic-debug-user-command nil
- "The command the user is requesting.")
-
-(defun semantic-debug-break (frame)
- "Stop parsing now at FRAME.
-FRAME is an object that represents the parser's view of the
-current state of the world.
-This function enters a recursive edit. It returns
-on an `exit-recursive-edit', or if someone uses one
-of the `semantic-debug-mode' commands.
-It returns the command specified. Parsers need to take action
-on different types of return values."
- (save-window-excursion
- ;; Set up displaying information
- (semantic-debug-mode t)
- (unwind-protect
- (progn
- (semantic-debug-frame-highlight frame)
- (semantic-debug-interface-layout semantic-debug-current-interface)
- (condition-case nil
- ;; Enter recursive edit... wait for user command.
- (recursive-edit)
- (error nil)))
- (semantic-debug-unhighlight semantic-debug-current-interface)
- (semantic-debug-mode nil))
- ;; Find the requested user state. Do something.
- (let ((returnstate semantic-debug-user-command))
- (setq semantic-debug-user-command nil)
- returnstate)
- ))
-
-;;; Frame
-;;
-;; A frame can represent the state at a break point.
-(defclass semantic-debug-frame ()
- (
- )
- "One frame representation.")
-
-(cl-defmethod semantic-debug-frame-highlight ((_frame semantic-debug-frame))
- "Highlight one parser frame."
-
- )
-
-(cl-defmethod semantic-debug-frame-info ((_frame semantic-debug-frame))
- "Display info about this one parser frame."
-
- )
-
-;;; Major Mode
-;;
-(defvar semantic-debug-mode-map
- (let ((km (make-sparse-keymap)))
- (define-key km "n" #'semantic-debug-next)
- (define-key km " " #'semantic-debug-next)
- (define-key km "s" #'semantic-debug-step)
- (define-key km "u" #'semantic-debug-up)
- (define-key km "d" #'semantic-debug-down)
- (define-key km "f" #'semantic-debug-fail-match)
- (define-key km "h" #'semantic-debug-print-state)
- (define-key km "s" #'semantic-debug-jump-to-source)
- (define-key km "p" #'semantic-debug-jump-to-parser)
- (define-key km "q" #'semantic-debug-quit)
- (define-key km "a" #'semantic-debug-abort)
- (define-key km "g" #'semantic-debug-go)
- (define-key km "b" #'semantic-debug-set-breakpoint)
- ;; Some boring bindings.
- (define-key km "e" #'eval-expression)
-
- km)
- "Keymap used when in semantic-debug-node.")
-
-(defun semantic-debug-mode (onoff)
- "Turn `semantic-debug-mode' on and off.
-Argument ONOFF is non-nil when we are entering debug mode.
-\\{semantic-debug-mode-map}"
- (let ((iface semantic-debug-current-interface))
- (if onoff
- ;; Turn it on
- (with-current-buffer (oref iface parser-buffer)
- ;; Install our map onto this buffer
- (use-local-map semantic-debug-mode-map)
- ;; Make the buffer read only
- (setq buffer-read-only t)
-
- (set-buffer (oref iface source-buffer))
- ;; Use our map in the source buffer also
- (use-local-map semantic-debug-mode-map)
- ;; Make the buffer read only
- (setq buffer-read-only t)
- ;; Hooks
- (run-hooks 'semantic-debug-mode-hook)
- )
- ;; Restore old mode information
- (with-current-buffer
- (oref semantic-debug-current-interface parser-buffer)
- (use-local-map
- (oref semantic-debug-current-interface parser-local-map))
- (setq buffer-read-only nil)
- )
- (with-current-buffer
- (oref semantic-debug-current-interface source-buffer)
- (use-local-map
- (oref semantic-debug-current-interface source-local-map))
- (setq buffer-read-only nil)
- )
- (run-hooks 'semantic-debug-exit-hook)
- )))
-
-;;;###autoload
-(defun semantic-debug ()
- "Parse the current buffer and run in debug mode."
- (interactive)
- (if semantic-debug-current-interface
- (error "You are already in a debug session"))
- (if (not semantic-debug-parser-class)
- (error "This major mode does not support parser debugging"))
- ;; Clear the cache to force a full reparse.
- (semantic-clear-toplevel-cache)
- ;; Load in the debugger for this file.
- (when semantic-debug-parser-debugger-source
- (require semantic-debug-parser-debugger-source))
- ;; Do the parse
- (let ((semantic-debug-enabled t)
- ;; Create an interface
- (semantic-debug-current-interface
- (let ((parserb (semantic-debug-find-parser-source)))
- (semantic-debug-interface
- :parser-buffer parserb
- :parser-local-map (with-current-buffer parserb
- (current-local-map))
- :source-buffer (current-buffer)
- :source-local-map (current-local-map)
- )))
- ;; Create a parser debug interface
- (semantic-debug-current-parser
- (funcall semantic-debug-parser-class "parser"))
- )
- ;; We could recurse into a parser while debugging.
- ;; Is that a problem?
- (semantic-fetch-tags)
- ;; We should turn the auto-parser back on, but don't do it for
- ;; now until the debugger is working well.
- ))
-
-(defun semantic-debug-find-parser-source ()
- "Return a buffer containing the parser source file for the current buffer.
-The parser needs to be on the load path, or this routine returns nil."
- (if (not semantic-debug-parser-source)
- (error "No parser is associated with this buffer"))
- (let ((parser (locate-library semantic-debug-parser-source t)))
- (if parser
- (find-file-noselect parser)
- (error "Cannot find parser source. It should be on the load-path"))))
-
-;;; Debugger commands
-;;
-(defun semantic-debug-next ()
- "Perform one parser operation.
-In the recursive parser, this steps past one match rule.
-In other parsers, this may be just like `semantic-debug-step'."
- (interactive)
- (let ((parser semantic-debug-current-parser))
- (semantic-debug-parser-next parser)
- (exit-recursive-edit)
- )
- )
-
-(defun semantic-debug-step ()
- "Perform one parser operation."
- (interactive)
- (let ((parser semantic-debug-current-parser))
- (semantic-debug-parser-step parser)
- (exit-recursive-edit)
- )
- )
-
-(defun semantic-debug-up ()
- "Move highlighting representation up one level."
- (interactive)
- (message "Not implemented yet.")
- )
-
-(defun semantic-debug-down ()
- "Move highlighting representation down one level."
- (interactive)
- (message "Not implemented yet.")
- )
-
-(defun semantic-debug-fail-match ()
- "Artificially fail the current match."
- (interactive)
- (let ((parser semantic-debug-current-parser))
- (semantic-debug-parser-fail parser)
- (exit-recursive-edit)
- )
- )
-
-(defun semantic-debug-print-state ()
- "Show interesting parser state."
- (interactive)
- (let ((parser semantic-debug-current-parser))
- (semantic-debug-parser-print-state parser)
- )
- )
-
-(defun semantic-debug-jump-to-source ()
- "Move cursor to the source code being parsed at the current lexical token."
- (interactive)
- (let* ((interface semantic-debug-current-interface)
- (buf (oref interface source-buffer)))
- (if (get-buffer-window buf)
- (progn
- (select-frame (window-frame (get-buffer-window buf)))
- (select-window (get-buffer-window buf)))
- ;; Technically, this should do a window layout operation
- (switch-to-buffer buf))
- )
- )
-
-(defun semantic-debug-jump-to-parser ()
- "Move cursor to the parser being debugged."
- (interactive)
- (let* ((interface semantic-debug-current-interface)
- (buf (oref interface parser-buffer)))
- (if (get-buffer-window buf)
- (progn
- (select-frame (window-frame (get-buffer-window buf)))
- (select-window (get-buffer-window buf)))
- ;; Technically, this should do a window layout operation
- (switch-to-buffer buf))
- )
- )
-
-(defun semantic-debug-quit ()
- "Exit debug mode, blowing all stack, and leaving the parse incomplete.
-Do not update any tokens already parsed."
- (interactive)
- (let ((parser semantic-debug-current-parser))
- (semantic-debug-parser-quit parser)
- (exit-recursive-edit)
- )
- )
-
-(defun semantic-debug-abort ()
- "Abort one level of debug mode, blowing all stack."
- (interactive)
- (let ((parser semantic-debug-current-parser))
- (semantic-debug-parser-abort parser)
- (exit-recursive-edit)
- )
- )
-
-(defun semantic-debug-go ()
- "Continue parsing till finish or breakpoint."
- (interactive)
- (let ((parser semantic-debug-current-parser))
- (semantic-debug-parser-go parser)
- (exit-recursive-edit)
- )
- )
-
-(defun semantic-debug-set-breakpoint ()
- "Set a breakpoint at the current rule location."
- (interactive)
- (let ((parser semantic-debug-current-parser)
- ;; Get the location as semantic tokens.
- (location (semantic-current-tag))
- )
- (if location
- (semantic-debug-parser-break parser location)
- (error "Not on a rule"))
- )
- )
-
-
-;;; Debugger superclass
-;;
-(defclass semantic-debug-parser ()
- (
- )
- "Represents a parser and its state.
-When implementing the debug parser you can add extra functionality
-by overriding one of the command methods. Be sure to use
-`call-next-method' so that the debug command is saved, and passed
-down to your parser later."
- :abstract t)
-
-(cl-defmethod semantic-debug-parser-next ((_parser semantic-debug-parser))
- "Execute next for this PARSER."
- (setq semantic-debug-user-command 'next)
- )
-
-(cl-defmethod semantic-debug-parser-step ((_parser semantic-debug-parser))
- "Execute a step for this PARSER."
- (setq semantic-debug-user-command 'step)
- )
-
-(cl-defmethod semantic-debug-parser-go ((_parser semantic-debug-parser))
- "Continue execution in this PARSER until the next breakpoint."
- (setq semantic-debug-user-command 'go)
- )
-
-(cl-defmethod semantic-debug-parser-fail ((_parser semantic-debug-parser))
- "Continue execution in this PARSER until the next breakpoint."
- (setq semantic-debug-user-command 'fail)
- )
-
-(cl-defmethod semantic-debug-parser-quit ((_parser semantic-debug-parser))
- "Continue execution in this PARSER until the next breakpoint."
- (setq semantic-debug-user-command 'quit)
- )
-
-(cl-defmethod semantic-debug-parser-abort ((_parser semantic-debug-parser))
- "Continue execution in this PARSER until the next breakpoint."
- (setq semantic-debug-user-command 'abort)
- )
-
-(cl-defmethod semantic-debug-parser-print-state ((_parser semantic-debug-parser))
- "Print state for this PARSER at the current breakpoint."
- (with-slots (current-frame) semantic-debug-current-interface
- (when current-frame
- (semantic-debug-frame-info current-frame)
- )))
-
-(cl-defmethod semantic-debug-parser-break ((_parser semantic-debug-parser))
- "Set a breakpoint for this PARSER."
- )
-
-;; Stack stuff
-(cl-defmethod semantic-debug-parser-frames ((_parser semantic-debug-parser))
- "Return a list of frames for the current parser.
-A frame is of the form:
- ( .. .what ? .. )"
- (error "Parser has not implemented frame values"))
-
-
-(provide 'semantic/debug)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/debug"
-;; End:
-
-;;; semantic/debug.el ends here
+++ /dev/null
-;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Text representing a semantic tag is wrapped in an overlay.
-;; This overlay can be used for highlighting, or setting other
-;; editing properties on a tag, such as "read only."
-;;
-
-(require 'semantic)
-(require 'pulse)
-
-;;; Code:
-
-;;; Highlighting Basics
-(defun semantic-highlight-tag (tag &optional face)
- "Specify that TAG should be highlighted.
-Optional FACE specifies the face to use."
- (let ((o (semantic-tag-overlay tag)))
- (overlay-put o 'old-face
- (cons (overlay-get o 'face)
- (overlay-get o 'old-face)))
- (overlay-put o 'face (or face 'semantic-tag-highlight-face))))
-
-(defun semantic-unhighlight-tag (tag)
- "Unhighlight TAG, restoring its previous face."
- (let ((o (semantic-tag-overlay tag)))
- (overlay-put o 'face (car (overlay-get o 'old-face)))
- (overlay-put o 'old-face (cdr (overlay-get o 'old-face)))
- ))
-
-;;; Momentary Highlighting - One line
-(defun semantic-momentary-highlight-one-tag-line (tag &optional _face)
- "Highlight the first line of TAG, unhighlighting before next command.
-Optional argument FACE specifies the face to do the highlighting."
- (save-excursion
- ;; Go to first line in tag
- (semantic-go-to-tag tag)
- (pulse-momentary-highlight-one-line (point))))
-
-;;; Momentary Highlighting - Whole Tag
-(defun semantic-momentary-highlight-tag (tag &optional face)
- "Highlight TAG, removing highlighting when the user hits a key.
-Optional argument FACE is the face to use for highlighting.
-If FACE is not specified, then `highlight' will be used."
- (when (semantic-tag-with-position-p tag)
- (if (not (overlayp (semantic-tag-overlay tag)))
- ;; No overlay, but a position. Highlight the first line only.
- (semantic-momentary-highlight-one-tag-line tag face)
- ;; The tag has an overlay, highlight the whole thing
- (pulse-momentary-highlight-overlay (semantic-tag-overlay tag)
- face)
- )))
-
-(defun semantic-set-tag-face (tag face)
- "Specify that TAG should use FACE for display."
- (overlay-put (semantic-tag-overlay tag) 'face face))
-
-(defun semantic-set-tag-invisible (tag &optional visible)
- "Enable the text in TAG to be made invisible.
-If VISIBLE is non-nil, make the text visible."
- (overlay-put (semantic-tag-overlay tag) 'invisible
- (not visible)))
-
-(defun semantic-tag-invisible-p (tag)
- "Return non-nil if TAG is invisible."
- (overlay-get (semantic-tag-overlay tag) 'invisible))
-
-(defun semantic-overlay-signal-read-only
- (overlay after start end &optional _len)
- "Hook used in modification hooks to prevent modification.
-Allows deletion of the entire text.
-Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system."
- ;; Stolen blithely from cpp.el in Emacs 21.1
- (if (and (not after)
- (or (< (overlay-start overlay) start)
- (> (overlay-end overlay) end)))
- (error "This text is read only")))
-
-(defun semantic-set-tag-read-only (tag &optional writable)
- "Enable the text in TAG to be made read-only.
-Optional argument WRITABLE should be non-nil to make the text writable
-instead of read-only."
- (let ((o (semantic-tag-overlay tag))
- (hook (if writable nil '(overlay-signal-read-only))))
- (overlay-put o 'modification-hooks hook)
- (overlay-put o 'insert-in-front-hooks hook)
- (overlay-put o 'insert-behind-hooks hook)))
-
-(defun semantic-tag-read-only-p (tag)
- "Return non-nil if the current TAG is marked read only."
- (let ((o (semantic-tag-overlay tag)))
- (member 'semantic-overlay-signal-read-only
- (overlay-get o 'modification-hooks))))
-
-;;; Secondary overlays
-;;
-;; Some types of decoration require a second overlay to be made.
-;; It could be for images, arrows, or whatever.
-;; We need a way to create such an overlay, and make sure it
-;; gets whacked, but doesn't show up in the master list
-;; of overlays used for searching.
-(defun semantic-tag-secondary-overlays (tag)
- "Return a list of secondary overlays active on TAG."
- (semantic--tag-get-property tag 'secondary-overlays))
-
-(defun semantic-tag-create-secondary-overlay (tag &optional link-hook)
- "Create a secondary overlay for TAG.
-Returns an overlay. The overlay is also saved in TAG.
-LINK-HOOK is a function called whenever TAG is to be linked into
-a buffer. It should take TAG and OVERLAY as arguments.
-The LINK-HOOK should be used to position and set properties on the
-generated secondary overlay."
- (if (not (semantic-tag-overlay tag))
- ;; do nothing if there is no overlay
- nil
- (let* ((os (semantic-tag-start tag))
- (oe (semantic-tag-end tag))
- (o (make-overlay os oe (semantic-tag-buffer tag) t))
- (attr (semantic-tag-secondary-overlays tag))
- )
- (semantic--tag-put-property tag 'secondary-overlays (cons o attr))
- (overlay-put o 'semantic-secondary t)
- (overlay-put o 'semantic-link-hook link-hook)
- (semantic-tag-add-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
- (semantic-tag-add-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
- (semantic-tag-add-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
- (run-hook-with-args link-hook tag o)
- o)))
-
-(defun semantic-tag-get-secondary-overlay (tag property)
- "Return secondary overlays from TAG with PROPERTY.
-PROPERTY is a symbol and all overlays with that symbol are returned.."
- (let* ((olsearch (semantic-tag-secondary-overlays tag))
- (o nil))
- (while olsearch
- (when (overlay-get (car olsearch) property)
- (setq o (cons (car olsearch) o)))
- (setq olsearch (cdr olsearch)))
- o))
-
-(defun semantic-tag-delete-secondary-overlay (tag overlay-or-property)
- "Delete from TAG the secondary overlay OVERLAY-OR-PROPERTY.
-If OVERLAY-OR-PROPERTY is an overlay, delete that overlay.
-If OVERLAY-OR-PROPERTY is a symbol, find the overlay with that property."
- (let* ((o overlay-or-property))
- (if (overlayp o)
- (setq o (list o))
- (setq o (semantic-tag-get-secondary-overlay tag overlay-or-property)))
- (while (overlayp (car o))
- ;; We don't really need to worry about the hooks.
- ;; They will clean themselves up eventually ??
- (semantic--tag-put-property
- tag 'secondary-overlays
- (delete (car o) (semantic-tag-secondary-overlays tag)))
- (delete-overlay (car o))
- (setq o (cdr o)))))
-
-(defun semantic--tag-unlink-copy-secondary-overlays (tag)
- "Unlink secondary overlays from TAG which is a copy.
-This means we don't destroy the overlays, only remove reference
-from them in TAG."
- (let ((ol (semantic-tag-secondary-overlays tag)))
- (while ol
- ;; Else, remove all traces of ourself from the tag
- ;; Note to self: Does this prevent multiple types of secondary
- ;; overlays per tag?
- (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
- (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
- (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
- ;; Next!
- (setq ol (cdr ol)))
- (semantic--tag-put-property tag 'secondary-overlays nil)
- ))
-
-(defun semantic--tag-unlink-secondary-overlays (tag)
- "Unlink secondary overlays from TAG."
- (let ((ol (semantic-tag-secondary-overlays tag))
- (nl nil))
- (while ol
- (if (overlay-get (car ol) 'semantic-link-hook)
- ;; Only put in a proxy if there is a link-hook. If there is no link-hook
- ;; the decorating mode must know when tags are unlinked on its own.
- (setq nl (cons (overlay-get (car ol) 'semantic-link-hook)
- nl))
- ;; Else, remove all traces of ourself from the tag
- ;; Note to self: Does this prevent multiple types of secondary
- ;; overlays per tag?
- (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
- (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
- (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
- )
- (delete-overlay (car ol))
- (setq ol (cdr ol)))
- (semantic--tag-put-property tag 'secondary-overlays (nreverse nl))
- ))
-
-(defun semantic--tag-link-secondary-overlays (tag)
- "Unlink secondary overlays from TAG."
- (let ((ol (semantic-tag-secondary-overlays tag)))
- ;; Wipe out old values.
- (semantic--tag-put-property tag 'secondary-overlays nil)
- ;; Run all the link hooks.
- (while ol
- (semantic-tag-create-secondary-overlay tag (car ol))
- (setq ol (cdr ol)))
- ))
-
-;;; Secondary Overlay Uses
-;;
-;; States to put on tags that depend on a secondary overlay.
-(defun semantic-set-tag-folded (tag &optional folded)
- "Fold TAG, such that only the first line of text is shown.
-Optional argument FOLDED should be non-nil to fold the tag.
-nil implies the tag should be fully shown."
- ;; If they are different, do the deed.
- (let ((o (semantic-tag-folded-p tag)))
- (if (not folded)
- ;; We unfold.
- (when o
- (semantic-tag-delete-secondary-overlay tag 'semantic-folded))
- (unless o
- ;; Add the foldn
- (setq o (semantic-tag-create-secondary-overlay tag))
- ;; mark as folded
- (overlay-put o 'semantic-folded t)
- ;; Move to cover end of tag
- (save-excursion
- (goto-char (semantic-tag-start tag))
- (end-of-line)
- (move-overlay o (point) (semantic-tag-end tag)))
- ;; We need to modify the invisibility spec for this to
- ;; work.
- (if (or (eq buffer-invisibility-spec t)
- (not (assoc 'semantic-fold buffer-invisibility-spec)))
- (add-to-invisibility-spec '(semantic-fold . t)))
- (overlay-put o 'invisible 'semantic-fold)
- (overlay-put o 'isearch-open-invisible
- 'semantic-set-tag-folded-isearch)))))
-
-(declare-function semantic-current-tag "semantic/find")
-
-(defun semantic-set-tag-folded-isearch (_overlay)
- "Called by isearch if it discovers text in the folded region.
-OVERLAY is passed in by isearch."
- (semantic-set-tag-folded (semantic-current-tag) nil)
- )
-
-(defun semantic-tag-folded-p (tag)
- "Non-nil if TAG is currently folded."
- (semantic-tag-get-secondary-overlay tag 'semantic-folded)
- )
-
-(provide 'semantic/decorate)
-
-;;; semantic/decorate.el ends here
+++ /dev/null
-;;; semantic/decorate/include.el --- Decoration modes for include statements -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Highlight any include that is in a state the user may care about.
-;; The basic idea is to have the state be highly visible so users will
-;; as 'what is this?" and get the info they need to fix problems that
-;; are otherwise transparent when trying to get smart completion
-;; working.
-
-(require 'semantic/decorate/mode)
-(require 'semantic/db)
-(require 'semantic/db-ref)
-(require 'semantic/db-find)
-
-(eval-when-compile
- (require 'semantic/find))
-
-(defvar semantic-dependency-system-include-path)
-(declare-function ede-get-locator-object "ede/files")
-(declare-function ede-system-include-path "ede/cpp-root")
-
-;;; Code:
-
-;;; FACES AND KEYMAPS
-(defvar semantic-decoration-mouse-3 [ mouse-3 ]
- "The keybinding Lisp object to use for binding the right mouse button.")
-
-;;; Includes that are in a happy state!
-;;
-(defface semantic-decoration-on-includes
- '((t (:inherit default)))
- "Overlay Face used on includes that are not in some other state.
-Used by the decoration style: `semantic-decoration-on-includes'."
- :group 'semantic-faces)
-
-(defvar semantic-decoration-on-include-map
- (let ((km (make-sparse-keymap)))
- (define-key km semantic-decoration-mouse-3 #'semantic-decoration-include-menu)
- km)
- "Keymap used on includes.")
-
-
-(defvar semantic-decoration-on-include-menu nil
- "Menu used for include headers.")
-
-(easy-menu-define
- semantic-decoration-on-include-menu
- semantic-decoration-on-include-map
- "Include Menu."
- (list
- "Include"
- ["What Is This?" semantic-decoration-include-describe
- :active t
- :help "Describe why this include has been marked this way." ]
- ["Visit This Include" semantic-decoration-include-visit
- :active t
- :help "Visit this include file." ]
- "---"
- ["Summarize includes current buffer" semantic-decoration-all-include-summary
- :active t
- :help "Show a summary for the current buffer containing this include." ]
- ["List found includes (load unparsed)" semanticdb-find-test-translate-path
- :active t
- :help "List all includes found for this file, and parse unparsed files." ]
- ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading
- :active t
- :help "List all includes found for this file, do not parse unparsed files." ]
- ["List all unknown includes" semanticdb-find-adebug-lost-includes
- :active t
- :help "Show a list of all includes semantic cannot find for this file." ]
- "---"
- ["Customize System Include Path" semantic-customize-system-include-path
- :active (get 'semantic-dependency-system-include-path major-mode)
- :help "Run customize for the system include path for this major mode." ]
- ["Add a System Include Path" semantic-add-system-include
- :active t
- :help "Add an include path for this session." ]
- ["Remove a System Include Path" semantic-remove-system-include
- :active t
- :help "Add an include path for this session." ]
- ))
-
-;;; Unknown Includes!
-;;
-(defface semantic-decoration-on-unknown-includes
- '((((class color) (background dark))
- (:background "#900000"))
- (((class color) (background light))
- (:background "#fff0f0")))
- "Face used to show includes that cannot be found.
-Used by the decoration style: `semantic-decoration-on-unknown-includes'."
- :group 'semantic-faces)
-
-(defvar semantic-decoration-on-unknown-include-map
- (let ((km (make-sparse-keymap)))
- ;(define-key km [ mouse-2 ] 'semantic-decoration-unknown-include-describe)
- (define-key km semantic-decoration-mouse-3 #'semantic-decoration-unknown-include-menu)
- km)
- "Keymap used on unparsed includes.")
-
-(defvar semantic-decoration-on-unknown-include-menu nil
- "Menu used for unparsed include headers.")
-
-(easy-menu-define
- semantic-decoration-on-unknown-include-menu
- semantic-decoration-on-unknown-include-map
- "Unknown Include Menu."
- (list
- "Unknown Include"
- ["What Is This?" semantic-decoration-unknown-include-describe
- :active t
- :help "Describe why this include has been marked this way." ]
- ["List all unknown includes" semanticdb-find-adebug-lost-includes
- :active t
- :help "Show a list of all includes semantic cannot find for this file." ]
- "---"
- ["Summarize includes current buffer" semantic-decoration-all-include-summary
- :active t
- :help "Show a summary for the current buffer containing this include." ]
- ["List found includes (load unparsed)" semanticdb-find-test-translate-path
- :active t
- :help "List all includes found for this file, and parse unparsed files." ]
- ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading
- :active t
- :help "List all includes found for this file, do not parse unparsed files." ]
- "---"
- ["Customize System Include Path" semantic-customize-system-include-path
- :active (get 'semantic-dependency-system-include-path major-mode)
- :help "Run customize for the system include path for this major mode." ]
- ["Add a System Include Path" semantic-add-system-include
- :active t
- :help "Add an include path for this session." ]
- ["Remove a System Include Path" semantic-remove-system-include
- :active t
- :help "Add an include path for this session." ]
- ))
-
-;;; Includes with no file, but a table
-;;
-(defface semantic-decoration-on-fileless-includes
- '((((class color) (background dark))
- (:background "#009000"))
- (((class color) (background light))
- (:background "#f0fdf0")))
- "Face used to show includes that have no file, but do have a DB table.
-Used by the decoration style: `semantic-decoration-on-fileless-includes'."
- :group 'semantic-faces)
-
-(defvar semantic-decoration-on-fileless-include-map
- (let ((km (make-sparse-keymap)))
- ;(define-key km [ mouse-2 ] 'semantic-decoration-fileless-include-describe)
- (define-key km semantic-decoration-mouse-3 #'semantic-decoration-fileless-include-menu)
- km)
- "Keymap used on unparsed includes.")
-
-(defvar semantic-decoration-on-fileless-include-menu nil
- "Menu used for unparsed include headers.")
-
-(easy-menu-define
- semantic-decoration-on-fileless-include-menu
- semantic-decoration-on-fileless-include-map
- "Fileless Include Menu."
- (list
- "Fileless Include"
- ["What Is This?" semantic-decoration-fileless-include-describe
- :active t
- :help "Describe why this include has been marked this way." ]
- ["List all unknown includes" semanticdb-find-adebug-lost-includes
- :active t
- :help "Show a list of all includes semantic cannot find for this file." ]
- "---"
- ["Summarize includes current buffer" semantic-decoration-all-include-summary
- :active t
- :help "Show a summary for the current buffer containing this include." ]
- ["List found includes (load unparsed)" semanticdb-find-test-translate-path
- :active t
- :help "List all includes found for this file, and parse unparsed files." ]
- ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading
- :active t
- :help "List all includes found for this file, do not parse unparsed files." ]
- "---"
- ["Customize System Include Path" semantic-customize-system-include-path
- :active (get 'semantic-dependency-system-include-path major-mode)
- :help "Run customize for the system include path for this major mode." ]
- ["Add a System Include Path" semantic-add-system-include
- :active t
- :help "Add an include path for this session." ]
- ["Remove a System Include Path" semantic-remove-system-include
- :active t
- :help "Add an include path for this session." ]
- ))
-
-;;; Includes that need to be parsed.
-;;
-(defface semantic-decoration-on-unparsed-includes
- '((((class color) (background dark))
- (:background "#555500"))
- (((class color) (background light))
- (:background "#ffff55")))
- "Face used to show includes that have not yet been parsed.
-Used by the decoration style: `semantic-decoration-on-unparsed-includes'."
- :group 'semantic-faces)
-
-(defvar semantic-decoration-on-unparsed-include-map
- (let ((km (make-sparse-keymap)))
- (define-key km semantic-decoration-mouse-3 #'semantic-decoration-unparsed-include-menu)
- km)
- "Keymap used on unparsed includes.")
-
-
-(defvar semantic-decoration-on-unparsed-include-menu nil
- "Menu used for unparsed include headers.")
-
-(easy-menu-define
- semantic-decoration-on-unparsed-include-menu
- semantic-decoration-on-unparsed-include-map
- "Unparsed Include Menu."
- (list
- "Unparsed Include"
- ["What Is This?" semantic-decoration-unparsed-include-describe
- :active t
- :help "Describe why this include has been marked this way." ]
- ["Visit This Include" semantic-decoration-include-visit
- :active t
- :help "Visit this include file so that header file's tags can be used." ]
- ["Parse This Include" semantic-decoration-unparsed-include-parse-include
- :active t
- :help "Parse this include file so that header file's tags can be used." ]
- ["Parse All Includes" semantic-decoration-unparsed-include-parse-all-includes
- :active t
- :help "Parse all the includes so the contents can be used." ]
- "---"
- ["Summarize includes current buffer" semantic-decoration-all-include-summary
- :active t
- :help "Show a summary for the current buffer containing this include." ]
- ["List found includes (load unparsed)" semanticdb-find-test-translate-path
- :active t
- :help "List all includes found for this file, and parse unparsed files." ]
- ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading
- :active t
- :help "List all includes found for this file, do not parse unparsed files." ]
- ["List all unknown includes" semanticdb-find-adebug-lost-includes
- :active t
- :help "Show a list of all includes semantic cannot find for this file." ]
- "---"
- ["Customize System Include Path" semantic-customize-system-include-path
- :active (get 'semantic-dependency-system-include-path major-mode)
- :help "Run customize for the system include path for this major mode." ]
- ["Add a System Include Path" semantic-add-system-include
- :active t
- :help "Add an include path for this session." ]
- ["Remove a System Include Path" semantic-remove-system-include
- :active t
- :help "Add an include path for this session." ]))
-
-\f
-;;; MODES
-
-;;; Include statement Decorate Mode
-;;
-;; This mode handles the three states of an include statements
-;;
-(define-semantic-decoration-style semantic-decoration-on-includes
- "Highlight class members that are includes.
-This mode provides a nice context menu on the include statements."
- :enabled t)
-
-(defun semantic-decoration-on-includes-p-default (tag)
- "Return non-nil if TAG has is an includes that can't be found."
- (semantic-tag-of-class-p tag 'include))
-
-(defun semantic-decoration-on-includes-highlight-default (tag)
- "Highlight the include TAG to show that semantic can't find it."
- (let* ((file (semantic-dependency-tag-file tag))
- ;; Don't actually load includes
- (semanticdb-find-default-throttle
- (remq 'unloaded semanticdb-find-default-throttle))
- (table (semanticdb-find-table-for-include tag (current-buffer)))
- (face nil)
- (map nil)
- )
- (cond
- ((and (not file) (not table))
- ;; Cannot find this header.
- (setq face 'semantic-decoration-on-unknown-includes
- map semantic-decoration-on-unknown-include-map)
- )
- ((and (not file) table)
- ;; There is no file, but the language supports a table for this
- ;; include. Import perhaps? System include with no file?
- (setq face 'semantic-decoration-on-fileless-includes
- map semantic-decoration-on-fileless-include-map)
- )
- ((and table (number-or-marker-p (oref table pointmax)))
- ;; A found and parsed file.
- (setq face 'semantic-decoration-on-includes
- map semantic-decoration-on-include-map)
- )
- (t
- ;; An unparsed file.
- (setq face 'semantic-decoration-on-unparsed-includes
- map semantic-decoration-on-unparsed-include-map)
- (when table
- ;; Set ourselves up for synchronization
- (semanticdb-cache-get
- table 'semantic-decoration-unparsed-include-cache)
- ;; Add a dependency.
- (let ((currenttable semanticdb-current-table))
- (semanticdb-add-reference currenttable tag))
- )
- ))
-
- ;; @TODO - if not a tag with a position, we need to get one. How?
-
- (when (semantic-tag-with-position-p tag)
- (let ((ol (semantic-decorate-tag tag
- (semantic-tag-start tag)
- (semantic-tag-end tag)
- face)))
- (overlay-put ol 'mouse-face 'highlight)
- (overlay-put ol 'keymap map)
- (overlay-put ol 'help-echo "Header File : mouse-3 - Context menu")))))
-
-;;; Regular Include Functions
-;;
-(defun semantic-decoration-include-describe ()
- "Describe the current include tag.
-Argument EVENT is the mouse clicked event."
- (interactive)
- (let* ((tag (or (semantic-current-tag)
- (error "No tag under point")))
- (file (semantic-dependency-tag-file tag))
- (table (when file
- (semanticdb-file-table-object file t))))
- (with-output-to-temp-buffer (help-buffer) ; "*Help*"
- (help-setup-xref (list #'semantic-decoration-include-describe)
- (called-interactively-p 'interactive))
- (princ "Include File: ")
- (princ (semantic-format-tag-name tag nil t))
- (princ "\n")
- (princ "This include file was found at:\n ")
- (princ (semantic-dependency-tag-file tag))
- (princ "\n\n")
- (princ "Semantic knows where this include file is, and has parsed
-its contents.
-
-")
- (let ((inc (semantic-find-tags-by-class 'include table))
- (ok 0)
- (unknown 0)
- (unparsed 0)
- (all 0))
- (dolist (i inc)
- (let* ((fileinner (semantic-dependency-tag-file i))
- )
- (cond ((not fileinner)
- (setq unknown (1+ unknown)))
- ((number-or-marker-p (oref table pointmax))
- (setq ok (1+ ok)))
- (t
- (setq unparsed (1+ unparsed))))))
- (setq all (+ ok unknown unparsed))
- (if (= 0 all)
- (princ "There are no other includes in this file.\n")
- (princ (format "There are %d more includes in this file.\n"
- all))
- (princ (format " Unknown Includes: %d\n" unknown))
- (princ (format " Unparsed Includes: %d\n" unparsed))
- (princ (format " Parsed Includes: %d\n" ok)))
- )
- ;; Get the semanticdb statement, and display it's contents.
- (princ "\nDetails for header file...\n")
- (princ "\nMajor Mode: ")
- (princ (oref table major-mode))
- (princ "\nTags: ")
- (princ (format "%s entries" (length (oref table tags))))
- (princ "\nFile Size: ")
- (princ (format "%s chars" (oref table pointmax)))
- (princ "\nSave State: ")
- (cond ((oref table dirty)
- (princ "Table needs to be saved."))
- (t
- (princ "Table is saved on disk."))
- )
- (princ "\nExternal References:")
- (dolist (r (oref table db-refs))
- (princ "\n ")
- (princ (oref r file)))
- )))
-
-;;;###autoload
-(defun semantic-decoration-include-visit ()
- "Visit the included file at point."
- (interactive)
- (let ((tag (semantic-current-tag)))
- (unless (eq (semantic-tag-class tag) 'include)
- (error "Point is not on an include tag"))
- (let ((file (semantic-dependency-tag-file tag)))
- (cond
- ((or (not file) (not (file-exists-p file)))
- (error "Could not location include %s"
- (semantic-tag-name tag)))
- ((get-file-buffer file)
- (pop-to-buffer-same-window (get-file-buffer file)))
- ((stringp file)
- (find-file file))
- ))))
-
-(defun semantic-decoration-include-menu (event)
- "Popup a menu that can help a user understand unparsed includes.
-Argument EVENT describes the event that caused this function to be called."
- (interactive "e")
- (let* ((startwin (selected-window))
- (win (semantic-event-window event))
- )
- (select-window win t)
- (save-excursion
- ;(goto-char (window-start win))
- (mouse-set-point event)
- (sit-for 0)
- (popup-menu semantic-decoration-on-include-menu)
- )
- (select-window startwin)))
-
-\f
-;;; Unknown Include functions
-;;
-(defun semantic-decoration-unknown-include-describe ()
- "Describe the current unknown include.
-Argument EVENT is the mouse clicked event."
- (interactive)
- (let ((tag (semantic-current-tag))
- (mm major-mode))
- (with-output-to-temp-buffer (help-buffer) ; "*Help*"
- (help-setup-xref (list #'semantic-decoration-unknown-include-describe)
- (called-interactively-p 'interactive))
- (princ "Include File: ")
- (princ (semantic-format-tag-name tag nil t))
- (princ "\n\n")
- (princ (substitute-command-keys "\
-This header file has been marked \"Unknown\".
-This means that Semantic has not been able to locate this file on disk.
-
-When Semantic cannot find an include file, this means that the
-idle summary mode and idle completion modes cannot use the contents of
-that file to provide coding assistance.
-
-If this is a system header and you want it excluded from Semantic's
-searches (which may be desirable for speed reasons) then you can
-safely ignore this state.
-
-If this is a system header, and you want to include it in Semantic's
-searches, then you will need to use:
-
-M-x semantic-add-system-include RET /path/to/includes RET
-
-or, in your .emacs file do:
-
- (semantic-add-system-include \"/path/to/include\" \\='"))
- (princ (symbol-name mm))
- (princ (substitute-command-keys ")
-
-to add the path to Semantic's search.
-
-If this is an include file that belongs to your project, then you may
-need to update `semanticdb-project-roots' or better yet, use `ede'
-to manage your project. See the ede manual for projects that will
-wrap existing project code for Semantic's benefit.
-"))
-
- (when (or (eq mm 'c++-mode) (eq mm 'c-mode))
- (princ "
-For C/C++ includes located within a project, you can use a special
-EDE project that will wrap an existing build system. You can do that
-like this in your .emacs file:
-
- (ede-cpp-root-project \"NAME\" :file \"FILENAME\" :locate-fcn \\='MYFCN)
-
-See the CEDET manual, the EDE manual, or the commentary in
-ede/cpp-root.el for more.
-
-If you think this header tag is marked in error, you may need to do:
-
-C-u M-x bovinate RET
-
-to refresh the tags in this buffer, and recalculate the state."))
-
- (princ "
-See the Semantic manual node on SemanticDB for more about search paths.")
- )))
-
-(defun semantic-decoration-unknown-include-menu (event)
- "Popup a menu that can help a user understand unknown includes.
-Argument EVENT describes the event that caused this function to be called."
- (interactive "e")
- (let* ((startwin (selected-window))
- (win (semantic-event-window event)))
- (select-window win t)
- (save-excursion
- ;(goto-char (window-start win))
- (mouse-set-point event)
- (sit-for 0)
- (popup-menu semantic-decoration-on-unknown-include-menu)
- )
- (select-window startwin)))
-
-\f
-;;; Fileless Include functions
-;;
-(defun semantic-decoration-fileless-include-describe ()
- "Describe the current fileless include.
-Argument EVENT is the mouse clicked event."
- (interactive)
- (let* ((tag (semantic-current-tag))
- (table (semanticdb-find-table-for-include tag (current-buffer)))
- ) ;; (mm major-mode)
- (with-output-to-temp-buffer (help-buffer) ; "*Help*"
- (help-setup-xref (list #'semantic-decoration-fileless-include-describe)
- (called-interactively-p 'interactive))
- (princ "Include Tag: ")
- (princ (semantic-format-tag-name tag nil t))
- (princ "\n\n")
- (princ "This header tag has been marked \"Fileless\".
-This means that Semantic cannot find a file associated with this tag
-on disk, but a database table of tags has been associated with it.
-
-This means that the include will still be used to find tags for
-searches, but you cannot visit this include.\n\n")
- (princ "This Header is now represented by the following database table:\n\n ")
- (princ (cl-prin1-to-string table))
- )))
-
-(defun semantic-decoration-fileless-include-menu (event)
- "Popup a menu that can help a user understand fileless includes.
-Argument EVENT describes the event that caused this function to be called."
- (interactive "e")
- (let* ((startwin (selected-window))
- (win (semantic-event-window event)))
- (select-window win t)
- (save-excursion
- ;(goto-char (window-start win))
- (mouse-set-point event)
- (sit-for 0)
- (popup-menu semantic-decoration-on-fileless-include-menu)
- )
- (select-window startwin)))
-
-\f
-;;; Interactive parts of unparsed includes
-;;
-(defun semantic-decoration-unparsed-include-describe ()
- "Describe what unparsed includes are in the current buffer.
-Argument EVENT is the mouse clicked event."
- (interactive)
- (let ((tag (semantic-current-tag)))
- (with-output-to-temp-buffer (help-buffer); "*Help*"
- (help-setup-xref (list #'semantic-decoration-unparsed-include-describe)
- (called-interactively-p 'interactive))
-
- (princ "Include File: ")
- (princ (semantic-format-tag-name tag nil t))
- (princ "\n")
- (princ "This include file was found at:\n ")
- (princ (semantic-dependency-tag-file tag))
- (princ "\n\n")
- (princ "This header file has been marked \"Unparsed\".
-This means that Semantic has located this header file on disk
-but has not yet opened and parsed this file.
-
-So long as this header file is unparsed, idle summary and
-idle completion will not be able to reference the details in this
-header.
-
-To resolve this, use the context menu to parse this include file,
-or all include files referred to in ")
- (princ (buffer-name))
- (princ ".
-This can take a while in large projects.
-
-Alternately, you can call:
-
-M-x semanticdb-find-test-translate-path RET
-
-to search path Semantic uses to perform completion.
-
-
-If you think this header tag is marked in error, you may need to do:
-
-C-u M-x bovinate RET
-
-to refresh the tags in this buffer, and recalculate the state.
-If you find a repeatable case where a header is marked in error,
-report it to cedet-devel@lists.sf.net.") )))
-
-
-(defun semantic-decoration-unparsed-include-menu (event)
- "Popup a menu that can help a user understand unparsed includes.
-Argument EVENT describes the event that caused this function to be called."
- (interactive "e")
- (let* ((startwin (selected-window))
- (win (semantic-event-window event))
- )
- (select-window win t)
- (save-excursion
- ;(goto-char (window-start win))
- (mouse-set-point event)
- (sit-for 0)
- (popup-menu semantic-decoration-on-unparsed-include-menu)
- )
- (select-window startwin)))
-
-(defun semantic-decoration-unparsed-include-parse-include ()
- "Parse the include file the user menu-selected from."
- (interactive)
- (let* ((file (semantic-dependency-tag-file (semantic-current-tag))))
- (semanticdb-file-table-object file)
- (semantic-decoration-unparsed-include-do-reset)))
-
-
-(defun semantic-decoration-unparsed-include-parse-all-includes ()
- "Parse the include file the user menu-selected from."
- (interactive)
- (semanticdb-find-translate-path nil nil)
- )
-
-\f
-;;; General Includes Information
-;;
-(defun semantic-decoration-all-include-summary ()
- "Provide a general summary for the state of all includes."
- (interactive)
- (require 'semantic/dep)
- (let* ((table semanticdb-current-table)
- (tags (semantic-fetch-tags))
- (inc (semantic-find-tags-by-class 'include table))
- )
- (with-output-to-temp-buffer (help-buffer) ;"*Help*"
- (help-setup-xref (list #'semantic-decoration-all-include-summary)
- (called-interactively-p 'interactive))
-
- (princ "Include Summary for File: ")
- (princ (file-truename (buffer-file-name)))
- (princ "\n")
-
- (when (oref table db-refs)
- (princ "\nExternal Database References to this buffer:")
- (dolist (r (oref table db-refs))
- (princ "\n ")
- (princ (oref r file)))
- )
-
- (princ (format "\nThis file contains %d tags, %d of which are includes.\n"
- (length tags) (length inc)))
- (let ((ok 0)
- (unknown 0)
- (unparsed 0)
- (all 0))
- (dolist (i inc)
- (let* ((fileinner (semantic-dependency-tag-file i))
- (tableinner (when fileinner
- (semanticdb-file-table-object fileinner t))))
- (cond ((not fileinner)
- (setq unknown (1+ unknown)))
- ((number-or-marker-p (oref tableinner pointmax))
- (setq ok (1+ ok)))
- (t
- (setq unparsed (1+ unparsed))))))
- (setq all (+ ok unknown unparsed))
- (when (not (= 0 all))
- (princ (format " Unknown Includes: %d\n" unknown))
- (princ (format " Unparsed Includes: %d\n" unparsed))
- (princ (format " Parsed Includes: %d\n" ok)))
- )
-
- (princ "\nInclude Path Summary:\n\n")
- (when (and (boundp 'ede-object)
- (boundp 'ede-object-project)
- ede-object)
- (princ (substitute-command-keys
- " This file's project include search is handled by the EDE object:\n"))
- (princ " Buffer Target: ")
- (princ (cl-prin1-to-string ede-object))
- (princ "\n")
- (when (not (eq ede-object ede-object-project))
- (princ " Buffer Project: ")
- (princ (cl-prin1-to-string ede-object-project))
- (princ "\n")
- )
- (when ede-object-project
- (let ((loc (ede-get-locator-object ede-object-project)))
- (princ " Backup in-project Locator: ")
- (princ (cl-prin1-to-string loc))
- (princ "\n")))
- (let ((syspath (ede-system-include-path ede-object-project)))
- (if (not syspath)
- (princ " EDE Project system include path: Empty\n")
- (princ " EDE Project system include path:\n")
- (dolist (dir syspath)
- (princ " ")
- (princ dir)
- (princ "\n"))
- )))
-
- (princ (substitute-command-keys
- "\n This file's system include path is:\n"))
- (dolist (dir semantic-dependency-system-include-path)
- (princ " ")
- (princ dir)
- (princ "\n"))
-
- (let ((unk semanticdb-find-lost-includes))
- (when unk
- (princ "\nAll unknown includes:\n")
- (dolist (tag unk)
- (princ " ")
- (princ (semantic-tag-name tag))
- (when (not (eq (semantic-tag-name tag) (semantic-tag-include-filename tag)))
- (princ " -> ")
- (princ (semantic-tag-include-filename tag)))
- (princ "\n"))
- ))
-
- (let* ((semanticdb-find-default-throttle
- (if (featurep 'semantic/db-find)
- (remq 'unloaded semanticdb-find-default-throttle)
- nil))
- (path (semanticdb-find-translate-path nil nil)))
- (if (<= (length path) (length inc))
- (princ "\nThere are currently no includes found recursively.\n")
- ;; List the full include list.
- (princ "\nSummary of all includes needed by ")
- (princ (buffer-name))
- (dolist (p path)
- (if (slot-boundp p 'tags)
- (princ (format "\n %s :\t%d tags, %d are includes. %s"
- (eieio-object-name-string p)
- (length (oref p tags))
- (length (semantic-find-tags-by-class
- 'include p))
- (cond
- ((condition-case nil
- (oref p dirty)
- (error nil))
- " dirty.")
- ((not (number-or-marker-p (oref table pointmax)))
- " Needs to be parsed.")
- (t ""))))
- (princ (format "\n %s :\tUnparsed"
- (eieio-object-name-string p))))
- )))
- )))
-
-\f
-;;; Unparsed Include Features
-;;
-;; This section handles changing states of unparsed include
-;; decorations base on what happens in other files.
-;;
-
-(defclass semantic-decoration-unparsed-include-cache (semanticdb-abstract-cache)
- ()
- "Class used to reset decorated includes.
-When an include's referring file is parsed, we need to undecorate
-any decorated referring includes.")
-
-
-(cl-defmethod semantic-reset ((obj semantic-decoration-unparsed-include-cache))
- "Reset OBJ back to it's empty settings."
- (let ((table (oref obj table)))
- ;; This is a hack. Add in something better?
- (semanticdb-notify-references
- table (lambda (tab _me)
- (semantic-decoration-unparsed-include-reference-reset tab)))))
-
-(cl-defmethod semanticdb-partial-synchronize ((cache semantic-decoration-unparsed-include-cache)
- new-tags)
- "Synchronize CACHE with some NEW-TAGS."
- (if (semantic-find-tags-by-class 'include new-tags)
- (semantic-reset cache)))
-
-(cl-defmethod semanticdb-synchronize ((cache semantic-decoration-unparsed-include-cache)
- _new-tags)
- "Synchronize a CACHE with some NEW-TAGS."
- (semantic-reset cache))
-
-(defun semantic-decoration-unparsed-include-reference-reset (table)
- "Refresh any highlighting in buffers referred to by TABLE.
-If TABLE is not in a buffer, do nothing."
- ;; This cache removal may seem odd in that we are "creating one", but
- ;; since we can't get in the fcn unless one exists, this ought to be
- ;; ok.
- (let ((c (semanticdb-cache-get
- table 'semantic-decoration-unparsed-include-cache)))
- (semanticdb-cache-remove table c))
-
- (let ((buf (semanticdb-in-buffer-p table)))
- (when buf
- (semantic-decorate-add-pending-decoration
- 'semantic-decoration-unparsed-include-do-reset
- buf)
- )))
-
-;;;###autoload
-(defun semantic-decoration-unparsed-include-do-reset ()
- "Do a reset of unparsed includes in the current buffer."
- (let* ((style (assoc "semantic-decoration-on-includes"
- semantic-decoration-styles)))
- (when (cdr style)
- (let ((allinc (semantic-find-tags-included
- (semantic-fetch-tags-fast))))
- ;; This will do everything, but it should be speedy since it
- ;; would have been done once already.
- (semantic-decorate-add-decorations allinc)
- ))))
-
-(define-obsolete-function-alias 'semantic-decoration-unparsed-include-refrence-reset
- #'semantic-decoration-unparsed-include-reference-reset "30.1")
-
-(provide 'semantic/decorate/include)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/decorate/include"
-;; End:
-
-;;; semantic/decorate/include.el ends here
+++ /dev/null
-;;; semantic/decorate/mode.el --- Minor mode for decorating tags -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000-2005, 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; A minor mode for use in decorating tags.
-;;
-;; There are two types of decorations that can be performed on a tag.
-;; You can either highlight the full tag, or you can add an
-;; independent decoration on some part of the tag body.
-;;
-;; For independent decoration in particular, managing them so that they
-;; do not get corrupted is challenging. This major mode and
-;; corresponding macros will make handling those types of decorations
-;; easier.
-;;
-
-;;; Code:
-(eval-when-compile (require 'cl-lib))
-(require 'semantic)
-(require 'semantic/decorate)
-(require 'semantic/tag-ls)
-(require 'semantic/util-modes)
-
-;;; Styles List
-;;
-(defcustom semantic-decoration-styles nil
- "List of active decoration styles.
-It is an alist of \(NAME . FLAG) elements, where NAME is a style name
-and FLAG is non-nil if the style is enabled.
-See also `define-semantic-decoration-style' which will automatically
-add items to this list."
- :group 'semantic
- :type '(repeat (cons (string :tag "Decoration Name")
- (boolean :tag "Enabled")))
- )
-
-;;; Misc.
-;;
-(defsubst semantic-decorate-style-predicate (style)
- "Return the STYLE's predicate function."
- (intern (format "%s-p" style)))
-
-(defsubst semantic-decorate-style-highlighter (style)
- "Return the STYLE's highlighter function."
- (intern (format "%s-highlight" style)))
-
-(defsubst semantic-decorate-style-predicate-default (style)
- "Return the STYLE's predicate function."
- (intern (format "%s-p-default" style)))
-
-(defsubst semantic-decorate-style-highlighter-default (style)
- "Return the STYLE's highlighter function."
- (intern (format "%s-highlight-default" style)))
-
-;;; Base decoration API
-;;
-(defsubst semantic-decoration-p (object)
- "Return non-nil if OBJECT is a tag decoration."
- (and (overlayp object)
- (overlay-get object 'semantic-decoration)))
-
-(defsubst semantic-decoration-set-property (deco property value)
- "Set the DECO decoration's PROPERTY to VALUE.
-Return DECO."
- (cl-assert (semantic-decoration-p deco))
- (overlay-put deco property value)
- deco)
-
-(defsubst semantic-decoration-get-property (deco property)
- "Return the DECO decoration's PROPERTY value."
- (cl-assert (semantic-decoration-p deco))
- (overlay-get deco property))
-
-(defsubst semantic-decoration-set-face (deco face)
- "Set the face of the decoration DECO to FACE.
-Return DECO."
- (semantic-decoration-set-property deco 'face face))
-
-(defsubst semantic-decoration-face (deco)
- "Return the face of the decoration DECO."
- (semantic-decoration-get-property deco 'face))
-
-(defsubst semantic-decoration-set-priority (deco priority)
- "Set the priority of the decoration DECO to PRIORITY.
-Return DECO."
- (cl-assert (natnump priority))
- (semantic-decoration-set-property deco 'priority priority))
-
-(defsubst semantic-decoration-priority (deco)
- "Return the priority of the decoration DECO."
- (semantic-decoration-get-property deco 'priority))
-
-(defsubst semantic-decoration-move (deco begin end)
- "Move the decoration DECO on the region between BEGIN and END.
-Return DECO."
- (cl-assert (semantic-decoration-p deco))
- (move-overlay deco begin end)
- deco)
-\f
-;;; Tag decoration
-;;
-(defun semantic-decorate-tag (tag begin end &optional face)
- "Add a new decoration on TAG on the region between BEGIN and END.
-If optional argument FACE is non-nil, set the decoration's face to
-FACE.
-Return the overlay that makes up the new decoration."
- (let ((deco (semantic-tag-create-secondary-overlay tag)))
- ;; We do not use the unlink property because we do not want to
- ;; save the highlighting information in the DB.
- (overlay-put deco 'semantic-decoration t)
- (semantic-decoration-move deco begin end)
- (semantic-decoration-set-face deco face)
- deco))
-
-(defun semantic-decorate-clear-tag (tag &optional deco)
- "Remove decorations from TAG.
-If optional argument DECO is non-nil, remove only that decoration."
- (cl-assert (or (null deco) (semantic-decoration-p deco)))
- ;; Clear primary decorations.
- ;; For now, just unhighlight the tag. How to deal with other
- ;; primary decorations like invisibility, etc. ? Maybe just
- ;; restoring default values will suffice?
- (semantic-unhighlight-tag tag)
- (semantic-tag-delete-secondary-overlay
- tag (or deco 'semantic-decoration)))
-
-(defun semantic-decorate-tag-decoration (tag)
- "Return decoration found on TAG."
- (semantic-tag-get-secondary-overlay tag 'semantic-decoration))
-\f
-;;; Global setup of active decorations
-;;
-(defun semantic-decorate-flush-decorations (&optional buffer)
- "Flush decorations found in BUFFER.
-BUFFER defaults to the current buffer.
-Should be used to flush decorations that might remain in BUFFER, for
-example, after tags have been refreshed."
- (with-current-buffer (or buffer (current-buffer))
- (dolist (o (overlays-in (point-min) (point-max)))
- (and (semantic-decoration-p o)
- (delete-overlay o)))))
-
-(defun semantic-decorate-clear-decorations (tag-list)
- "Remove decorations found in tags in TAG-LIST."
- (dolist (tag tag-list)
- (semantic-decorate-clear-tag tag)
- ;; recurse over children
- (semantic-decorate-clear-decorations
- (semantic-tag-components-with-overlays tag))))
-
-(defun semantic-decorate-add-decorations (tag-list)
- "Add decorations to tags in TAG-LIST.
-Also make sure old decorations in the area are completely flushed."
- (dolist (tag tag-list)
- ;; Cleanup old decorations.
- (when (semantic-decorate-tag-decoration tag)
- ;; Note on below comment. This happens more as decorations are refreshed
- ;; mid-way through their use. Remove the message.
-
- ;; It would be nice if this never happened, but it still does
- ;; once in a while. Print a message to help flush these
- ;; situations
- ;;(message "Decorations still on %s" (semantic-format-tag-name tag))
- (semantic-decorate-clear-tag tag))
- ;; Add new decorations.
- (dolist (style semantic-decoration-styles)
- (let ((pred (semantic-decorate-style-predicate (car style)))
- (high (semantic-decorate-style-highlighter (car style))))
- (and (cdr style)
- (fboundp pred)
- (funcall pred tag)
- (fboundp high)
- (funcall high tag))))
- ;; Recurse on the children of all tags
- (semantic-decorate-add-decorations
- (semantic-tag-components-with-overlays tag))))
-\f
-;;; PENDING DECORATIONS
-;;
-;; Activities in Emacs may cause a decoration to change state. Any
-;; such identified change ought to be setup as PENDING. This means
-;; that the next idle step will do the decoration change, but at the
-;; time of the state change, minimal work would be done.
-(defvar semantic-decorate-pending-decoration-hook nil
- "Normal hook run to perform pending decoration changes.")
-
-(defun semantic-decorate-add-pending-decoration (fcn &optional buffer)
- "Add a pending decoration change represented by FCN.
-Applies only to the current BUFFER.
-The setting of FCN will be removed after it is run."
- (save-excursion
- (when buffer (set-buffer buffer))
- (add-hook 'semantic-decorate-pending-decoration-hook fcn nil t)))
-
-(defun semantic-decorate-flush-pending-decorations (&optional buffer)
- "Flush any pending decorations for BUFFER.
-Flush functions from `semantic-decorate-pending-decoration-hook'."
- (save-excursion
- (when buffer (set-buffer buffer))
- (run-hooks 'semantic-decorate-pending-decoration-hook)
- ;; Always reset the hooks
- (setq semantic-decorate-pending-decoration-hook nil)))
-
-\f
-;;; DECORATION MODE
-;;
-;; Generic mode for handling basic highlighting and decorations.
-;;
-
-;;;###autoload
-(define-minor-mode global-semantic-decoration-mode
- "Toggle global use of option `semantic-decoration-mode'.
-Decoration mode turns on all active decorations as specified
-by `semantic-decoration-styles'."
- :global t :group 'semantic :group 'semantic-modes
- ;; Not needed because it's autoloaded instead.
- ;; :require 'semantic/decorate/mode
- (semantic-toggle-minor-mode-globally
- 'semantic-decoration-mode (if global-semantic-decoration-mode 1 -1)))
-
-(defcustom semantic-decoration-mode-hook nil
- "Hook run at the end of function `semantic-decoration-mode'."
- :group 'semantic
- :type 'hook)
-
-(define-minor-mode semantic-decoration-mode
- "Minor mode for decorating tags.
-Decorations are specified in `semantic-decoration-styles'. You
-can define new decoration styles with
-`define-semantic-decoration-style'.
-
-The minor mode can be turned on only if semantic feature is
-available and the current buffer was set up for parsing. Return
-non-nil if the minor mode is enabled."
-;;
-;;\\{semantic-decoration-map}"
- :lighter nil
- (if semantic-decoration-mode
- (if (not (and (featurep 'semantic) (semantic-active-p)))
- (progn
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-decoration-mode nil)
- (error "Buffer %s was not set up for parsing"
- (buffer-name)))
- ;; Add hooks
- (add-hook 'semantic-after-partial-cache-change-hook
- #'semantic-decorate-tags-after-partial-reparse nil t)
- (add-hook 'semantic-after-toplevel-cache-change-hook
- #'semantic-decorate-tags-after-full-reparse nil t)
- ;; Add decorations to available tags. The above hooks ensure
- ;; that new tags will be decorated when they become available.
- ;; However, don't do this immediately, because EDE will be
- ;; activated later by find-file-hook, and includes might not
- ;; be found yet.
- (run-with-idle-timer
- 0.1 nil
- (lambda ()
- (semantic-decorate-add-decorations (semantic-fetch-available-tags)))))
- ;; Remove decorations from available tags.
- (semantic-decorate-clear-decorations (semantic-fetch-available-tags))
- ;; Cleanup any leftover crap too.
- (semantic-decorate-flush-decorations)
- ;; Remove hooks
- (remove-hook 'semantic-after-partial-cache-change-hook
- #'semantic-decorate-tags-after-partial-reparse t)
- (remove-hook 'semantic-after-toplevel-cache-change-hook
- #'semantic-decorate-tags-after-full-reparse t)))
-
-(semantic-add-minor-mode 'semantic-decoration-mode
- "")
-
-(defun semantic-decorate-tags-after-full-reparse (tag-list)
- "Add decorations after a complete reparse of the current buffer.
-TAG-LIST is the list of tags recently parsed.
-Flush all existing decorations and call `semantic-decorate-add-decorations' to
-add decorations.
-Called from `semantic-after-toplevel-cache-change-hook'."
- ;; Flush everything
- (semantic-decorate-flush-decorations)
- ;; Add it back on
- (semantic-decorate-add-decorations tag-list))
-
-(defun semantic-decorate-tags-after-partial-reparse (tag-list)
- "Add decorations when new tags are created in the current buffer.
-TAG-LIST is the list of newly created tags.
-Call `semantic-decorate-add-decorations' to add decorations.
-Called from `semantic-after-partial-cache-change-hook'."
- (semantic-decorate-add-decorations tag-list))
-
-\f
-;;; Enable/Disable toggling
-;;
-(defun semantic-decoration-style-enabled-p (style)
- "Return non-nil if STYLE is currently enabled.
-Return nil if the style is disabled, or does not exist."
- (let ((pair (assoc style semantic-decoration-styles)))
- (and pair (cdr pair))))
-
-(defun semantic-toggle-decoration-style (name &optional arg)
- "Turn on/off the decoration style with NAME.
-Decorations are specified in `semantic-decoration-styles'.
-With prefix argument ARG, turn on if positive, otherwise off.
-Return non-nil if the decoration style is enabled."
- (interactive
- (list (completing-read "Decoration style: "
- semantic-decoration-styles nil t)
- current-prefix-arg))
- (setq name (format "%s" name)) ;; Ensure NAME is a string.
- (unless (equal name "")
- (let* ((style (assoc name semantic-decoration-styles))
- (flag (if arg
- (> (prefix-numeric-value arg) 0)
- (not (cdr style)))))
- (when (null style)
- (error "Unknown decoration style %s" name))
- (unless (eq (cdr style) flag)
- ;; Store the new flag.
- (setcdr style flag)
- ;; Refresh decorations is `semantic-decoration-mode' is on.
- (when semantic-decoration-mode
- (semantic-decoration-mode -1)
- (semantic-decoration-mode 1))
- (when (called-interactively-p 'interactive)
- (message "Decoration style %s turned %s" (car style)
- (if flag "on" "off"))))
- flag)))
-
-(defvar semantic-decoration-menu-cache nil
- "Cache of the decoration menu.")
-
-(defun semantic-decoration-build-style-menu (style)
- "Build a menu item for controlling a specific decoration STYLE."
- (let ((s (car style)))
- (vector s
- (lambda () (interactive) (semantic-toggle-decoration-style s))
- :style 'toggle
- :selected `(semantic-decoration-style-enabled-p ',s))))
-
-(defun semantic-build-decoration-mode-menu (&rest _ignore)
- "Create a menu listing all the known decorations for toggling.
-IGNORE any input arguments."
- (or semantic-decoration-menu-cache
- (setq semantic-decoration-menu-cache
- (mapcar #'semantic-decoration-build-style-menu
- (reverse semantic-decoration-styles))
- )))
-
-\f
-;;; Defining decoration styles
-;;
-(defmacro define-semantic-decoration-style (name doc &rest flags)
- "Define a new decoration style with NAME.
-DOC is a documentation string describing the decoration style NAME.
-It is appended to auto-generated doc strings.
-An optional list of FLAGS can also be specified. Flags are:
- :enabled <value> - specify the default enabled value for NAME.
- :load <value> - specify a feature (as a string) with the rest of
- the definition for decoration mode NAME.
-
-This defines two new overload functions respectively called `NAME-p'
-and `NAME-highlight', for which you must provide a default
-implementation in respectively the functions `NAME-p-default' and
-`NAME-highlight-default'. Those functions are passed a tag. `NAME-p'
-must return non-nil to indicate that the tag should be decorated by
-`NAME-highlight'.
-
-To put primary decorations on a tag `NAME-highlight' must use
-functions like `semantic-set-tag-face', `semantic-set-tag-read-only',
-etc., found in the semantic-decorate library.
-
-To add other kind of decorations on a tag, `NAME-highlight' must use
-`semantic-decorate-tag', and other functions of the semantic
-decoration API found in this library."
- (declare (indent 1))
- (let ((predicate (semantic-decorate-style-predicate name))
- (highlighter (semantic-decorate-style-highlighter name))
- (predicatedef (semantic-decorate-style-predicate-default name))
- (highlighterdef (semantic-decorate-style-highlighter-default name))
- (defaultenable (if (plist-member flags :enabled)
- (plist-get flags :enabled)
- t))
- (loadfile (if (plist-member flags :load)
- (plist-get flags :load)
- nil))
- )
- `(progn
- ;; Clear the menu cache so that new items are added when
- ;; needed.
- (setq semantic-decoration-menu-cache nil)
- ;; Create an override method to specify if a given tag belongs
- ;; to this type of decoration
- (define-overloadable-function ,predicate (tag)
- ,(concat
- (internal--format-docstring-line
- "Return non-nil to decorate TAG with `%s' style."
- name)
- "\n" doc))
- ;; Create an override method that will perform the highlight
- ;; operation if the -p method returns non-nil.
- (define-overloadable-function ,highlighter (tag)
- ,(format "Decorate TAG with `%s' style.\n%s"
- name doc))
- ;; Add this to the list of primary decoration modes.
- (add-to-list 'semantic-decoration-styles
- (cons ',(symbol-name name)
- ,defaultenable))
- ;; If there is a load file, then create the autoload tokens for
- ;; those functions to load the token, but only if the fsym
- ;; doesn't exist yet.
- (when (stringp ,loadfile)
- (unless (fboundp ',predicatedef)
- (autoload ',predicatedef ',loadfile "Return non-nil to decorate TAG."
- ))
-
- (unless (fboundp ',highlighterdef)
- (autoload ',highlighterdef ',loadfile "Decorate TAG."))
- ))
- ))
-\f
-;;; Predefined decoration styles
-;;
-
-;;; Tag boundaries highlighting
-;;
-(define-semantic-decoration-style semantic-tag-boundary
- "Place an overline in front of each long tag.
-Does not provide overlines for prototypes.")
-
-(defface semantic-tag-boundary-face
- '((((class color) (background dark))
- (:overline "cyan"))
- (((class color) (background light))
- (:overline "blue")))
- "Face used to show long tags in.
-Used by decoration style: `semantic-tag-boundary'."
- :group 'semantic-faces)
-
-(defun semantic-tag-boundary-p-default (tag)
- "Return non-nil if TAG is a type, or a non-prototype function."
- (let ((c (semantic-tag-class tag)))
- (and
- (or
- ;; All types get a line?
- (eq c 'type)
- ;; Functions which aren't prototypes get a line.
- (and (eq c 'function)
- (not (semantic-tag-get-attribute tag :prototype-flag)))
- )
- ;; Note: The below restriction confused users.
- ;;
- ;; Nothing smaller than a few lines
- ;;(> (- (semantic-tag-end tag) (semantic-tag-start tag)) 150)
- ;; Random truth
- t)
- ))
-
-(defun semantic-tag-boundary-highlight-default (tag)
- "Highlight the first line of TAG as a boundary."
- (when (bufferp (semantic-tag-buffer tag))
- (with-current-buffer (semantic-tag-buffer tag)
- (semantic-decorate-tag
- tag
- (semantic-tag-start tag)
- (save-excursion
- (goto-char (semantic-tag-start tag))
- (end-of-line)
- (forward-char 1)
- (point))
- 'semantic-tag-boundary-face))
- ))
-
-;;; Private member highlighting
-;;
-(define-semantic-decoration-style semantic-decoration-on-private-members
- "Highlight class members that are designated as PRIVATE access."
- :enabled nil)
-
-(defface semantic-decoration-on-private-members-face
- '((((class color) (background dark))
- (:background "#200000"))
- (((class color) (background light))
- (:background "#8fffff")))
- "Face used to show privately scoped tags in.
-Used by the decoration style: `semantic-decoration-on-private-members'."
- :group 'semantic-faces)
-
-(defun semantic-decoration-on-private-members-highlight-default (tag)
- "Highlight TAG as designated to have PRIVATE access.
-Use a primary decoration."
- (semantic-set-tag-face
- tag 'semantic-decoration-on-private-members-face))
-
-(defun semantic-decoration-on-private-members-p-default (tag)
- "Return non-nil if TAG has PRIVATE access."
- (and (member (semantic-tag-class tag) '(function variable))
- (eq (semantic-tag-protection tag) 'private)))
-
-;;; Protected member highlighting
-;;
-(defface semantic-decoration-on-protected-members-face
- '((((class color) (background dark))
- (:background "#000020"))
- (((class color) (background light))
- (:background "#fffff8")))
- "Face used to show protected scoped tags in.
-Used by the decoration style: `semantic-decoration-on-protected-members'."
- :group 'semantic-faces)
-
-(define-semantic-decoration-style semantic-decoration-on-protected-members
- "Highlight class members that are designated as PROTECTED access."
- :enabled nil)
-
-(defun semantic-decoration-on-protected-members-p-default (tag)
- "Return non-nil if TAG has PROTECTED access."
- (and (member (semantic-tag-class tag) '(function variable))
- (eq (semantic-tag-protection tag) 'protected)))
-
-(defun semantic-decoration-on-protected-members-highlight-default (tag)
- "Highlight TAG as designated to have PROTECTED access.
-Use a primary decoration."
- (semantic-set-tag-face
- tag 'semantic-decoration-on-protected-members-face))
-
-;;; Decoration Modes in other files
-;;
-(declare-function semantic-decoration-on-includes-p-default
- "semantic/decorate/include")
-(declare-function semantic-decoration-on-includes-highlight-default
- "semantic/decorate/include")
-(define-semantic-decoration-style semantic-decoration-on-includes
- "Highlight class members that are includes.
-This mode provides a nice context menu on the include statements."
- :enabled t
- :load "semantic/decorate/include")
-
-
-
-(provide 'semantic/decorate/mode)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/decorate/mode"
-;; End:
-
-;;; semantic/decorate/mode.el ends here
+++ /dev/null
-;;; semantic/dep.el --- Methods for tracking dependencies (include files) -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2006-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Include tags (dependencies for a given source file) usually have
-;; some short name. The target file that it is dependent on is
-;; generally found on some sort of path controlled by the compiler or
-;; project.
-;;
-;; EDE or even ECB can control our project dependencies, and help us
-;; find file within the setting of a given project. For system
-;; dependencies, we need to depend on user supplied lists, which can
-;; manifest themselves in the form of system databases (from
-;; semanticdb.)
-;;
-;; Provide ways to track these different files here.
-
-(require 'semantic/tag)
-
-;;; Code:
-
-(defvar-local semantic-dependency-include-path nil
- "Defines the include path used when searching for files.
-This should be a list of directories to search which is specific
-to the file being included.
-
-If `semantic-dependency-tag-file' is overridden for a given
-language, this path is most likely ignored.
-
-The above function, regardless of being overridden, caches the
-located dependency file location in the tag property
-`dependency-file'. If you override this function, you do not
-need to implement your own cache. Each time the buffer is fully
-reparsed, the cache will be reset.
-
-TODO: use ffap.el to locate such items?
-
-NOTE: Obsolete this, or use as special user")
-
-(defvar-local semantic-dependency-system-include-path nil
- "Defines the system include path.
-This should be set with either `defvar-mode-local', or with
-`semantic-add-system-include'.
-
-For mode authors, use
-`defcustom-mode-local-semantic-dependency-system-include-path'
-to create a mode-specific variable to control this.
-
-When searching for a file associated with a name found in a tag of
-class include, this path will be inspected for includes of type
-`system'. Some include tags are agnostic to this setting and will
-check both the project and system directories.")
-
-(defmacro defcustom-mode-local-semantic-dependency-system-include-path
- (mode name value &optional docstring)
- "Create a mode-local value of the system-dependency include path.
-MODE is the `major-mode' this name/value pairs is for.
-NAME is the name of the customizable value users will use.
-VALUE is the path (a list of strings) to add.
-DOCSTRING is a documentation string applied to the variable NAME
-users will customize.
-
-Creates a customizable variable users can customize that will
-keep semantic data structures up to date."
- (declare (indent defun))
- `(progn
- ;; Create a variable users can customize.
- (defcustom ,name ,value
- ,docstring
- :group (quote ,(intern (car (split-string (symbol-name mode) "-"))))
- :group 'semantic
- :type '(repeat (directory :tag "Directory"))
- :set (lambda (sym val)
- (set-default sym val)
- (setq-mode-local ,mode
- semantic-dependency-system-include-path
- val)
- (when (fboundp
- 'semantic-decoration-unparsed-include-do-reset)
- (mode-local-map-mode-buffers
- 'semantic-decoration-unparsed-include-do-reset
- (quote ,mode))))
- )
- ;; Set the variable to the default value.
- (defvar-mode-local ,mode semantic-dependency-system-include-path
- ,name
- "System path to search for include files.")
- ;; Bind NAME onto our variable so tools can customize it
- ;; without knowing about it.
- (put 'semantic-dependency-system-include-path
- (quote ,mode) (quote ,name))
- ))
-
-;;; PATH MANAGEMENT
-;;
-;; Some fcns to manage paths for a give mode.
-;;;###autoload
-(defun semantic-add-system-include (dir &optional mode)
- "Add a system include DIR to path for MODE.
-Modifies a mode-local version of `semantic-dependency-system-include-path'.
-
-Changes made by this function are not persistent."
- (interactive "DNew Include Directory: ")
- (if (not mode) (setq mode major-mode))
- (let ((dirtmp (file-name-as-directory dir))
- (value
- (mode-local-value mode 'semantic-dependency-system-include-path)))
- (eval `(setq-mode-local ,mode
- semantic-dependency-system-include-path
- ',(if (member dirtmp value) value
- (append value (list dirtmp))))
- t)))
-
-;;;###autoload
-(defun semantic-remove-system-include (dir &optional mode)
- "Add a system include DIR to path for MODE.
-Modifies a mode-local version of `semantic-dependency-system-include-path'.
-
-Changes made by this function are not persistent."
- (interactive (list
- (completing-read
- "Include Directory to Remove: "
- semantic-dependency-system-include-path))
- )
- (if (not mode) (setq mode major-mode))
- (let ((dirtmp (file-name-as-directory dir))
- (value
- (mode-local-value mode 'semantic-dependency-system-include-path))
- )
- (setq value (remove dirtmp value))
- (eval `(setq-mode-local ,mode semantic-dependency-system-include-path
- ',value)
- t)))
-
-;;;###autoload
-(defun semantic-reset-system-include (&optional mode)
- "Reset the system include list to empty for MODE.
-Modifies a mode-local version of
-`semantic-dependency-system-include-path'."
- (interactive)
- (eval `(setq-mode-local ,(or mode major-mode)
- semantic-dependency-system-include-path
- nil)
- t))
-
-;;;###autoload
-(defun semantic-customize-system-include-path (&optional mode)
- "Customize the include path for this `major-mode'.
-To create a customizable include path for a major MODE, use the
-macro `defcustom-mode-local-semantic-dependency-system-include-path'."
- (interactive)
- (let ((ips (get 'semantic-dependency-system-include-path
- (or mode major-mode))))
- ;; Do we have one?
- (when (not ips)
- (error "There is no customizable includepath variable for %s"
- (or mode major-mode)))
- ;; Customize it.
- (customize-variable ips)))
-
-;;; PATH SEARCH
-;;
-;; methods for finding files on a provided path.
-(defmacro semantic--dependency-find-file-on-path (file path)
- (declare (obsolete locate-file "28.1"))
- `(locate-file ,file ,path))
-
-(defvar ede-minor-mode)
-(defvar ede-object)
-(declare-function ede-system-include-path "ede")
-
-(defun semantic-dependency-find-file-on-path (file systemp &optional mode)
- "Return an expanded file name for FILE on available paths.
-If SYSTEMP is true, then only search system paths.
-If optional argument MODE is non-nil, then derive paths from the
-provided mode, not from the current major mode."
- (if (not mode) (setq mode major-mode))
- (let ((sysp (mode-local-value
- mode 'semantic-dependency-system-include-path))
- (edesys (when (and (featurep 'ede) ede-minor-mode
- ede-object)
- (ede-system-include-path
- (if (listp ede-object) (car ede-object) ede-object))))
- (locp (mode-local-value
- mode 'semantic-dependency-include-path))
- (found nil))
- (when (file-exists-p file)
- (setq found file))
- (when (and (not found) (not systemp))
- (setq found (locate-file file locp)))
- (when (and (not found) edesys)
- (setq found (locate-file file edesys)))
- (when (not found)
- (setq found (locate-file file sysp)))
- (if found (expand-file-name found))))
-
-
-(provide 'semantic/dep)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/dep"
-;; End:
-
-;;; semantic/dep.el ends here
+++ /dev/null
-;;; semantic/doc.el --- Routines for documentation strings -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2003, 2005, 2008-2024 Free Software Foundation,
-;; Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; It is good practice to write documentation for your functions and
-;; variables. These core routines deal with these documentation
-;; comments or strings. They can exist either as a tag property
-;; (:documentation) or as a comment just before the symbol, or after
-;; the symbol on the same line.
-
-(require 'semantic/tag)
-
-;;; Code:
-
-;;;###autoload
-(define-overloadable-function semantic-documentation-for-tag (&optional tag nosnarf)
- "Find documentation from TAG and return it as a clean string.
-TAG might have DOCUMENTATION set in it already. If not, there may be
-some documentation in a comment preceding TAG's definition which we
-can look for. When appropriate, this can be overridden by a language specific
-enhancement.
-Optional argument NOSNARF means return only the lexical analyzer token for it.
-If NOSNARF is `lex', then only return the lex token."
- (if (not tag) (setq tag (semantic-current-tag)))
- (save-excursion
- (when (semantic-tag-with-position-p tag)
- (set-buffer (semantic-tag-buffer tag)))
- (:override
- ;; No override. Try something simple to find documentation nearby
- (save-excursion
- (semantic-go-to-tag tag)
- (let ((doctmp (semantic-tag-docstring tag (current-buffer))))
- (or
- ;; Is there doc in the tag???
- doctmp
- ;; Check just before the definition.
- (when (semantic-tag-with-position-p tag)
- (semantic-documentation-comment-preceding-tag tag nosnarf))
- ;; Let's look for comments either after the definition, but before code:
- ;; Not sure yet. Fill in something clever later....
- nil))))))
-
-(defun semantic-documentation-comment-preceding-tag (&optional tag nosnarf)
- "Find a comment preceding TAG.
-If TAG is nil. use the tag under point.
-Searches the space between TAG and the preceding tag for a comment,
-and converts the comment into clean documentation.
-Optional argument NOSNARF with a value of `lex' means to return
-just the lexical token and not the string."
- (if (not tag) (setq tag (semantic-current-tag)))
- (save-excursion
- ;; Find this tag.
- (semantic-go-to-tag tag)
- (let* ((starttag (semantic-find-tag-by-overlay-prev
- (semantic-tag-start tag)))
- (start (if starttag
- (semantic-tag-end starttag)
- (point-min))))
- (when (and comment-start-skip
- (re-search-backward comment-start-skip start t))
- ;; We found a comment that doesn't belong to the body
- ;; of a function.
- (semantic-doc-snarf-comment-for-tag nosnarf)))
- ))
-(define-obsolete-function-alias
- 'semantic-documentation-comment-preceeding-tag
- #'semantic-documentation-comment-preceding-tag
- "25.1")
-
-(defun semantic-doc-snarf-comment-for-tag (nosnarf)
- "Snarf up the comment at POINT for `semantic-documentation-for-tag'.
-Attempt to strip out comment syntactic sugar.
-Argument NOSNARF means don't modify the found text.
-If NOSNARF is `lex', then return the lex token."
- (let* ((semantic-lex-analyzer #'semantic-comment-lexer))
- (if (memq nosnarf '(lex flex)) ;; keep `flex' for compatibility
- (car (semantic-lex (point) (1+ (point))))
- (let ((ct (semantic-lex-token-text
- (car (semantic-lex (point) (1+ (point)))))))
- (if nosnarf
- nil
- ;; ok, try to clean the text up.
- ;; Comment start thingy
- (while (string-match (concat "^\\s-*\\(?:" comment-start-skip "\\)")
- ct)
- (setq ct (concat (substring ct 0 (match-beginning 0))
- (substring ct (match-end 0)))))
- ;; Arbitrary punctuation at the beginning of each line.
- (while (string-match "^\\s-*\\s.+\\s-*" ct)
- (setq ct (concat (substring ct 0 (match-beginning 0))
- (substring ct (match-end 0)))))
- ;; End of a block comment.
- (if (and (boundp 'block-comment-end)
- block-comment-end
- (string-match block-comment-end ct))
- (setq ct (concat (substring ct 0 (match-beginning 0))
- (substring ct (match-end 0)))))
- ;; In case it's a real string, STRIPIT.
- (while (string-match "\\s-*\\s\"+\\s-*" ct)
- (setq ct (concat (substring ct 0 (match-beginning 0))
- (substring ct (match-end 0)))))
- ;; Remove comment delimiter at the end of the string.
- (when (and comment-end (not (string= comment-end ""))
- (string-match (concat (regexp-quote comment-end) "$") ct))
- (setq ct (substring ct 0 (match-beginning 0)))))
- ;; Now return the text.
- ct))))
-
-(provide 'semantic/doc)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/doc"
-;; End:
-
-;;; semantic/doc.el ends here
+++ /dev/null
-;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2003-2004, 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: project, make
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Handle .by or .wy files.
-
-(require 'semantic)
-(require 'ede/proj)
-(require 'ede/pmake)
-(require 'ede/pconf)
-(require 'ede/proj-elisp)
-(require 'semantic/grammar)
-(eval-when-compile (require 'cl-lib))
-
-;;; Code:
-(defclass semantic-ede-proj-target-grammar (ede-proj-target-elisp)
- ((menu :initform nil)
- (keybindings :initform nil)
- (phony :initform t)
- (sourcetype :initform
- '(semantic-ede-source-grammar-wisent
- semantic-ede-source-grammar-bovine
- ))
- (availablecompilers :initform
- '(semantic-ede-grammar-compiler-wisent
- semantic-ede-grammar-compiler-bovine
- ))
- (aux-packages :initform '("semantic" "cedet-compat"))
- (pre-load-packages :initform '("cedet-compat" "semantic/grammar" "semantic/bovine/grammar" "semantic/wisent/grammar"))
- )
- "This target consists of a group of grammar files.
-A grammar target consists of grammar files that build Emacs Lisp programs for
-parsing different languages.")
-
-(cl-defmethod ede-proj-makefile-dependencies ((this semantic-ede-proj-target-grammar))
- "Return a string representing the dependencies for THIS.
-Some compilers only use the first element in the dependencies, others
-have a list of intermediates (object files), and others don't care.
-This allows customization of how these elements appear.
-For Emacs Lisp, return addsuffix command on source files."
- (let ((source (car (oref this source))))
- (cond
- ((string-match "\\.wy$" source)
- (format "$(addsuffix -wy.elc, $(basename $(%s)))"
- (ede-proj-makefile-sourcevar this)))
- ((string-match "\\.by$" source)
- (format "$(addsuffix -by.elc, $(basename $(%s)))"
- (ede-proj-makefile-sourcevar this))))))
-
-(defvar semantic-ede-source-grammar-wisent
- (ede-sourcecode :name "Wisent Grammar"
- :sourcepattern "\\.wy$"
- :garbagepattern '("*-wy.el")
- )
- "Semantic Grammar source code definition for wisent.")
-
-(defclass semantic-ede-grammar-compiler-class (ede-compiler)
- nil
- "Specialized compiler for semantic grammars.")
-
-(defvar semantic-ede-grammar-compiler-wisent
- (semantic-ede-grammar-compiler-class
- :name "emacs"
- :variables '(("EMACS" . "emacs")
- ("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'")
- ("require" . "$(foreach r,$(1),(require (quote $(r))))"))
- :rules (list (ede-makefile-rule
- :target "%-wy.el"
- :dependencies "%.wy"
- :rules '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \
---eval '(progn $(call require,$(PRELOADS)))' -f semantic-grammar-batch-build-packages $^")))
- :sourcetype '(semantic-ede-source-grammar-wisent)
- :objectextention "-wy.el"
- )
- "Compile Emacs Lisp programs.")
-
-
-(defvar semantic-ede-source-grammar-bovine
- (ede-sourcecode :name "Bovine Grammar"
- :sourcepattern "\\.by$"
- :garbagepattern '("*-by.el")
- )
- "Semantic Grammar source code definition for the bovinator.")
-
-(defvar semantic-ede-grammar-compiler-bovine
- (semantic-ede-grammar-compiler-class
- :name "emacs"
- :variables '(("EMACS" . "emacs")
- ("EMACSFLAGS" . "-batch --no-site-file --eval '(setq debug-on-error t)'")
- ("require" . "$(foreach r,$(1),(require (quote $(r))))"))
- :rules (list (ede-makefile-rule
- :target "%-by.el"
- :dependencies "%.by"
- :rules '("$(EMACS) $(EMACSFLAGS) $(addprefix -L ,$(LOADPATH)) \
---eval '(progn $(call require,$(PRELOADS)))' -f semantic-grammar-batch-build-packages $^")))
- :sourcetype '(semantic-ede-source-grammar-bovine)
- :objectextention "-by.el"
- )
- "Compile Emacs Lisp programs.")
-
-;;; Target options.
-(cl-defmethod ede-buffer-mine ((_this semantic-ede-proj-target-grammar) buffer)
- "Return t if object THIS lays claim to the file in BUFFER.
-Lays claim to all -by.el, and -wy.el files."
- ;; We need to be a little more careful than this, but at the moment it
- ;; is common to have only one target of this class per directory.
- (if (string-match "-[bw]y\\.elc?$" (buffer-file-name buffer))
- t
- (cl-call-next-method) ; The usual thing.
- ))
-
-(cl-defmethod project-compile-target ((obj semantic-ede-proj-target-grammar))
- "Compile all sources in a Lisp target OBJ."
- (let* (;; (cb (current-buffer))
- (proj (ede-target-parent obj))
- (default-directory (oref proj directory))
- (comp 0)
- (utd 0))
- (mapc (lambda (src)
- (with-current-buffer (find-file-noselect src)
- (let* ((package (semantic-grammar-create-package))
- (fname (progn (string-match ".*/\\(.+\\.el\\)" package)
- (match-string 1 package)))
- (src (ede-expand-filename obj fname))
- ;; (csrc (concat (file-name-sans-extension src) ".elc"))
- )
- (cl-incf (if (eq (byte-recompile-file src nil 0) t)
- comp utd)))))
- (oref obj source))
- (message "All Semantic Grammar sources are up to date in %s" (eieio-object-name obj))
- (cons comp utd)))
-
-;;; Makefile generation functions
-;;
-(cl-defmethod ede-proj-makefile-sourcevar ((this semantic-ede-proj-target-grammar))
- "Return the variable name for THIS's sources."
- (cond ((ede-proj-automake-p)
- (error "No Automake support for Semantic Grammars"))
- (t (concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR"))))
-
-(cl-defmethod ede-proj-makefile-insert-variables :after ((this semantic-ede-proj-target-grammar))
- "Insert variables needed by target THIS."
- (ede-proj-makefile-insert-loadpath-items
- (ede-proj-elisp-packages-to-loadpath
- (list "eieio" "semantic" "ede")))
- ;; eieio for object system needed in ede
- ;; semantic because it is
- ;; ede for project regeneration
- (ede-pmake-insert-variable-shared
- (concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL")
- (insert
- (mapconcat (lambda (src)
- (with-current-buffer (find-file-noselect src)
- (concat (semantic-grammar-package) ".el")))
- (oref this source)
- " "))))
-
-(cl-defmethod ede-proj-makefile-insert-rules :after ((this semantic-ede-proj-target-grammar))
- "Insert rules needed by THIS target.
-This raises `max-lisp-eval-depth', which can be needed for the compilation
-of the resulting parsers."
- (insert (format "%s: EMACSFLAGS+= --eval '(setq max-lisp-eval-depth 700)'\n"
- (oref this name))))
-
-(cl-defmethod ede-proj-makefile-insert-dist-dependencies ((this semantic-ede-proj-target-grammar))
- "Insert dist dependencies, or intermediate targets.
-This makes sure that all grammar Lisp files are created before the dist
-runs, so they are always up to date.
-Argument THIS is the target that should insert stuff."
- (cl-call-next-method)
- (insert " $(" (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL)")
- )
-
-;; (autoload 'ede-proj-target-elisp "ede/proj-elisp"
-;; "Target class for Emacs/Semantic grammar files." nil nil)
-
-(ede-proj-register-target "semantic grammar"
- 'semantic-ede-proj-target-grammar)
-
-(provide 'semantic/ede-grammar)
-
-;;; semantic/ede-grammar.el ends here
+++ /dev/null
-;;; semantic/edit.el --- Edit Management for Semantic -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; In Semantic 1.x, changes were handled in a simplistic manner, where
-;; tags that changed were reparsed one at a time. Any other form of
-;; edit were managed through a full reparse.
-;;
-;; This code attempts to minimize the number of times a full reparse
-;; needs to occur. While overlays and tags will continue to be
-;; recycled in the simple case, new cases where tags are inserted
-;; or old tags removed from the original list are handled.
-;;
-
-;;; NOTES FOR IMPROVEMENT
-;;
-;; Work done by the incremental parser could be improved by the
-;; following:
-;;
-;; 1. Tags created could have as a property an overlay marking a region
-;; of themselves that can be edited w/out affecting the definition of
-;; that tag.
-;;
-;; 2. Tags with positioned children could have a property of an
-;; overlay marking the region in themselves that contain the
-;; children. This could be used to better improve splicing near
-;; the beginning and end of the child lists.
-;;
-
-;;; BUGS IN INCREMENTAL PARSER
-;;
-;; 1. Changes in the whitespace between tags could extend a
-;; following tag. These will be marked as merely unmatched
-;; syntax instead.
-;;
-;; 2. Incremental parsing while a new function is being typed in
-;; sometimes gets a chance only when lists are incomplete,
-;; preventing correct context identification.
-
-;;
-(require 'semantic)
-
-;;; Code:
-(defvar semantic-after-partial-cache-change-hook nil
- "Normal hook run after the buffer cache has been updated.
-
-This hook will run when the cache has been partially reparsed.
-Partial reparses are incurred when a user edits a buffer, and only the
-modified sections are rescanned.
-
-Hook functions must take one argument, which is the list of tags
-updated in the current buffer.
-
-For language specific hooks, make sure you define this as a local hook.")
-
-(defvar semantic-change-functions
- '(semantic-edits-change-function-handle-changes)
- "Abnormal hook run when semantic detects a change in a buffer.
-Each hook function must take three arguments, identical to the
-common hook `after-change-functions'.")
-
-(defvar semantic-reparse-needed-change-hook nil
- "Hooks run when a user edit is detected as needing a reparse.
-For language specific hooks, make sure you define this as a local hook.
-Not used yet; part of the next generation reparse mechanism.")
-
-(defvar semantic-no-reparse-needed-change-hook nil
- "Hooks run when a user edit is detected as not needing a reparse.
-If the hook returns non-nil, then declare that a reparse is needed.
-For language specific hooks, make sure you define this as a local hook.
-Not used yet; part of the next generation reparse mechanism.")
-
-(defvar semantic-edits-new-change-functions nil
- "Abnormal hook run when a new change is found.
-Functions must take one argument representing an overlay on that change.")
-
-(defvar semantic-edits-delete-change-functions nil
- "Abnormal hook run before a change overlay is deleted.
-Deleted changes occur when multiple changes are merged.
-Functions must take one argument representing an overlay being deleted.")
-
-(defvar semantic-edits-move-change-hook nil
- "Abnormal hook run after a change overlay is moved.
-Changes move when a new change overlaps an old change. The old change
-will be moved.
-Functions must take one argument representing an overlay being moved.")
-
-(defvar semantic-edits-reparse-change-functions nil
- "Abnormal hook run after a change results in a reparse.
-Functions are called before the overlay is deleted, and after the
-incremental reparse.")
-
-(defvar semantic-edits-incremental-reparse-failed-hook nil
- "Hook run after the incremental parser fails.
-When this happens, the buffer is marked as needing a full reparse.")
-
-(defcustom semantic-edits-verbose-flag nil
- "Non-nil means the incremental parser is verbose.
-If nil, errors are still displayed, but informative messages are not."
- :group 'semantic
- :type 'boolean)
-
-;;; Change State management
-;;
-;; Manage a series of overlays that define changes recently
-;; made to the current buffer.
-;;;###autoload
-(defun semantic-change-function (start end length)
- "Provide a mechanism for semantic tag management.
-Argument START, END, and LENGTH specify the bounds of the change."
- (setq semantic-unmatched-syntax-cache-check t)
- (save-match-data
- (run-hook-with-args 'semantic-change-functions start end length)
- ))
-
-(defun semantic-changes-in-region (start end &optional buffer)
- "Find change overlays which exist in whole or in part between START and END.
-Optional argument BUFFER is the buffer to search for changes in."
- (save-excursion
- (if buffer (set-buffer buffer))
- (let ((ol (overlays-in (max start (point-min))
- (min end (point-max))))
- (ret nil))
- (while ol
- (when (overlay-get (car ol) 'semantic-change)
- (setq ret (cons (car ol) ret)))
- (setq ol (cdr ol)))
- (sort ret :key #'overlay-start))))
-
-(defun semantic-edits-change-function-handle-changes (start end _length)
- "Run whenever a buffer controlled by `semantic-mode' change.
-Tracks when and how the buffer is re-parsed.
-Argument START, END, and LENGTH specify the bounds of the change."
- ;; We move start/end by one so that we can merge changes that occur
- ;; just before, or just after. This lets simple typing capture everything
- ;; into one overlay.
- (let ((changes-in-change (semantic-changes-in-region (1- start) (1+ end)))
- )
- (semantic-parse-tree-set-needs-update)
- (if (not changes-in-change)
- (let ((o (make-overlay start end)))
- (overlay-put o 'semantic-change t)
- ;; Run the hooks safely. When hooks blow it, our dirty
- ;; function will be removed from the list of active change
- ;; functions.
- (condition-case nil
- (run-hook-with-args 'semantic-edits-new-change-functions o)
- (error nil)))
- (let ((tmp changes-in-change))
- ;; Find greatest bounds of all changes
- (while tmp
- (when (< (overlay-start (car tmp)) start)
- (setq start (overlay-start (car tmp))))
- (when (> (overlay-end (car tmp)) end)
- (setq end (overlay-end (car tmp))))
- (setq tmp (cdr tmp)))
- ;; Move the first found overlay, recycling that overlay.
- (move-overlay (car changes-in-change) start end)
- (condition-case nil
- (run-hook-with-args 'semantic-edits-move-change-hooks
- (car changes-in-change))
- (error nil))
- (setq changes-in-change (cdr changes-in-change))
- ;; Delete other changes. They are now all bound here.
- (while changes-in-change
- (condition-case nil
- (run-hook-with-args 'semantic-edits-delete-change-functions
- (car changes-in-change))
- (error nil))
- (delete-overlay (car changes-in-change))
- (setq changes-in-change (cdr changes-in-change))))
- )))
-
-(defsubst semantic-edits-flush-change (change)
- "Flush the CHANGE overlay."
- (condition-case nil
- (run-hook-with-args 'semantic-edits-delete-change-functions
- change)
- (error nil))
- (delete-overlay change))
-
-(defun semantic-edits-flush-changes ()
- "Flush the changes in the current buffer."
- (let ((changes (semantic-changes-in-region (point-min) (point-max))))
- (while changes
- (semantic-edits-flush-change (car changes))
- (setq changes (cdr changes))))
- )
-
-(defun semantic-edits-change-in-one-tag-p (change hits)
- "Return non-nil if the overlay CHANGE exists solely in one leaf tag.
-HITS is the list of tags that CHANGE is in. It can have more than
-one tag in it if the leaf tag is within a parent tag."
- (and (< (semantic-tag-start (car hits))
- (overlay-start change))
- (> (semantic-tag-end (car hits))
- (overlay-end change))
- ;; Recurse on the rest. If this change is inside all
- ;; of these tags, then they are all leaves or parents
- ;; of the smallest tag.
- (or (not (cdr hits))
- (semantic-edits-change-in-one-tag-p change (cdr hits))))
- )
-
-;;; Change/Tag Query functions
-;;
-;; A change (region of space) can effect tags in different ways.
-;; These functions perform queries on a buffer to determine different
-;; ways that a change effects a buffer.
-;;
-;; NOTE: After debugging these, replace below to no longer look
-;; at point and mark (via comments I assume.)
-(defsubst semantic-edits-os (change)
- "For testing: Start of CHANGE, or smaller of (point) and (mark)."
- (if change (overlay-start change)
- (if (< (point) (mark)) (point) (mark))))
-
-(defsubst semantic-edits-oe (change)
- "For testing: End of CHANGE, or larger of (point) and (mark)."
- (if change (overlay-end change)
- (if (> (point) (mark)) (point) (mark))))
-
-(defun semantic-edits-change-leaf-tag (change)
- "A leaf tag which completely encompasses CHANGE.
-If change overlaps a tag, but is not encompassed in it, return nil.
-Use `semantic-edits-change-overlap-leaf-tag'.
-If CHANGE is completely encompassed in a tag, but overlaps sub-tags,
-return nil."
- (let* ((start (semantic-edits-os change))
- (end (semantic-edits-oe change))
- (tags (nreverse
- (semantic-find-tag-by-overlay-in-region
- start end))))
- ;; A leaf is always first in this list
- (if (and tags
- (<= (semantic-tag-start (car tags)) start)
- (> (semantic-tag-end (car tags)) end))
- ;; Ok, we have a match. If this tag has children,
- ;; we have to do more tests.
- (let ((chil (semantic-tag-components (car tags))))
- (if (not chil)
- ;; Simple leaf.
- (car tags)
- ;; For this type, we say that we encompass it if the
- ;; change occurs outside the range of the children.
- (if (or (not (semantic-tag-with-position-p (car chil)))
- (> start (semantic-tag-end (nth (1- (length chil)) chil)))
- (< end (semantic-tag-start (car chil))))
- ;; We have modifications to the definition of this parent
- ;; so we have to reparse the whole thing.
- (car tags)
- ;; We actually modified an area between some children.
- ;; This means we should return nil, as that case is
- ;; calculated by someone else.
- nil)))
- nil)))
-
-(defun semantic-edits-change-between-tags (change)
- "Return a cache list of tags surrounding CHANGE.
-The returned list is the CONS cell in the master list pointing to
-a tag just before CHANGE. The CDR will have the tag just after CHANGE.
-CHANGE cannot encompass or overlap a leaf tag.
-If CHANGE is fully encompassed in a tag that has children, and
-this change occurs between those children, this returns non-nil.
-See `semantic-edits-change-leaf-tag' for details on parents."
- (let* ((start (semantic-edits-os change))
- (end (semantic-edits-oe change))
- (tags (nreverse
- (semantic-find-tag-by-overlay-in-region
- start end)))
- (list-to-search nil)
- (found nil))
- (if (not tags)
- (setq list-to-search semantic--buffer-cache)
- ;; A leaf is always first in this list
- (if (and (< (semantic-tag-start (car tags)) start)
- (> (semantic-tag-end (car tags)) end))
- ;; We are completely encompassed in a tag.
- (if (setq list-to-search
- (semantic-tag-components (car tags)))
- ;; Ok, we are completely encompassed within the first tag
- ;; entry, AND that tag has children. This means that change
- ;; occurred outside of all children, but inside some tag
- ;; with children.
- (if (or (not (semantic-tag-with-position-p (car list-to-search)))
- (> start (semantic-tag-end
- (nth (1- (length list-to-search))
- list-to-search)))
- (< end (semantic-tag-start (car list-to-search))))
- ;; We have modifications to the definition of this parent
- ;; and not between it's children. Clear the search list.
- (setq list-to-search nil)))
- ;; Search list is nil.
- ))
- ;; If we have a search list, let's go. Otherwise nothing.
- (while (and list-to-search (not found))
- (if (cdr list-to-search)
- ;; We end when the start of the CDR is after the end of our
- ;; asked change.
- (if (< (semantic-tag-start (cadr list-to-search)) end)
- (setq list-to-search (cdr list-to-search))
- (setq found t))
- (setq list-to-search nil)))
- ;; Return it. If it is nil, there is a logic bug, and we need
- ;; to avoid this bit of logic anyway.
- list-to-search
- ))
-
-(defun semantic-edits-change-over-tags (change)
- "Return a cache list of tags surrounding a CHANGE encompassing tags.
-CHANGE must not only include all overlapped tags (excepting possible
-parent tags) in their entirety. In this case, the change may be deleting
-or moving whole tags.
-The return value is a vector.
-Cell 0 is a list of all tags completely encompassed in change.
-Cell 1 is the cons cell into a master parser cache starting with
-the cell which occurs BEFORE the first position of CHANGE.
-Cell 2 is the parent of cell 1, or nil for the buffer cache.
-This function returns nil if any tag covered by change is not
-completely encompassed.
-See `semantic-edits-change-leaf-tag' for details on parents."
- (let* ((start (semantic-edits-os change))
- (end (semantic-edits-oe change))
- (tags (nreverse
- (semantic-find-tag-by-overlay-in-region
- start end)))
- (parent nil)
- (overlapped-tags nil)
- inner-end ;; inner-start
- (list-to-search nil))
- ;; By the time this is already called, we know that it is
- ;; not a leaf change, nor a between tag change. That leaves
- ;; an overlap, and this condition.
-
- ;; A leaf is always first in this list.
- ;; Is the leaf encompassed in this change?
- (if (and tags
- (>= (semantic-tag-start (car tags)) start)
- (<= (semantic-tag-end (car tags)) end))
- (progn
- ;; We encompass one whole change.
- (setq overlapped-tags (list (car tags))
- ;; inner-start (semantic-tag-start (car tags))
- inner-end (semantic-tag-end (car tags))
- tags (cdr tags))
- ;; Keep looping while tags are inside the change.
- (while (and tags
- (>= (semantic-tag-start (car tags)) start)
- (<= (semantic-tag-end (car tags)) end))
-
- ;; Check if this new all-encompassing tag is a parent
- ;; of that which went before. Only check end because
- ;; we know that start is less than inner-start since
- ;; tags was sorted on that.
- (if (> (semantic-tag-end (car tags)) inner-end)
- ;; This is a parent. Drop the children found
- ;; so far.
- (setq overlapped-tags (list (car tags))
- ;; inner-start (semantic-tag-start (car tags))
- inner-end (semantic-tag-end (car tags))
- )
- ;; It is not a parent encompassing tag
- (setq overlapped-tags (cons (car tags)
- overlapped-tags)
- ;; inner-start (semantic-tag-start (car tags))
- ))
- (setq tags (cdr tags)))
- (if (not tags)
- ;; There are no tags left, and all tags originally
- ;; found are encompassed by the change. Setup our list
- ;; from the cache
- (setq list-to-search semantic--buffer-cache);; We have a tag outside the list. Check for
- ;; We know we have a parent because it would
- ;; completely cover the change. A tag can only
- ;; do that if it is a parent after we get here.
- (when (and tags
- (< (semantic-tag-start (car tags)) start)
- (> (semantic-tag-end (car tags)) end))
- ;; We have a parent. Stuff in the search list.
- (setq parent (car tags)
- list-to-search (semantic-tag-components parent))
- ;; If the first of TAGS is a parent (see above)
- ;; then clear out the list. All other tags in
- ;; here must therefore be parents of the car.
- (setq tags nil)
- ;; One last check, If start is before the first
- ;; tag or after the last, we may have overlap into
- ;; the characters that make up the definition of
- ;; the tag we are parsing.
- (when (or (semantic-tag-with-position-p (car list-to-search))
- (< start (semantic-tag-start
- (car list-to-search)))
- (> end (semantic-tag-end
- (nth (1- (length list-to-search))
- list-to-search))))
- ;; We have a problem
- (setq list-to-search nil
- parent nil))))
-
- (when list-to-search
-
- ;; Ok, return the vector only if all TAGS are
- ;; confirmed as the lineage of `overlapped-tags'
- ;; which must have a value by now.
-
- ;; Loop over the search list to find the preceding CDR.
- ;; Fortunately, (car overlapped-tags) happens to be
- ;; the first tag positionally.
- (let ((tokstart (semantic-tag-start (car overlapped-tags))))
- (while (and list-to-search
- ;; Assume always (car (cdr list-to-search)).
- ;; A thrown error will be captured nicely, but
- ;; that case shouldn't happen.
-
- ;; We end when the start of the CDR is after the
- ;; end of our asked change.
- (cdr list-to-search)
- (< (semantic-tag-start (car (cdr list-to-search)))
- tokstart)
- (setq list-to-search (cdr list-to-search)))))
- ;; Create the return vector
- (vector overlapped-tags
- list-to-search
- parent)
- ))
- nil)))
-
-;;; Default Incremental Parser
-;;
-;; Logic about how to group changes for effective reparsing and splicing.
-
-(defun semantic-parse-changes-failed (&rest args)
- "Signal that Semantic failed to parse changes.
-That is, display a message by passing all ARGS to `format-message', then throw
-a `semantic-parse-changes-failed' exception with value t."
- (when semantic-edits-verbose-flag
- (message "Semantic parse changes failed: %S"
- (apply #'format-message args)))
- (throw 'semantic-parse-changes-failed t))
-
-(defsubst semantic-edits-incremental-fail ()
- "When the incremental parser fails, we mark that we need a full reparse."
- ;;(debug)
- (semantic-parse-tree-set-needs-rebuild)
- (when semantic-edits-verbose-flag
- (message "Force full reparse (%s)"
- (buffer-name (current-buffer))))
- (run-hooks 'semantic-edits-incremental-reparse-failed-hook))
-
-;;;###autoload
-(defun semantic-edits-incremental-parser ()
- "Incrementally reparse the current buffer.
-Incremental parser allows semantic to only reparse those sections of
-the buffer that have changed. This function depends on
-`semantic-edits-change-function-handle-changes' setting up change
-overlays in the current buffer. Those overlays are analyzed against
-the semantic cache to see what needs to be changed."
- (let ((changed-tags
- ;; Don't use `semantic-safe' here to explicitly catch errors
- ;; and reset the parse tree.
- (catch 'semantic-parse-changes-failed
- (if debug-on-error
- (semantic-edits-incremental-parser-1)
- (condition-case err
- (semantic-edits-incremental-parser-1)
- (error
- (message "incremental parser error: %S"
- (error-message-string err))
- t))))))
- (when (eq changed-tags t)
- ;; Force a full reparse.
- (semantic-edits-incremental-fail)
- (setq changed-tags nil))
- changed-tags))
-
-(defmacro semantic-edits-assert-valid-region ()
- "Assert that parse-start and parse-end are sorted correctly."
-;;; (if (> parse-start parse-end)
-;;; (error "Bug is %s !> %d! Buff min/max = [ %d %d ]"
-;;; parse-start parse-end
-;;; (point-min) (point-max)))
- )
-
-(defun semantic-edits-incremental-parser-1 ()
- "Incrementally reparse the current buffer.
-Return the list of tags that changed.
-If the incremental parse fails, throw a `semantic-parse-changes-failed'
-exception with value t, that can be caught to schedule a full reparse.
-This function is for internal use by `semantic-edits-incremental-parser'."
- (let* ((changed-tags nil)
- (debug-on-quit t) ; try to find this annoying bug!
- (changes (semantic-changes-in-region
- (point-min) (point-max)))
- (tags nil) ;tags found at changes
- (newf-tags nil) ;newfound tags in change
- (parse-start nil) ;location to start parsing
- (parse-end nil) ;location to end parsing
- (parent-tag nil) ;parent of the cache list.
- (cache-list nil) ;list of children within which
- ;we incrementally reparse.
- (reparse-symbol nil) ;The ruled we start at for reparse.
- (change-group nil) ;changes grouped in this reparse
- (last-cond nil) ;track the last case used.
- ;query this when debugging to find
- ;source of bugs.
- )
- (ignore last-cond) ;; Don't warn about the var not being used.
- (or changes
- ;; If we were called, and there are no changes, then we
- ;; don't know what to do. Force a full reparse.
- (semantic-parse-changes-failed "Don't know what to do"))
- ;; Else, we have some changes. Loop over them attempting to
- ;; patch things up.
- (while changes
- ;; Calculate the reparse boundary.
- ;; We want to take some set of changes, and group them
- ;; together into a small change group. One change forces
- ;; a reparse of a larger region (the size of some set of
- ;; tags it encompasses.) It may contain several tags.
- ;; That region may have other changes in it (several small
- ;; changes in one function, for example.)
- ;; Optimize for the simple cases here, but try to handle
- ;; complex ones too.
-
- (while (and changes ; we still have changes
- (or (not parse-start)
- ;; Below, if the change we are looking at
- ;; is not the first change for this
- ;; iteration, and it starts before the end
- ;; of current parse region, then it is
- ;; encompassed within the bounds of tags
- ;; modified by the previous iteration's
- ;; change.
- (< (overlay-start (car changes))
- parse-end)))
-
- ;; REMOVE LATER
- (if (eq (car changes) (car change-group))
- (semantic-parse-changes-failed
- "Possible infinite loop detected"))
-
- ;; Store this change in this change group.
- (setq change-group (cons (car changes) change-group))
-
- (cond
- ;; Is this is a new parse group?
- ((not parse-start)
- (setq last-cond "new group")
- (let (tmp)
- (cond
-
-;;;; Are we encompassed all in one tag?
- ((setq tmp (semantic-edits-change-leaf-tag (car changes)))
- (setq last-cond "Encompassed in tag")
- (setq tags (list tmp)
- parse-start (semantic-tag-start tmp)
- parse-end (semantic-tag-end tmp)
- )
- (semantic-edits-assert-valid-region))
-
-;;;; Did the change occur between some tags?
- ((setq cache-list (semantic-edits-change-between-tags
- (car changes)))
- (setq last-cond "Between and not overlapping tags")
- ;; The CAR of cache-list is the tag just before
- ;; our change, but wasn't modified. Hmmm.
- ;; Bound our reparse between these two tags
- (setq tags nil
- parent-tag
- (car (semantic-find-tag-by-overlay
- parse-start)))
- (cond
- ;; A change at the beginning of the buffer.
- ;; Feb 06 -
- ;; IDed when the first cache-list tag is after
- ;; our change, meaning there is nothing before
- ;; the change.
- ((> (semantic-tag-start (car cache-list))
- (overlay-end (car changes)))
- (setq last-cond "Beginning of buffer")
- (setq parse-start
- ;; Don't worry about parents since
- ;; there would be an exact
- ;; match in the tag list otherwise
- ;; and the routine would fail.
- (point-min)
- parse-end
- (semantic-tag-start (car cache-list)))
- (semantic-edits-assert-valid-region)
- )
- ;; A change stuck on the first surrounding tag.
- ((= (semantic-tag-end (car cache-list))
- (overlay-start (car changes)))
- (setq last-cond "Beginning of Tag")
- ;; Reparse that first tag.
- (setq parse-start
- (semantic-tag-start (car cache-list))
- parse-end
- (overlay-end (car changes))
- tags
- (list (car cache-list)))
- (semantic-edits-assert-valid-region)
- )
- ;; A change at the end of the buffer.
- ((not (car (cdr cache-list)))
- (setq last-cond "End of buffer")
- (setq parse-start (semantic-tag-end
- (car cache-list))
- parse-end (point-max))
- (semantic-edits-assert-valid-region)
- )
- (t
- (setq last-cond "Default")
- (setq parse-start
- (semantic-tag-end (car cache-list))
- parse-end
- (semantic-tag-start (car (cdr cache-list)))
- )
- (semantic-edits-assert-valid-region))))
-
-;;;; Did the change completely overlap some number of tags?
- ((setq tmp (semantic-edits-change-over-tags
- (car changes)))
- (setq last-cond "Overlap multiple tags")
- ;; Extract the information
- (setq tags (aref tmp 0)
- cache-list (aref tmp 1)
- parent-tag (aref tmp 2))
- ;; We can calculate parse begin/end by checking
- ;; out what is in TAGS. The one near start is
- ;; always first. Make sure the reparse includes
- ;; the `whitespace' around the snarfed tags.
- ;; Since cache-list is positioned properly, use it
- ;; to find that boundary.
- (if (eq (car tags) (car cache-list))
- ;; Beginning of the buffer!
- (let ((end-marker (nth (length tags)
- cache-list)))
- (setq parse-start (point-min))
- (if end-marker
- (setq parse-end
- (semantic-tag-start end-marker))
- (setq parse-end (overlay-end
- (car changes))))
- (semantic-edits-assert-valid-region)
- )
- ;; Middle of the buffer.
- (setq parse-start
- (semantic-tag-end (car cache-list)))
- ;; For the end, we need to scoot down some
- ;; number of tags. We 1+ the length of tags
- ;; because we want to skip the first tag
- ;; (remove 1-) then want the tag after the end
- ;; of the list (1+)
- (let ((end-marker (nth (1+ (length tags)) cache-list)))
- (if end-marker
- (setq parse-end (semantic-tag-start end-marker))
- ;; No marker. It is the last tag in our
- ;; list of tags. Only possible if END
- ;; already matches the end of that tag.
- (setq parse-end
- (overlay-end (car changes)))))
- (semantic-edits-assert-valid-region)
- ))
-
-;;;; Unhandled case.
- ;; Throw error, and force full reparse.
- ((semantic-parse-changes-failed "Unhandled change group")))
- ))
- ;; Is this change inside the previous parse group?
- ;; We already checked start.
- ((< (overlay-end (car changes)) parse-end)
- (setq last-cond "in bounds")
- nil)
- ;; This change extends the current parse group.
- ;; Find any new tags, and see how to append them.
- ((semantic-parse-changes-failed
- (setq last-cond "overlap boundary")
- "Unhandled secondary change overlapping boundary"))
- )
- ;; Prepare for the next iteration.
- (setq changes (cdr changes)))
-
- ;; By the time we get here, all TAGS are children of
- ;; some parent. They should all have the same start symbol
- ;; since that is how the multi-tag parser works. Grab
- ;; the reparse symbol from the first of the returned tags.
- ;;
- ;; Feb '06 - If reparse-symbol is nil, then they are top level
- ;; tags. (I'm guessing.) Is this right?
- (setq reparse-symbol
- (semantic--tag-get-property (car (or tags cache-list))
- 'reparse-symbol))
- ;; Find a parent if not provided.
- (and (not parent-tag) tags
- (setq parent-tag
- (semantic-find-tag-parent-by-overlay
- (car tags))))
- ;; We can do the same trick for our parent and resulting
- ;; cache list.
- (unless cache-list
- (if parent-tag
- (setq cache-list
- ;; We need to get all children in case we happen
- ;; to have a mix of positioned and non-positioned
- ;; children.
- (semantic-tag-components parent-tag))
- ;; Else, all the tags since there is no parent.
- ;; It sucks to have to use the full buffer cache in
- ;; this case because it can be big. Failure to provide
- ;; however results in a crash.
- (setq cache-list semantic--buffer-cache)
- ))
- ;; Use the boundary to calculate the new tags found.
- (setq newf-tags (semantic-parse-region
- parse-start parse-end reparse-symbol))
- ;; Make sure all these tags are given overlays.
- ;; They have already been cooked by the parser and just
- ;; need the overlays.
- (let ((tmp newf-tags))
- (while tmp
- (semantic--tag-link-to-buffer (car tmp))
- (setq tmp (cdr tmp))))
-
- ;; See how this change lays out.
- (cond
-
-;;;; Whitespace change
- ((and (not tags) (not newf-tags))
- ;; A change that occurred outside of any existing tags
- ;; and there are no new tags to replace it.
- (when semantic-edits-verbose-flag
- (message "White space changes"))
- nil
- )
-
-;;;; New tags in old whitespace area.
- ((and (not tags) newf-tags)
- ;; A change occurred outside existing tags which added
- ;; a new tag. We need to splice these tags back
- ;; into the cache at the right place.
- (semantic-edits-splice-insert newf-tags parent-tag cache-list)
-
- (setq changed-tags
- (append newf-tags changed-tags))
-
- (when semantic-edits-verbose-flag
- (message "Inserted tags: (%s)"
- (semantic-format-tag-name (car newf-tags))))
- )
-
-;;;; Old tags removed
- ((and tags (not newf-tags))
- ;; A change occurred where pre-existing tags were
- ;; deleted! Remove the tag from the cache.
- (semantic-edits-splice-remove tags parent-tag cache-list)
-
- (setq changed-tags
- (append tags changed-tags))
-
- (when semantic-edits-verbose-flag
- (message "Deleted tags: (%s)"
- (semantic-format-tag-name (car tags))))
- )
-
-;;;; One tag was updated.
- ((and (= (length tags) 1) (= (length newf-tags) 1))
- ;; One old tag was modified, and it is replaced by
- ;; One newfound tag. Splice the new tag into the
- ;; position of the old tag.
- ;; Do the splice.
- (semantic-edits-splice-replace (car tags) (car newf-tags))
- ;; Add this tag to our list of changed toksns
- (setq changed-tags (cons (car tags) changed-tags))
- ;; Debug
- (when semantic-edits-verbose-flag
- (message "Update Tag Table: %s"
- (semantic-format-tag-name (car tags) nil t)))
- ;; Flush change regardless of above if statement.
- )
-
-;;;; Some unhandled case.
- ((semantic-parse-changes-failed "Don't know what to do")))
-
- ;; We got this far, and we didn't flag a full reparse.
- ;; Clear out this change group.
- (while change-group
- (semantic-edits-flush-change (car change-group))
- (setq change-group (cdr change-group)))
-
- ;; Don't increment change here because an earlier loop
- ;; created change-groups.
- (setq parse-start nil)
- )
- ;; Mark that we are done with this glop
- (semantic-parse-tree-set-up-to-date)
- ;; Return the list of tags that changed. The caller will
- ;; use this information to call hooks which can fix themselves.
- changed-tags))
-
-;; Make it the default changes parser
-;;;###autoload
-(defalias 'semantic-parse-changes-default #'semantic-edits-incremental-parser)
-
-;;; Cache Splicing
-;;
-;; The incremental parser depends on the ability to parse up sections
-;; of the file, and splice the results back into the cache. There are
-;; three types of splices. A REPLACE, an ADD, and a REMOVE. REPLACE
-;; is one of the simpler cases, as the starting cons cell representing
-;; the old tag can be used to auto-splice in. ADD and REMOVE
-;; require scanning the cache to find the correct location so that the
-;; list can be fiddled.
-(defun semantic-edits-splice-remove (oldtags parent cachelist)
- "Remove OLDTAGS from PARENT's CACHELIST.
-OLDTAGS are tags in the current buffer, preferably linked
-together also in CACHELIST.
-PARENT is the parent tag containing OLDTAGS.
-CACHELIST should be the children from PARENT, but may be
-pre-positioned to a convenient location."
- (let* ((first (car oldtags))
- (last (nth (1- (length oldtags)) oldtags))
- (chil (if parent
- (semantic-tag-components parent)
- semantic--buffer-cache))
- (cachestart cachelist)
- (cacheend nil)
- )
- ;; First in child list?
- (if (eq first (car chil))
- ;; First tags in the cache are being deleted.
- (progn
- (when semantic-edits-verbose-flag
- (message "To Remove First Tag: (%s)"
- (semantic-format-tag-name first)))
- ;; Find the last tag
- (setq cacheend chil)
- (while (and cacheend (not (eq last (car cacheend))))
- (setq cacheend (cdr cacheend)))
- ;; The spliceable part is after cacheend.. so move cacheend
- ;; one more tag.
- (setq cacheend (cdr cacheend))
- ;; Splice the found end tag into the cons cell
- ;; owned by the current top child.
- (setcar chil (car cacheend))
- (setcdr chil (cdr cacheend))
- (when (not cacheend)
- ;; No cacheend.. then the whole system is empty.
- ;; The best way to deal with that is to do a full
- ;; reparse
- (semantic-parse-changes-failed "Splice-remove failed. Empty buffer?")
- ))
- (when semantic-edits-verbose-flag
- (message "To Remove Middle Tag: (%s)"
- (semantic-format-tag-name first))))
- ;; Find in the cache the preceding tag
- (while (and cachestart (not (eq first (car (cdr cachestart)))))
- (setq cachestart (cdr cachestart)))
- ;; Find the last tag
- (setq cacheend cachestart)
- (while (and cacheend (not (eq last (car cacheend))))
- (setq cacheend (cdr cacheend)))
- ;; Splice the end position into the start position.
- ;; If there is no start, then this whole section is probably
- ;; gone.
- (if cachestart
- (setcdr cachestart (cdr cacheend))
- (semantic-parse-changes-failed "Splice-remove failed."))
-
- ;; Remove old overlays of these deleted tags
- (while oldtags
- (semantic--tag-unlink-from-buffer (car oldtags))
- (setq oldtags (cdr oldtags)))
- ))
-
-(defun semantic-edits-splice-insert (newtags parent cachelist)
- "Insert NEWTAGS into PARENT using CACHELIST.
-PARENT could be nil, in which case CACHELIST is the buffer cache
-which must be updated.
-CACHELIST must be searched to find where NEWTAGS are to be inserted.
-The positions of NEWTAGS must be synchronized with those in
-CACHELIST for this to work. Some routines pre-position CACHELIST at a
-convenient location, so use that."
- (let* ((start (semantic-tag-start (car newtags)))
- (newtagendcell (nthcdr (1- (length newtags)) newtags))
- (end (semantic-tag-end (car newtagendcell)))
- )
- (if (> (semantic-tag-start (car cachelist)) start)
- ;; We are at the beginning.
- (let* ((pc (if parent
- (semantic-tag-components parent)
- semantic--buffer-cache))
- (nc (cons (car pc) (cdr pc))) ; new cons cell.
- )
- ;; Splice the new cache cons cell onto the end of our list.
- (setcdr newtagendcell nc)
- ;; Set our list into parent.
- (setcar pc (car newtags))
- (setcdr pc (cdr newtags)))
- ;; We are at the end, or in the middle. Find our match first.
- (while (and (cdr cachelist)
- (> end (semantic-tag-start (car (cdr cachelist)))))
- (setq cachelist (cdr cachelist)))
- ;; Now splice into the list!
- (setcdr newtagendcell (cdr cachelist))
- (setcdr cachelist newtags))))
-
-(defun semantic-edits-splice-replace (oldtag newtag)
- "Replace OLDTAG with NEWTAG in the current cache.
-Do this by recycling OLDTAG's first CONS cell. This effectively
-causes the new tag to completely replace the old one.
-Make sure that all information in the overlay is transferred.
-It is presumed that OLDTAG and NEWTAG are both cooked.
-When this routine returns, OLDTAG is raw, and the data will be
-lost if not transferred into NEWTAG."
- (let* ((oo (semantic-tag-overlay oldtag))
- (o (semantic-tag-overlay newtag))
- (oo-props (overlay-properties oo)))
- (while oo-props
- (overlay-put o (car oo-props) (car (cdr oo-props)))
- (setq oo-props (cdr (cdr oo-props)))
- )
- ;; Free the old overlay(s)
- (semantic--tag-unlink-from-buffer oldtag)
- ;; Recover properties
- (semantic--tag-copy-properties oldtag newtag)
- ;; Splice into the main list.
- (setcdr oldtag (cdr newtag))
- (setcar oldtag (car newtag))
- ;; This important bit is because the CONS cell representing
- ;; OLDTAG is now pointing to NEWTAG, but the NEWTAG
- ;; cell is about to be abandoned. Here we update our overlay
- ;; to point at the updated state of the world.
- (overlay-put o 'semantic oldtag)
- ))
-
-(add-hook 'semantic-before-toplevel-cache-flush-hook
- #'semantic-edits-flush-changes)
-
-(provide 'semantic/edit)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/edit"
-;; End:
-
-;;; semantic/edit.el ends here
+++ /dev/null
-;;; semantic/find.el --- Search routines for Semantic -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2005, 2008-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Routines for searching through lists of tags.
-;; There are several groups of tag search routines:
-;;
-;; 1) semantic-brute-find-tag-by-*
-;; These routines use brute force hierarchical search to scan
-;; through lists of tags. They include some parameters
-;; used for compatibility with the semantic 1.x search routines.
-;;
-;; 1.5) semantic-brute-find-first-tag-by-*
-;; Like 1, except searching stops on the first match for the given
-;; information.
-;;
-;; 2) semantic-find-tag-by-*
-;; These preferred search routines attempt to scan through lists
-;; in an intelligent way based on questions asked.
-;;
-;; 3) semantic-find-*-overlay
-;; These routines use overlays to return tags based on a buffer position.
-;;
-;; 4) ...
-
-;;; Code:
-
-(require 'semantic)
-(require 'semantic/tag)
-
-(declare-function semantic-tag-protected-p "semantic/tag-ls")
-(declare-function semantic-tag-package-protected-p "semantic/tag-ls")
-
-;;; Overlay Search Routines
-;;
-;; These routines provide fast access to tokens based on a buffer that
-;; has parsed tokens in it. Uses overlays to perform the hard work.
-;;
-;;;###autoload
-(defun semantic-find-tag-by-overlay (&optional positionormarker buffer)
- "Find all tags covering POSITIONORMARKER by using overlays.
-If POSITIONORMARKER is nil, use the current point.
-Optional BUFFER is used if POSITIONORMARKER is a number, otherwise the current
-buffer is used. This finds all tags covering the specified position
-by checking for all overlays covering the current spot. They are then sorted
-from largest to smallest via the start location."
- (save-excursion
- (when positionormarker
- (if (markerp positionormarker)
- (set-buffer (marker-buffer positionormarker))
- (if (bufferp buffer)
- (set-buffer buffer))))
- (let ((ol (overlays-at (or positionormarker (point))))
- (ret nil))
- (while ol
- (let ((tmp (overlay-get (car ol) 'semantic)))
- (when (and tmp
- ;; We don't need with-position because no tag w/out
- ;; a position could exist in an overlay.
- (semantic-tag-p tmp))
- (setq ret (cons tmp ret))))
- (setq ol (cdr ol)))
- (sort ret :key #'semantic-tag-start))))
-
-;;;###autoload
-(defun semantic-find-tag-by-overlay-in-region (start end &optional buffer)
- "Find all tags which exist in whole or in part between START and END.
-Uses overlays to determine position.
-Optional BUFFER argument specifies the buffer to use."
- (save-excursion
- (if buffer (set-buffer buffer))
- (let ((ol (overlays-in start end))
- (ret nil))
- (while ol
- (let ((tmp (overlay-get (car ol) 'semantic)))
- (when (and tmp
- ;; See above about position
- (semantic-tag-p tmp))
- (setq ret (cons tmp ret))))
- (setq ol (cdr ol)))
- (sort ret :key #'semantic-tag-start))))
-
-;;;###autoload
-(defun semantic-find-tag-by-overlay-next (&optional start buffer)
- "Find the next tag after START in BUFFER.
-If START is in an overlay, find the tag which starts next,
-not the current tag."
- (save-excursion
- (if buffer (set-buffer buffer))
- (if (not start) (setq start (point)))
- (let ((os start) (ol nil))
- (while (and os (< os (point-max)) (not ol))
- (setq os (next-overlay-change os))
- (when os
- ;; Get overlays at position
- (setq ol (overlays-at os))
- ;; find the overlay that belongs to semantic
- ;; and starts at the found position.
- (while (and ol (listp ol))
- (if (and (overlay-get (car ol) 'semantic)
- (semantic-tag-p
- (overlay-get (car ol) 'semantic))
- (= (overlay-start (car ol)) os))
- (setq ol (car ol)))
- (when (listp ol) (setq ol (cdr ol))))))
- ;; convert ol to a tag
- (when (and ol (semantic-tag-p (overlay-get ol 'semantic)))
- (overlay-get ol 'semantic)))))
-
-;;;###autoload
-(defun semantic-find-tag-by-overlay-prev (&optional start buffer)
- "Find the next tag before START in BUFFER.
-If START is in an overlay, find the tag which starts next,
-not the current tag."
- (save-excursion
- (if buffer (set-buffer buffer))
- (if (not start) (setq start (point)))
- (let ((os start) (ol nil))
- (while (and os (> os (point-min)) (not ol))
- (setq os (previous-overlay-change os))
- (when os
- ;; Get overlays at position
- (setq ol (overlays-at (1- os)))
- ;; find the overlay that belongs to semantic
- ;; and ENDS at the found position.
- ;;
- ;; Use end because we are going backward.
- (while (and ol (listp ol))
- (if (and (overlay-get (car ol) 'semantic)
- (semantic-tag-p
- (overlay-get (car ol) 'semantic))
- (= (overlay-end (car ol)) os))
- (setq ol (car ol)))
- (when (listp ol) (setq ol (cdr ol))))))
- ;; convert ol to a tag
- (when (and ol
- (semantic-tag-p (overlay-get ol 'semantic)))
- (overlay-get ol 'semantic)))))
-
-;;;###autoload
-(defun semantic-find-tag-parent-by-overlay (tag)
- "Find the parent of TAG by overlays.
-Overlays are a fast way of finding this information for active buffers."
- (let ((tag (nreverse (semantic-find-tag-by-overlay
- (semantic-tag-start tag)))))
- ;; This is a lot like `semantic-current-tag-parent', but
- ;; it uses a position to do it's work. Assumes two tags don't share
- ;; the same start unless they are siblings.
- (car (cdr tag))))
-
-;;;###autoload
-(defun semantic-current-tag ()
- "Return the current tag in the current buffer.
-If there are more than one in the same location, return the
-smallest tag. Return nil if there is no tag here."
- (car (nreverse (semantic-find-tag-by-overlay))))
-
-;;;###autoload
-(defun semantic-current-tag-parent ()
- "Return the current tags parent in the current buffer.
-A tag's parent would be a containing structure, such as a type
-containing a field. Return nil if there is no parent."
- (car (cdr (nreverse (semantic-find-tag-by-overlay)))))
-
-(defun semantic-current-tag-of-class (class)
- "Return the current (smallest) tags of CLASS in the current buffer.
-If the smallest tag is not of type CLASS, keep going upwards until one
-is found.
-Uses `semantic-tag-class' for classification."
- (let ((tags (nreverse (semantic-find-tag-by-overlay))))
- (while (and tags
- (not (eq (semantic-tag-class (car tags)) class)))
- (setq tags (cdr tags)))
- (car tags)))
-\f
-;;; Search Routines
-;;
-;; These are routines that search a single tags table.
-;;
-;; The original API (see COMPATIBILITY section below) in semantic 1.4
-;; had these usage statistics:
-;;
-;; semantic-find-nonterminal-by-name 17
-;; semantic-find-nonterminal-by-name-regexp 8 - Most doing completion
-;; semantic-find-nonterminal-by-position 13
-;; semantic-find-nonterminal-by-token 21
-;; semantic-find-nonterminal-by-type 2
-;; semantic-find-nonterminal-standard 1
-;;
-;; semantic-find-nonterminal-by-function (not in other searches) 1
-;;
-;; New API: As above w/out `search-parts' or `search-includes' arguments.
-;; Extra fcn: Specific to completion which is what -name-regexp is
-;; mostly used for
-;;
-;; As for the sarguments "search-parts" and "search-includes" here
-;; are stats:
-;;
-;; search-parts: 4 - charting x2, find-doc, senator (sans db)
-;;
-;; Implement command to flatten a tag table. Call new API Fcn w/
-;; flattened table for same results.
-;;
-;; search-include: 2 - analyze x2 (sans db)
-;;
-;; Not used effectively. Not to be re-implemented here.
-
-(defsubst semantic--find-tags-by-function (predicate &optional table)
- "Find tags for which PREDICATE is non-nil in TABLE.
-PREDICATE is a lambda expression which accepts on TAG.
-TABLE is a semantic tags table. See `semantic-something-to-tag-table'."
- (let ((tags (semantic-something-to-tag-table table))
- (result nil))
-; (mapc (lambda (tag) (and (funcall predicate tag)
-; (setq result (cons tag result))))
-; tags)
- ;; A while loop is actually faster. Who knew
- (while tags
- (and (funcall predicate (car tags))
- (setq result (cons (car tags) result)))
- (setq tags (cdr tags)))
- (nreverse result)))
-
-;; I can shave off some time by removing the funcall (see above)
-;; and having the question be inlined in the while loop.
-;; Strangely turning the upper level fcns into macros had a larger
-;; impact.
-(defmacro semantic--find-tags-by-macro (form &optional table)
- "Find tags for which FORM is non-nil in TABLE.
-TABLE is a semantic tags table. See `semantic-something-to-tag-table'."
- `(let ((tags (semantic-something-to-tag-table ,table))
- (result nil))
- (while tags
- (and ,form
- (setq result (cons (car tags) result)))
- (setq tags (cdr tags)))
- (nreverse result)))
-
-;;; Top level Searches
-;;
-;;;###autoload
-(defun semantic-find-first-tag-by-name (name &optional table)
- "Find the first tag with NAME in TABLE.
-NAME is a string.
-TABLE is a semantic tags table. See `semantic-something-to-tag-table'.
-Respects `semantic-case-fold'."
- (assoc-string name (semantic-something-to-tag-table table)
- semantic-case-fold))
-
-(defmacro semantic-find-tags-by-name (name &optional table)
- "Find all tags with NAME in TABLE.
-NAME is a string.
-TABLE is a tag table. See `semantic-something-to-tag-table'."
- `(let ((case-fold-search semantic-case-fold))
- (semantic--find-tags-by-macro
- (string= ,name (semantic-tag-name (car tags)))
- ,table)))
-
-(defmacro semantic-find-tags-for-completion (prefix &optional table)
- "Find all tags whose name begins with PREFIX in TABLE.
-PREFIX is a string.
-TABLE is a tag table. See `semantic-something-to-tag-table'.
-While it would be nice to use `try-completion' or `all-completions',
-those functions do not return the tags, only a string.
-Uses `compare-strings' for fast comparison."
- `(let ((l (length ,prefix)))
- (semantic--find-tags-by-macro
- (eq (compare-strings ,prefix 0 nil
- (semantic-tag-name (car tags)) 0 l
- semantic-case-fold)
- t)
- ,table)))
-
-(defmacro semantic-find-tags-by-name-regexp (regexp &optional table)
- "Find all tags with name matching REGEXP in TABLE.
-REGEXP is a string containing a regular expression,
-TABLE is a tag table. See `semantic-something-to-tag-table'.
-Consider using `semantic-find-tags-for-completion' if you are
-attempting to do completions."
- `(let ((case-fold-search semantic-case-fold))
- (semantic--find-tags-by-macro
- (string-match ,regexp (semantic-tag-name (car tags)))
- ,table)))
-
-(defmacro semantic-find-tags-by-class (class &optional table)
- "Find all tags of class CLASS in TABLE.
-CLASS is a symbol representing the class of the token, such as
-`variable' or `function'.
-TABLE is a tag table. See `semantic-something-to-tag-table'."
- `(semantic--find-tags-by-macro
- (eq ,class (semantic-tag-class (car tags)))
- ,table))
-
-(defmacro semantic-filter-tags-by-class (class &optional table)
- "Find all tags of class not in the list CLASS in TABLE.
-CLASS is a list of symbols representing the class of the token,
-such as `variable' or `function'.
-TABLE is a tag table. See `semantic-something-to-tag-table'."
- `(semantic--find-tags-by-macro
- (not (memq (semantic-tag-class (car tags)) ,class))
- ,table))
-
-(defmacro semantic-find-tags-by-type (type &optional table)
- "Find all tags of with a type TYPE in TABLE.
-TYPE is a string or tag representing a data type as defined in the
-language the tags were parsed from, such as \"int\", or perhaps
-a tag whose name is that of a struct or class.
-TABLE is a tag table. See `semantic-something-to-tag-table'."
- `(semantic--find-tags-by-macro
- (semantic-tag-of-type-p (car tags) ,type)
- ,table))
-
-(defmacro semantic-find-tags-of-compound-type (&optional table)
- "Find all tags which are a compound type in TABLE.
-Compound types are structures, or other data type which
-is not of a primitive nature, such as int or double.
-Used in completion."
- `(semantic--find-tags-by-macro
- (semantic-tag-type-compound-p (car tags))
- ,table))
-
-;;;###autoload
-(define-overloadable-function semantic-find-tags-by-scope-protection (scopeprotection parent &optional table)
- "Find all tags accessible by SCOPEPROTECTION.
-SCOPEPROTECTION is a symbol which can be returned by the method
-`semantic-tag-protection'. A hard-coded order is used to determine a match.
-PARENT is a tag representing the PARENT slot needed for
-`semantic-tag-protection'.
-TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil,
-the type members of PARENT are used.
-See `semantic-tag-protected-p' for details on which tags are returned."
- (if (not (eq (semantic-tag-class parent) 'type))
- (signal 'wrong-type-argument '(semantic-find-tags-by-scope-protection
- parent
- semantic-tag-class type))
- (:override)))
-
-(defun semantic-find-tags-by-scope-protection-default
- (scopeprotection parent &optional table)
- "Find all tags accessible by SCOPEPROTECTION.
-SCOPEPROTECTION is a symbol which can be returned by the method
-`semantic-tag-protection'. A hard-coded order is used to determine a match.
-PARENT is a tag representing the PARENT slot needed for
-`semantic-tag-protection'.
-TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil,
-the type members of PARENT are used.
-See `semantic-tag-protected-p' for details on which tags are returned."
- (if (not table) (setq table (semantic-tag-type-members parent)))
- (if (null scopeprotection)
- table
- (require 'semantic/tag-ls)
- (semantic--find-tags-by-macro
- (not (and (semantic-tag-protected-p (car tags) scopeprotection parent)
- (semantic-tag-package-protected-p (car tags) parent)))
- table)))
-
-;;;###autoload
-(define-overloadable-function semantic-find-tags-included (&optional table)
- "Find all tags in TABLE that are of the `include' class.
-TABLE is a tag table. See `semantic-something-to-tag-table'.")
-
-(defun semantic-find-tags-included-default (&optional table)
- "Find all tags in TABLE that are of the `include' class.
-TABLE is a tag table. See `semantic-something-to-tag-table'.
-By default, just call `semantic-find-tags-by-class'."
- (semantic-find-tags-by-class 'include table))
-
-;;; Deep Searches
-
-(defmacro semantic-deep-find-tags-by-name (name &optional table)
- "Find all tags with NAME in TABLE.
-Search in top level tags, and their components, in TABLE.
-NAME is a string.
-TABLE is a tag table. See `semantic-flatten-tags-table'.
-See also `semantic-find-tags-by-name'."
- `(semantic-find-tags-by-name
- ,name (semantic-flatten-tags-table ,table)))
-
-(defmacro semantic-deep-find-tags-for-completion (prefix &optional table)
- "Find all tags whose name begins with PREFIX in TABLE.
-Search in top level tags, and their components, in TABLE.
-TABLE is a tag table. See `semantic-flatten-tags-table'.
-See also `semantic-find-tags-for-completion'."
- `(semantic-find-tags-for-completion
- ,prefix (semantic-flatten-tags-table ,table)))
-
-(defmacro semantic-deep-find-tags-by-name-regexp (regexp &optional table)
- "Find all tags with name matching REGEXP in TABLE.
-Search in top level tags, and their components, in TABLE.
-REGEXP is a string containing a regular expression,
-TABLE is a tag table. See `semantic-flatten-tags-table'.
-See also `semantic-find-tags-by-name-regexp'.
-Consider using `semantic-deep-find-tags-for-completion' if you are
-attempting to do completions."
- `(semantic-find-tags-by-name-regexp
- ,regexp (semantic-flatten-tags-table ,table)))
-
-;;; Specialty Searches
-
-(defun semantic-find-tags-external-children-of-type (type &optional table)
- "Find all tags in whose parent is TYPE in TABLE.
-These tags are defined outside the scope of the original TYPE declaration.
-TABLE is a tag table. See `semantic-something-to-tag-table'."
- (semantic--find-tags-by-macro
- (equal (semantic-tag-external-member-parent (car tags))
- type)
- table))
-
-(defun semantic-find-tags-subclasses-of-type (type &optional table)
- "Find all tags of class type in whose parent is TYPE in TABLE.
-These tags are defined outside the scope of the original TYPE declaration.
-TABLE is a tag table. See `semantic-something-to-tag-table'."
- (semantic--find-tags-by-macro
- (and (eq (semantic-tag-class (car tags)) 'type)
- (or (member type (semantic-tag-type-superclasses (car tags)))
- (member type (semantic-tag-type-interfaces (car tags)))))
- table))
-\f
-;;
-;; ************************** Compatibility ***************************
-;;
-
-;;; Old Style Brute Force Search Routines
-;;
-;; These functions will search through tags lists explicitly for
-;; desired information.
-
-;; The -by-name nonterminal search can use the built in fcn
-;; `assoc', which is faster than looping ourselves, so we will
-;; not use `semantic-brute-find-tag-by-function' to do this,
-;; instead erroring on the side of speed.
-
-(defun semantic-brute-find-first-tag-by-name
- (name streamorbuffer &optional search-parts search-include)
- "Find a tag NAME within STREAMORBUFFER. NAME is a string.
-If SEARCH-PARTS is non-nil, search children of tags.
-If SEARCH-INCLUDE was never implemented.
-Respects `semantic-case-fold'.
-
-Use `semantic-find-first-tag-by-name' instead."
- (let* ((stream (semantic-something-to-tag-table streamorbuffer))
- (m (assoc-string name stream semantic-case-fold)))
- (if m
- m
- (let ((toklst stream)
- (children nil))
- (while (and (not m) toklst)
- (if search-parts
- (progn
- (setq children (semantic-tag-components-with-overlays
- (car toklst)))
- (if children
- (setq m (semantic-brute-find-first-tag-by-name
- name children search-parts search-include)))))
- (setq toklst (cdr toklst)))
- (if (not m)
- ;; Go to dependencies, and search there.
- nil)
- m))))
-
-(defmacro semantic-brute-find-tag-by-class
- (class streamorbuffer &optional search-parts search-includes)
- "Find all tags with a class CLASS within STREAMORBUFFER.
-CLASS is a symbol representing the class of the tags to find.
-See `semantic-tag-class'.
-Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
-`semantic-brute-find-tag-by-function'.
-
-Use `semantic-find-tag-by-class' instead."
- `(semantic-brute-find-tag-by-function
- (lambda (tag) (eq ,class (semantic-tag-class tag)))
- ,streamorbuffer ,search-parts ,search-includes))
-
-(defmacro semantic-brute-find-tag-standard
- (streamorbuffer &optional search-parts search-includes)
- "Find all tags in STREAMORBUFFER which define simple class types.
-See `semantic-tag-class'.
-Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
-`semantic-brute-find-tag-by-function'."
- `(semantic-brute-find-tag-by-function
- (lambda (tag) (member (semantic-tag-class tag)
- '(function variable type)))
- ,streamorbuffer ,search-parts ,search-includes))
-
-(defun semantic-brute-find-tag-by-type
- (type streamorbuffer &optional search-parts search-includes)
- "Find all tags with type TYPE within STREAMORBUFFER.
-TYPE is a string which is the name of the type of the tags returned.
-See `semantic-tag-type'.
-Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
-`semantic-brute-find-tag-by-function'."
- (semantic-brute-find-tag-by-function
- (lambda (tag)
- (let ((ts (semantic-tag-type tag)))
- (if (and (listp ts)
- (or (= (length ts) 1)
- (eq (semantic-tag-class ts) 'type)))
- (setq ts (semantic-tag-name ts)))
- (equal type ts)))
- streamorbuffer search-parts search-includes))
-
-(defun semantic-brute-find-tag-by-type-regexp
- (regexp streamorbuffer &optional search-parts search-includes)
- "Find all tags with type matching REGEXP within STREAMORBUFFER.
-REGEXP is a regular expression which matches the name of the type of the
-tags returned. See `semantic-tag-type'.
-Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
-`semantic-brute-find-tag-by-function'."
- (semantic-brute-find-tag-by-function
- (lambda (tag)
- (let ((ts (semantic-tag-type tag)))
- (if (listp ts)
- (setq ts
- (if (eq (semantic-tag-class ts) 'type)
- (semantic-tag-name ts)
- (car ts))))
- (and ts (string-match regexp ts))))
- streamorbuffer search-parts search-includes))
-
-(defun semantic-brute-find-tag-by-name-regexp
- (regex streamorbuffer &optional search-parts search-includes)
- "Find all tags whose name match REGEX in STREAMORBUFFER.
-Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
-`semantic-brute-find-tag-by-function'."
- (semantic-brute-find-tag-by-function
- (lambda (tag) (string-match regex (semantic-tag-name tag)))
- streamorbuffer search-parts search-includes)
- )
-
-(defun semantic-brute-find-tag-by-property
- (property value streamorbuffer &optional search-parts search-includes)
- "Find all tags with PROPERTY equal to VALUE in STREAMORBUFFER.
-Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
-`semantic-brute-find-tag-by-function'."
- (semantic-brute-find-tag-by-function
- (lambda (tag) (equal (semantic--tag-get-property tag property) value))
- streamorbuffer search-parts search-includes)
- )
-
-(defun semantic-brute-find-tag-by-attribute
- (attr streamorbuffer &optional search-parts search-includes)
- "Find all tags with a given ATTR in STREAMORBUFFER.
-ATTR is a symbol key into the attributes list.
-Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
-`semantic-brute-find-tag-by-function'."
- (semantic-brute-find-tag-by-function
- (lambda (tag) (semantic-tag-get-attribute tag attr))
- streamorbuffer search-parts search-includes)
- )
-
-(defun semantic-brute-find-tag-by-attribute-value
- (attr value streamorbuffer &optional search-parts search-includes)
- "Find all tags with a given ATTR equal to VALUE in STREAMORBUFFER.
-ATTR is a symbol key into the attributes list.
-VALUE is the value that ATTR should match.
-Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
-`semantic-brute-find-tag-by-function'."
- (semantic-brute-find-tag-by-function
- (lambda (tag) (equal (semantic-tag-get-attribute tag attr) value))
- streamorbuffer search-parts search-includes)
- )
-
-(defun semantic-brute-find-tag-by-function
- (function streamorbuffer &optional search-parts _search-includes)
- "Find all tags for which FUNCTION's value is non-nil within STREAMORBUFFER.
-FUNCTION must return non-nil if an element of STREAM will be included
-in the new list.
-
-If optional argument SEARCH-PARTS is non-nil, all sub-parts of tags
-are searched. The overloadable function `semantic-tag-components' is
-used for the searching child lists. If SEARCH-PARTS is the symbol
-`positiononly', then only children that have positional information are
-searched.
-
-If SEARCH-INCLUDES has not been implemented.
-This parameter hasn't be active for a while and is obsolete."
- (let ((stream (semantic-something-to-tag-table streamorbuffer))
- (sl nil) ;list of tag children
- (nl nil) ;new list
- (case-fold-search semantic-case-fold))
- (dolist (tag stream)
- (if (not (semantic-tag-p tag))
- ;; `semantic-tag-components-with-overlays' can return invalid
- ;; tags if search-parts is not equal to 'positiononly
- nil ;; Ignore them!
- (if (funcall function tag)
- (setq nl (cons tag nl)))
- (and search-parts
- (setq sl (if (eq search-parts 'positiononly)
- (semantic-tag-components-with-overlays tag)
- (semantic-tag-components tag))
- )
- (setq nl (nconc nl
- (semantic-brute-find-tag-by-function
- function sl
- search-parts))))))
- (setq nl (nreverse nl))
- nl))
-
-(defun semantic-brute-find-first-tag-by-function
- (function streamorbuffer &optional _search-parts _search-includes)
- "Find the first tag which FUNCTION match within STREAMORBUFFER.
-FUNCTION must return non-nil if an element of STREAM will be included
-in the new list.
-
-The following parameters were never implemented.
-
-If optional argument SEARCH-PARTS, all sub-parts of tags are searched.
-The overloadable function `semantic-tag-components' is used for
-searching.
-If SEARCH-INCLUDES is non-nil, then all include files are also
-searched for matches."
- (let ((stream (semantic-something-to-tag-table streamorbuffer))
- (found nil)
- (case-fold-search semantic-case-fold))
- (while (and (not found) stream)
- (if (funcall function (car stream))
- (setq found (car stream)))
- (setq stream (cdr stream)))
- found))
-
-
-;;; Old Positional Searches
-;;
-;; Are these useful anymore?
-;;
-(defun semantic-brute-find-tag-by-position (position streamorbuffer
- &optional nomedian)
- "Find a tag covering POSITION within STREAMORBUFFER.
-POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do
-the median calculation, and return nil."
- (save-excursion
- (if (markerp position) (set-buffer (marker-buffer position)))
- (let* ((stream (if (bufferp streamorbuffer)
- (with-current-buffer streamorbuffer
- (semantic-fetch-tags))
- streamorbuffer))
- (prev nil)
- (found nil))
- (while (and stream (not found))
- ;; perfect fit
- (if (and (>= position (semantic-tag-start (car stream)))
- (<= position (semantic-tag-end (car stream))))
- (setq found (car stream))
- ;; Median between to objects.
- (if (and prev (not nomedian)
- (>= position (semantic-tag-end prev))
- (<= position (semantic-tag-start (car stream))))
- (let ((median (/ (+ (semantic-tag-end prev)
- (semantic-tag-start (car stream)))
- 2)))
- (setq found
- (if (> position median)
- (car stream)
- prev)))))
- ;; Next!!!
- (setq prev (car stream)
- stream (cdr stream)))
- found)))
-
-(defun semantic-brute-find-innermost-tag-by-position
- (position streamorbuffer &optional nomedian)
- "Find a list of tags covering POSITION within STREAMORBUFFER.
-POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do
-the median calculation, and return nil.
-This function will find the topmost item, and recurse until no more
-details are available of findable."
- (let* ((returnme nil)
- (current (semantic-brute-find-tag-by-position
- position streamorbuffer nomedian))
- (nextstream (and current
- (if (eq (semantic-tag-class current) 'type)
- (semantic-tag-type-members current)
- nil))))
- (while nextstream
- (setq returnme (cons current returnme))
- (setq current (semantic-brute-find-tag-by-position
- position nextstream nomedian))
- (setq nextstream (and current
- ;; NOTE TO SELF:
- ;; Looking at this after several years away,
- ;; what does this do???
- (if (eq (semantic-tag-class current) 'token)
- (semantic-tag-type-members current)
- nil))))
- (nreverse (cons current returnme))))
-
-(provide 'semantic/find)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/find"
-;; End:
-
-;;; semantic/find.el ends here
+++ /dev/null
-;;; semantic/format.el --- Routines for formatting tags -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2005, 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Once a language file has been parsed into a TAG, it is often useful
-;; then display that tag information in browsers, completion engines, or
-;; help routines. The functions and setup in this file provide ways
-;; to reformat a tag into different standard output types.
-;;
-;; In addition, macros for setting up customizable variables that let
-;; the user choose their default format type are also provided.
-;;
-
-;;; Code:
-(require 'semantic)
-(require 'semantic/tag-ls)
-(require 'ezimage)
-
-(eval-when-compile (require 'semantic/find))
-
-;;; Tag to text overload functions
-;;
-;; abbreviations, prototypes, and coloring support.
-(defvar semantic-format-tag-functions
- '(semantic-format-tag-name
- semantic-format-tag-canonical-name
- semantic-format-tag-abbreviate
- semantic-format-tag-summarize
- semantic-format-tag-summarize-with-file
- semantic-format-tag-short-doc
- semantic-format-tag-prototype
- semantic-format-tag-concise-prototype
- semantic-format-tag-uml-abbreviate
- semantic-format-tag-uml-prototype
- semantic-format-tag-uml-concise-prototype
- semantic-format-tag-prin1
- )
- "List of functions which convert a tag to text.
-Each function must take the parameters TAG &optional PARENT COLOR.
-TAG is the tag to convert.
-PARENT is a parent tag or name which refers to the structure
-or class which contains TAG. PARENT is NOT a class which a TAG
-would claim as a parent.
-COLOR indicates that the generated text should be colored using
-`font-lock'.")
-
-(defvar semantic-format-tag-custom-list
- (append '(radio)
- (mapcar (lambda (f) (list 'function-item f))
- semantic-format-tag-functions)
- '(function))
- "A List used by customizable variables to choose a tag to text function.
-Use this variable in the :type field of a customizable variable.")
-
-(defcustom semantic-format-use-images-flag ezimage-use-images
- "Non-nil means semantic format functions use images.
-Images can be used as icons instead of some types of text strings."
- :group 'semantic
- :type 'boolean)
-
-(defvar-local semantic-function-argument-separator ","
- "Text used to separate arguments when creating text from tags.")
-
-(defvar-local semantic-format-parent-separator "::"
- "Text used to separate names when between namespaces/classes and functions.")
-
-(defvar semantic-format-face-alist
- `( (function . font-lock-function-name-face)
- (variable . font-lock-variable-name-face)
- (type . font-lock-type-face)
- ;; These are different between Emacsen.
- (include . ,'font-lock-constant-face)
- (package . , 'font-lock-constant-face)
- ;; Not a tag, but instead a feature of output
- (label . font-lock-string-face)
- (comment . font-lock-comment-face)
- (keyword . font-lock-keyword-face)
- (abstract . italic)
- (static . underline)
- (documentation . font-lock-doc-face)
- )
- "Face used to colorize tags of different types.
-Override the value locally if a language supports other tag types.
-When adding new elements, try to use symbols also returned by the parser.
-The form of an entry in this list is of the form:
- ( SYMBOL . FACE )
-where SYMBOL is a tag type symbol used with semantic, and FACE
-is a symbol representing a face.
-Faces used are generated in `font-lock' for consistency, and will not
-be used unless font lock is a feature.")
-
-\f
-;;; Coloring Functions
-;;
-(defun semantic--format-colorize-text (text face-class)
- "Apply onto TEXT a color associated with FACE-CLASS.
-FACE-CLASS is a tag type found in `semantic-format-face-alist'.
-See that variable for details on adding new types."
- (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
- (newtext (concat text)))
- (put-text-property 0 (length text) 'face face newtext)
- newtext))
-
-(defun semantic--format-colorize-merge-text (precoloredtext face-class)
- "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS.
-FACE-CLASS is a tag type found in `semantic-format-face-alist'.
-See that variable for details on adding new types."
- (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
- (newtext (concat precoloredtext)))
- (alter-text-property 0 (length newtext) 'face
- (lambda (current-face)
- (let ((cf
- (cond ((facep current-face)
- (list current-face))
- ((listp current-face)
- current-face)
- (t nil)))
- (nf
- (cond ((facep face)
- (list face))
- ((listp face)
- face)
- (t nil))))
- (append cf nf)))
- newtext)
- newtext))
-
-;;; Function Arguments
-;;
-(defun semantic--format-tag-arguments (args formatter color)
- "Format the argument list ARGS with FORMATTER.
-FORMATTER is a function used to format a tag.
-COLOR specifies if color should be used."
- (let ((out nil))
- (while args
- (push (if (and formatter
- (semantic-tag-p (car args))
- (not (string= (semantic-tag-name (car args)) ""))
- )
- (funcall formatter (car args) nil color)
- (semantic-format-tag-name-from-anything
- (car args) nil color 'variable))
- out)
- (setq args (cdr args)))
- (mapconcat #'identity (nreverse out) semantic-function-argument-separator)
- ))
-
-;;; Data Type
-(define-overloadable-function semantic-format-tag-type (tag color)
- "Convert the data type of TAG to a string usable in tag formatting.
-It is presumed that TYPE is a string or semantic tag.")
-
-(defun semantic-format-tag-type-default (tag color)
- "Convert the data type of TAG to a string usable in tag formatting.
-Argument COLOR specifies to colorize the text."
- (let* ((type (semantic-tag-type tag))
- (out (cond ((semantic-tag-p type)
- (let* ((typetype (semantic-tag-type type))
- (name (semantic-tag-name type))
- (str (if typetype
- (concat typetype " " name)
- name)))
- (if color
- (semantic--format-colorize-text
- str
- 'type)
- str)))
- ((and (listp type)
- (stringp (car type)))
- (car type))
- ((stringp type)
- type)
- (t nil))))
- (if (and color out)
- (setq out (semantic--format-colorize-text out 'type))
- out)
- ))
-
-\f
-;;; Abstract formatting functions
-;;
-
-(defun semantic-format-tag-prin1 (tag &optional _parent _color)
- "Convert TAG to a string that is the print name for TAG.
-PARENT and COLOR are ignored."
- (format "%S" tag))
-
-(defun semantic-format-tag-name-from-anything (anything &optional
- parent color
- colorhint)
- "Convert just about anything into a name like string.
-Argument ANYTHING is the thing to be converted.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.
-Optional COLORHINT is the type of color to use if ANYTHING is not a tag
-with a tag class. See `semantic--format-colorize-text' for a definition
-of FACE-CLASS for which this is used."
- (cond ((stringp anything)
- (semantic--format-colorize-text anything colorhint))
- ((semantic-tag-p anything)
- (let ((ans (semantic-format-tag-name anything parent color)))
- ;; If ANS is empty string or nil, then the name wasn't
- ;; supplied. The implication is as in C where there is a data
- ;; type but no name for a prototype from an include file, or
- ;; an argument just wasn't used in the body of the fcn.
- (if (or (null ans) (string= ans ""))
- (setq ans (semantic-format-tag-type anything color)))
- ans))
- ((and (listp anything)
- (stringp (car anything)))
- (semantic--format-colorize-text (car anything) colorhint))))
-
-;;;###autoload
-(define-overloadable-function semantic-format-tag-name (tag &optional parent color)
- "Return the name string describing TAG.
-The name is the shortest possible representation.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(defun semantic-format-tag-name-default (tag &optional _parent color)
- "Return an abbreviated string describing TAG.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors."
- (let ((name (semantic-tag-name tag))
- (destructor
- (if (eq (semantic-tag-class tag) 'function)
- (semantic-tag-function-destructor-p tag))))
- (when destructor
- (setq name (concat "~" name)))
- (if color
- (setq name (semantic--format-colorize-text name (semantic-tag-class tag))))
- name))
-
-(declare-function semantic-go-to-tag "semantic/tag-file")
-
-(defun semantic--format-tag-parent-tree (tag parent)
- "Under Consideration.
-
-Return a list of parents for TAG.
-PARENT is the first parent, or nil. If nil, then an attempt to
-determine PARENT is made.
-Once PARENT is identified, additional parents are looked for.
-The return list first element is the nearest parent, and the last
-item is the first parent which may be a string. The root parent may
-not be the actual first parent as there may just be a failure to find
-local definitions."
- ;; First, validate the PARENT argument.
- (unless parent
- ;; All mechanisms here must be fast as often parent
- ;; is nil because there isn't one.
- (setq parent (or (semantic-tag-function-parent tag)
- (save-excursion
- (require 'semantic/tag-file)
- (semantic-go-to-tag tag)
- (semantic-current-tag-parent)))))
- (when (stringp parent)
- (setq parent (semantic-find-first-tag-by-name
- parent (current-buffer))))
- ;; Try and find a trail of parents from PARENT
- (let ((rlist (list parent))
- )
- ;; IMPLEMENT ME!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
- (reverse rlist)))
-
-(define-overloadable-function semantic-format-tag-canonical-name (tag &optional parent color)
- "Return a canonical name for TAG.
-A canonical name includes the names of any parents or namespaces preceding
-the tag.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(defun semantic-format-tag-canonical-name-default (tag &optional parent color)
- "Return a canonical name for TAG.
-A canonical name includes the names of any parents or namespaces preceding
-the tag with colons separating them.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors."
- (let ((parent-input-str
- (if (and parent
- (semantic-tag-p parent)
- (semantic-tag-of-class-p parent 'type))
- (concat
- ;; Choose a class of 'type as the default parent for something.
- ;; Just a guess though.
- (semantic-format-tag-name-from-anything parent nil color 'type)
- ;; Default separator between class/namespace and others.
- semantic-format-parent-separator)
- ""))
- (tag-parent-str
- (or (when (and (semantic-tag-of-class-p tag 'function)
- (semantic-tag-function-parent tag))
- (concat (semantic-tag-function-parent tag)
- semantic-format-parent-separator))
- ""))
- )
- (concat parent-input-str
- tag-parent-str
- (semantic-format-tag-name tag parent color))
- ))
-
-(define-overloadable-function semantic-format-tag-abbreviate (tag &optional parent color)
- "Return an abbreviated string describing TAG.
-The abbreviation is to be short, with possible symbols indicating
-the type of tag, or other information.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(defun semantic-format-tag-abbreviate-default (tag &optional parent color)
- "Return an abbreviated string describing TAG.
-Optional argument PARENT is a parent tag in the tag hierarchy.
-In this case PARENT refers to containment, not inheritance.
-Optional argument COLOR means highlight the prototype with font-lock colors.
-This is a simple C like default."
- ;; Do lots of complex stuff here.
- (let ((class (semantic-tag-class tag))
- (name (semantic-format-tag-canonical-name tag parent color))
- (suffix "")
- (prefix "")
- str)
- (cond ((eq class 'function)
- (setq suffix "()"))
- ((eq class 'include)
- (setq suffix "<>"))
- ((eq class 'variable)
- (setq suffix (if (semantic-tag-variable-default tag)
- "=" "")))
- ((eq class 'label)
- (setq suffix ":"))
- ((eq class 'code)
- (setq prefix "{"
- suffix "}"))
- ((eq class 'type)
- (setq suffix "{}"))
- )
- (setq str (concat prefix name suffix))
- str))
-
-;;;###autoload
-(define-overloadable-function semantic-format-tag-summarize (tag &optional parent color)
- "Summarize TAG in a reasonable way.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(defun semantic-format-tag-summarize-default (tag &optional parent color)
- "Summarize TAG in a reasonable way.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors."
- (let* ((proto (semantic-format-tag-prototype tag nil color))
- (names (if parent
- semantic-symbol->name-assoc-list-for-type-parts
- semantic-symbol->name-assoc-list))
- (tsymb (semantic-tag-class tag))
- (label (capitalize (or (cdr-safe (assoc tsymb names))
- (symbol-name tsymb)))))
- (if color
- (setq label (semantic--format-colorize-text label 'label)))
- (concat label ": " proto)))
-
-(define-overloadable-function semantic-format-tag-summarize-with-file (tag &optional parent color)
- "Like `semantic-format-tag-summarize', but with the file name.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(defun semantic-format-tag-summarize-with-file-default (tag &optional parent color)
- "Summarize TAG in a reasonable way.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors."
- (let* ((proto (semantic-format-tag-prototype tag nil color))
- (file (semantic-tag-file-name tag))
- )
- ;; Nothing for tag? Try parent.
- (when (and (not file) (and parent))
- (setq file (semantic-tag-file-name parent)))
- ;; Don't include the file name if we can't find one, or it is the
- ;; same as the current buffer.
- (if (or (not file)
- (string= file (buffer-file-name (current-buffer))))
- proto
- (setq file (file-name-nondirectory file))
- (when color
- (setq file (semantic--format-colorize-text file 'label)))
- (concat file ": " proto))))
-
-(define-overloadable-function semantic-format-tag-short-doc (tag &optional parent color)
- "Display a short form of TAG's documentation. (Comments, or docstring.)
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(declare-function semantic-documentation-for-tag "semantic/doc")
-
-(defun semantic-format-tag-short-doc-default (tag &optional parent color)
- "Display a short form of TAG's documentation. (Comments, or docstring.)
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors."
- (let* ((fname (or (semantic-tag-file-name tag)
- (when parent (semantic-tag-file-name parent))))
- (buf (or (semantic-tag-buffer tag)
- (when parent (semantic-tag-buffer parent))))
- (doc (semantic-tag-docstring tag buf)))
- (when (and (not doc) (not buf) fname)
- ;; If there is no doc, and no buffer, but we have a filename,
- ;; let's try again.
- (save-match-data
- (setq buf (find-file-noselect fname)))
- (setq doc (semantic-tag-docstring tag buf)))
- (when (not doc)
- (require 'semantic/doc)
- (setq doc (semantic-documentation-for-tag tag))
- )
- (setq doc
- (if (not doc)
- ;; No doc, use summarize.
- (semantic-format-tag-summarize tag parent color)
- ;; We have doc. Can we devise a single line?
- (if (string-match "$" doc)
- (substring doc 0 (match-beginning 0))
- doc)
- ))
- (when color
- (setq doc (semantic--format-colorize-text doc 'documentation)))
- doc
- ))
-
-;;; Prototype generation
-;;
-;;;###autoload
-(define-overloadable-function semantic-format-tag-prototype (tag &optional parent color)
- "Return a prototype for TAG.
-This function should be overloaded, though it need not be used.
-This is because it can be used to create code by language independent
-tools.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(defun semantic-format-tag-prototype-default (tag &optional parent color)
- "Default method for returning a prototype for TAG.
-This will work for C like languages.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors."
- (let* ((class (semantic-tag-class tag))
- (name (semantic-format-tag-name tag parent color))
- (type (if (member class '(function variable type))
- (semantic-format-tag-type tag color)))
- (args (if (member class '(function type))
- (semantic--format-tag-arguments
- (if (eq class 'function)
- (semantic-tag-function-arguments tag)
- (list "")
- ;;(semantic-tag-type-members tag)
- )
- #'semantic-format-tag-prototype
- color)))
- (const (semantic-tag-get-attribute tag :constant-flag))
- (tm (semantic-tag-get-attribute tag :typemodifiers))
- (mods (append
- (if const '("const") nil)
- (cond ((stringp tm) (list tm))
- ((consp tm) tm)
- (t nil))
- ))
- (array (if (eq class 'variable)
- (let ((deref
- (semantic-tag-get-attribute
- tag :dereference))
- (r ""))
- (while (and deref (/= deref 0))
- (setq r (concat r "[]")
- deref (1- deref)))
- r)))
- (default (when (eq class 'variable)
- (let ((defval
- (semantic-tag-get-attribute tag :default-value)))
- (when (and defval (stringp defval))
- (concat "[=" defval "]")))))
- )
- (if args
- (setq args
- (concat " "
- (if (eq class 'type) "{" "(")
- args
- (if (eq class 'type) "}" ")"))))
- (when mods
- (setq mods (concat (mapconcat #'identity mods " ") " ")))
- (concat (or mods "")
- (if type (concat type " "))
- name
- (or args "")
- (or array "")
- (or default ""))))
-
-;;;###autoload
-(define-overloadable-function semantic-format-tag-concise-prototype (tag &optional parent color)
- "Return a concise prototype for TAG.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(defun semantic-format-tag-concise-prototype-default (tag &optional parent color)
- "Return a concise prototype for TAG.
-This default function will make a cheap concise prototype using C like syntax.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors."
- (let ((class (semantic-tag-class tag)))
- (cond
- ((eq class 'type)
- (concat (semantic-format-tag-name tag parent color) "{}"))
- ((eq class 'function)
- (concat (semantic-format-tag-name tag parent color)
- " ("
- (semantic--format-tag-arguments
- (semantic-tag-function-arguments tag)
- 'semantic-format-tag-concise-prototype
- color)
- ")"))
- ((eq class 'variable)
- (let* ((deref (semantic-tag-get-attribute
- tag :dereference))
- (array "")
- )
- (while (and deref (/= deref 0))
- (setq array (concat array "[]")
- deref (1- deref)))
- (concat (semantic-format-tag-name tag parent color)
- array)))
- (t
- (semantic-format-tag-abbreviate tag parent color)))))
-
-;;; UML display styles
-;;
-(defcustom semantic-uml-colon-string " : "
- "String used as a color separator between parts of a UML string.
-In UML, a variable may appear as `varname : type'.
-Change this variable to change the output separator."
- :group 'semantic
- :type 'string)
-
-(defcustom semantic-uml-no-protection-string ""
- "String used to describe when no protection is specified.
-Used by `semantic-format-tag-uml-protection-to-string'."
- :group 'semantic
- :type 'string)
-
-(defun semantic--format-uml-post-colorize (text tag parent)
- "Add color to TEXT created from TAG and PARENT.
-Adds augmentation for `abstract' and `static' entries."
- (if (semantic-tag-abstract-p tag parent)
- (setq text (semantic--format-colorize-merge-text text 'abstract)))
- (if (semantic-tag-static-p tag parent)
- (setq text (semantic--format-colorize-merge-text text 'static)))
- text
- )
-
-(defun semantic-uml-attribute-string (tag &optional parent)
- "Return a string for TAG, a child of PARENT representing a UML attribute.
-UML attribute strings are things like {abstract} or {leaf}."
- (cond ((semantic-tag-abstract-p tag parent)
- "{abstract}")
- ((semantic-tag-leaf-p tag parent)
- "{leaf}")
- ))
-
-(defvar semantic-format-tag-protection-image-alist
- '(("+" . ezimage-unlock)
- ("#" . ezimage-key)
- ("-" . ezimage-lock)
- )
- "Association of protection strings, and images to use.")
-
-(defvar semantic-format-tag-protection-symbol-to-string-assoc-list
- '((public . "+")
- (protected . "#")
- (private . "-")
- )
- "Association list of the form (SYMBOL . \"STRING\") for protection symbols.
-For example, it might associate the symbol `public' with the string \"+\".")
-
-(define-overloadable-function semantic-format-tag-uml-protection-to-string (protection-symbol color)
- "Convert PROTECTION-SYMBOL to a string for UML.
-By default, uses `semantic-format-tag-protection-symbol-to-string-assoc-list'
-to convert.
-By default character returns are:
- public -- +
- private -- -
- protected -- #.
-If PROTECTION-SYMBOL is unknown, then the return value is
-`semantic-uml-no-protection-string'.
-COLOR indicates if we should use an image on the text.")
-
-(defun semantic-format-tag-uml-protection-to-string-default (protection-symbol color)
- "Convert PROTECTION-SYMBOL to a string for UML.
-Uses `semantic-format-tag-protection-symbol-to-string-assoc-list' to convert.
-If PROTECTION-SYMBOL is unknown, then the return value is
-`semantic-uml-no-protection-string'.
-COLOR indicates if we should use an image on the text."
- (let* ((ezimage-use-images (and semantic-format-use-images-flag color))
- (key (assoc protection-symbol
- semantic-format-tag-protection-symbol-to-string-assoc-list))
- (str (or (cdr-safe key) semantic-uml-no-protection-string)))
- (ezimage-image-over-string
- (copy-sequence str) ; make a copy to keep the original pristine.
- semantic-format-tag-protection-image-alist)))
-
-(defsubst semantic-format-tag-uml-protection (tag parent color)
- "Retrieve the protection string for TAG with PARENT.
-Argument COLOR specifies that color should be added to the string as
-needed."
- (semantic-format-tag-uml-protection-to-string
- (semantic-tag-protection tag parent)
- color))
-
-(defun semantic--format-tag-uml-type (tag color)
- "Format the data type of TAG to a string usable for formatting.
-COLOR indicates if it should be colorized."
- (let ((str (semantic-format-tag-type tag color)))
- (if str
- (concat semantic-uml-colon-string str))))
-
-(define-overloadable-function semantic-format-tag-uml-abbreviate (tag &optional parent color)
- "Return a UML style abbreviation for TAG.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(defun semantic-format-tag-uml-abbreviate-default (tag &optional parent color)
- "Return a UML style abbreviation for TAG.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors."
- (let* ((name (semantic-format-tag-name tag parent color))
- (type (semantic--format-tag-uml-type tag color))
- (protstr (semantic-format-tag-uml-protection tag parent color))
- (text nil))
- (setq text
- (concat
- protstr
- (if type (concat name type)
- name)))
- (if color
- (setq text (semantic--format-uml-post-colorize text tag parent)))
- text))
-
-(define-overloadable-function semantic-format-tag-uml-prototype (tag &optional parent color)
- "Return a UML style prototype for TAG.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(defun semantic-format-tag-uml-prototype-default (tag &optional parent color)
- "Return a UML style prototype for TAG.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors."
- (let* ((class (semantic-tag-class tag))
- (cp (semantic-format-tag-name tag parent color))
- (type (semantic--format-tag-uml-type tag color))
- (prot (semantic-format-tag-uml-protection tag parent color))
- (argtext
- (cond ((eq class 'function)
- (concat
- " ("
- (semantic--format-tag-arguments
- (semantic-tag-function-arguments tag)
- #'semantic-format-tag-uml-prototype
- color)
- ")"))
- ((eq class 'type)
- "{}")))
- (text nil))
- (setq text (concat prot cp argtext type))
- (if color
- (setq text (semantic--format-uml-post-colorize text tag parent)))
- text
- ))
-
-(define-overloadable-function semantic-format-tag-uml-concise-prototype (tag &optional parent color)
- "Return a UML style concise prototype for TAG.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors.")
-
-(defun semantic-format-tag-uml-concise-prototype-default (tag &optional parent color)
- "Return a UML style concise prototype for TAG.
-Optional argument PARENT is the parent type if TAG is a detail.
-Optional argument COLOR means highlight the prototype with font-lock colors."
- (let* ((cp (semantic-format-tag-concise-prototype tag parent color))
- (type (semantic--format-tag-uml-type tag color))
- (prot (semantic-format-tag-uml-protection tag parent color))
- (text nil)
- )
- (setq text (concat prot cp type))
- (if color
- (setq text (semantic--format-uml-post-colorize text tag parent)))
- text))
-
-(provide 'semantic/format)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/format"
-;; End:
-
-;;; semantic/format.el ends here
+++ /dev/null
-;;; semantic/fw.el --- Framework for Semantic -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic has several core features shared across it's lex/parse/util
-;; stages. This used to clutter semantic.el some. These routines are all
-;; simple things that are not parser specific, but aid in making
-;; semantic flexible and compatible amongst different Emacs platforms.
-
-;;; Code:
-;;
-(require 'mode-local)
-(require 'eieio)
-(load "semantic/loaddefs" 'noerror 'nomessage)
-
-;;; Compatibility
-;;
-(define-obsolete-function-alias 'semantic-overlay-live-p #'overlay-buffer "27.1")
-(define-obsolete-function-alias 'semantic-make-overlay #'make-overlay "27.1")
-(define-obsolete-function-alias 'semantic-overlay-put #'overlay-put "27.1")
-(define-obsolete-function-alias 'semantic-overlay-get #'overlay-get "27.1")
-(define-obsolete-function-alias 'semantic-overlay-properties
- #'overlay-properties "27.1")
-(define-obsolete-function-alias 'semantic-overlay-move #'move-overlay "27.1")
-(define-obsolete-function-alias 'semantic-overlay-delete #'delete-overlay "27.1")
-(define-obsolete-function-alias 'semantic-overlays-at #'overlays-at "27.1")
-(define-obsolete-function-alias 'semantic-overlays-in #'overlays-in "27.1")
-(define-obsolete-function-alias 'semantic-overlay-buffer #'overlay-buffer "27.1")
-(define-obsolete-function-alias 'semantic-overlay-start #'overlay-start "27.1")
-(define-obsolete-function-alias 'semantic-overlay-end #'overlay-end "27.1")
-(define-obsolete-function-alias 'semantic-overlay-next-change
- #'next-overlay-change "27.1")
-(define-obsolete-function-alias 'semantic-overlay-previous-change
- #'previous-overlay-change "27.1")
-(define-obsolete-function-alias 'semantic-overlay-lists #'overlay-lists "27.1")
-(define-obsolete-function-alias 'semantic-overlay-p #'overlayp "27.1")
-(define-obsolete-function-alias 'semantic-read-event #'read-event "27.1")
-(define-obsolete-function-alias 'semantic-popup-menu #'popup-menu "27.1")
-(define-obsolete-function-alias 'semantic-buffer-local-value
- #'buffer-local-value "27.1")
-
-(defun semantic-event-window (event)
- "Extract the window from EVENT."
- (car (car (cdr event))))
-
-(define-obsolete-function-alias 'semantic-make-local-hook #'identity "27.1")
-
-(defalias 'semantic-mode-line-update #'force-mode-line-update)
-
-(define-obsolete-function-alias 'semantic-run-mode-hooks #'run-mode-hooks "28.1")
-
-;; Fancy compat usage now handled in cedet-compat
-(define-obsolete-function-alias 'semantic-subst-char-in-string
- #'subst-char-in-string "28.1")
-
-(defun semantic-delete-overlay-maybe (overlay)
- "Delete OVERLAY if it is a semantic token overlay."
- (if (overlay-get overlay 'semantic)
- (delete-overlay overlay)))
-
-;;; Menu Item compatibility
-;;
-(define-obsolete-function-alias 'semantic-menu-item #'identity "27.1")
-
-;;; Positional Data Cache
-;;
-(defvar semantic-cache-data-overlays nil
- "List of all overlays waiting to be flushed.")
-
-(defun semantic-cache-data-to-buffer (buffer start end value name &optional lifespan)
- "In BUFFER over the region START END, remember VALUE.
-NAME specifies a special name that can be searched for later to
-recover the cached data with `semantic-get-cache-data'.
-LIFESPAN indicates how long the data cache will be remembered.
-The default LIFESPAN is `end-of-command'.
-Possible Lifespans are:
- `end-of-command' - Remove the cache at the end of the currently
- executing command.
- `exit-cache-zone' - Remove when point leaves the overlay at the
- end of the currently executing command."
- ;; Check if LIFESPAN is valid before to create any overlay
- (or lifespan (setq lifespan 'end-of-command))
- (or (memq lifespan '(end-of-command exit-cache-zone))
- (error "semantic-cache-data-to-buffer: Unknown LIFESPAN: %s"
- lifespan))
- (let ((o (make-overlay start end buffer)))
- (overlay-put o 'cache-name name)
- (overlay-put o 'cached-value value)
- (overlay-put o 'lifespan lifespan)
- (setq semantic-cache-data-overlays
- (cons o semantic-cache-data-overlays))
- ;;(message "Adding to cache: %s" o)
- (add-hook 'post-command-hook #'semantic-cache-data-post-command-hook)
- ))
-
-(defun semantic-cache-data-post-command-hook ()
- "Flush `semantic-cache-data-overlays' based `lifespan' property.
-Remove self from `post-command-hook' if it is empty."
- (let ((newcache nil)
- (oldcache semantic-cache-data-overlays))
- (while oldcache
- (let* ((o (car oldcache))
- (life (overlay-get o 'lifespan))
- )
- (if (or (eq life 'end-of-command)
- (and (eq life 'exit-cache-zone)
- (not (member o (overlays-at (point))))))
- (progn
- ;;(message "Removing from cache: %s" o)
- (delete-overlay o)
- )
- (setq newcache (cons o newcache))))
- (setq oldcache (cdr oldcache)))
- (setq semantic-cache-data-overlays (nreverse newcache)))
-
- ;; Remove ourselves if we have removed all overlays.
- (unless semantic-cache-data-overlays
- (remove-hook 'post-command-hook
- #'semantic-cache-data-post-command-hook)))
-
-(defun semantic-get-cache-data (name &optional point)
- "Get cached data with NAME from optional POINT."
- (save-excursion
- (if point (goto-char point))
- (let ((o (overlays-at (point)))
- (ans nil))
- (while (and (not ans) o)
- (if (equal (overlay-get (car o) 'cache-name) name)
- (setq ans (car o))
- (setq o (cdr o))))
- (when ans
- (overlay-get ans 'cached-value)))))
-
-(defun semantic-test-data-cache ()
- "Test the data cache."
- (interactive)
- (let ((data '(a b c)))
- (save-current-buffer
- (set-buffer (get-buffer-create " *semantic-test-data-cache*"))
- (save-excursion
- (erase-buffer)
- (insert "The Moose is Loose")
- (goto-char (point-min))
- (semantic-cache-data-to-buffer (current-buffer) (point) (+ (point) 5)
- data 'moose 'exit-cache-zone)
- (if (equal (semantic-get-cache-data 'moose) data)
- (message "Successfully retrieved cached data.")
- (error "Failed to retrieve cached data"))
- ))))
-
-;;; Obsoleting various functions & variables
-;;
-(defun semantic-overload-symbol-from-function (name)
- "Return the symbol for overload used by NAME, the defined symbol."
- (declare (obsolete define-obsolete-function-alias "28.1"))
- (let ((sym-name (symbol-name name)))
- (if (string-match "^semantic-" sym-name)
- (intern (substring sym-name (match-end 0)))
- name)))
-
-(defun semantic-alias-obsolete (oldfnalias newfn when)
- "Make OLDFNALIAS an alias for NEWFN.
-Mark OLDFNALIAS as obsolete, such that the byte compiler
-will throw a warning when it encounters this symbol."
- (declare (obsolete define-obsolete-function-alias "28.1"))
- (defalias oldfnalias newfn)
- (make-obsolete oldfnalias newfn when)
- (when (and (mode-local--function-overload-p newfn)
- (not (mode-local--overload-obsoleted-by newfn))
- ;; Only throw this warning when byte compiling things.
- (macroexp-compiling-p)
- (not (string-match "cedet" (macroexp-file-name)))
- )
- (make-obsolete-overload oldfnalias newfn when)
- (if (fboundp 'byte-compile-warn-x)
- (byte-compile-warn-x
- newfn
- "%s: `%s' obsoletes overload `%s'"
- (macroexp-file-name)
- newfn
- (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function))
- (semantic-overload-symbol-from-function oldfnalias)))
- (byte-compile-warn
- "%s: `%s' obsoletes overload `%s'"
- (macroexp-file-name)
- newfn
- (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function))
- (semantic-overload-symbol-from-function oldfnalias))))))
-
-(defun semantic-varalias-obsolete (oldvaralias newvar when)
- "Make OLDVARALIAS an alias for variable NEWVAR.
-Mark OLDVARALIAS as obsolete, such that the byte compiler
-will throw a warning when it encounters this symbol."
- (declare (obsolete define-obsolete-variable-alias "28.1"))
- (make-obsolete-variable oldvaralias newvar when)
- (condition-case nil
- (defvaralias oldvaralias newvar)
- (error
- ;; Only throw this warning when byte compiling things.
- (when (macroexp-compiling-p)
- (if (fboundp 'byte-compile-warn-x)
- (byte-compile-warn-x
- newvar
- "variable `%s' obsoletes, but isn't alias of `%s'"
- newvar oldvaralias)
- (byte-compile-warn
- "variable `%s' obsoletes, but isn't alias of `%s'"
- newvar oldvaralias))))))
-\f
-;;; Help debugging
-;;
-(defmacro semantic-safe (format &rest body)
- "Turn into a FORMAT message any error caught during eval of BODY.
-Return the value of last BODY form or nil if an error occurred.
-FORMAT can have a %s escape which will be replaced with the actual
-error message.
-If `debug-on-error' is set, errors are not caught, so that you can
-debug them.
-Avoid using a large BODY since it is duplicated."
- (declare (debug t) (indent 1))
- `(if debug-on-error
- ;;(let ((inhibit-quit nil)) ,@body)
- ;; Note to self: Doing the above screws up the wisent parser.
- (progn ,@body)
- (condition-case err
- (progn ,@body)
- (error
- (message ,format (format "%S - %s" (current-buffer)
- (error-message-string err)))
- nil))))
-
-;;; Misc utilities
-;;
-
-(defvar-local semantic-new-buffer-fcn-was-run nil
- "Non-nil after `semantic-new-buffer-fcn' has been executed.")
-
-(defsubst semantic-active-p ()
- "Return non-nil if the current buffer was set up for parsing."
- semantic-new-buffer-fcn-was-run)
-
-(defsubst semantic-map-buffers (function)
- "Run FUNCTION for each Semantic enabled buffer found.
-FUNCTION does not have arguments. When FUNCTION is entered
-`current-buffer' is a selected Semantic enabled buffer."
- (mode-local-map-file-buffers function #'semantic-active-p))
-
-(defalias 'semantic-map-mode-buffers #'mode-local-map-mode-buffers)
-
-(defun semantic-install-function-overrides (overrides &optional transient)
- "Install the function OVERRIDES in the specified environment.
-OVERRIDES must be an alist ((OVERLOAD . FUNCTION) ...) where OVERLOAD
-is a symbol identifying an overloadable entry, and FUNCTION is the
-function to override it with.
-If optional argument TRANSIENT is non-nil, installed overrides can in
-turn be overridden by next installation.
-If optional argument MODE is non-nil, it must be a major mode symbol.
-OVERRIDES will be installed globally for this major mode. If MODE is
-nil, OVERRIDES will be installed locally in the current buffer. This
-later installation should be done in MODE hook."
- (mode-local-bind
- ;; Add the semantic- prefix to OVERLOAD short names.
- (mapcar
- (lambda (e)
- (let ((name (symbol-name (car e))))
- (if (string-match "^semantic-" name)
- e
- (cons (intern (format "semantic-%s" name)) (cdr e)))))
- overrides)
- (list 'constant-flag (not transient)
- 'override-flag t)
- nil))
-\f
-;;; User Interrupt handling
-;;
-(defvar semantic-current-input-throw-symbol nil
- "The current throw symbol for `semantic-exit-on-input'.")
-(defvar semantic--on-input-start-marker nil
- "The marker when starting a `semantic-exit-on-input' form.")
-
-(defmacro semantic-exit-on-input (symbol &rest forms)
- "Using SYMBOL as an argument to `throw', execute FORMS.
-If FORMS includes a call to `semantic-throw-on-input', then
-if a user presses any key during execution, this form macro
-will exit with the value passed to `semantic-throw-on-input'.
-If FORMS completes, then the return value is the same as `progn'."
- (declare (indent 1) (debug def-body))
- `(let ((semantic-current-input-throw-symbol ,symbol)
- (semantic--on-input-start-marker (point-marker)))
- (catch ,symbol
- ,@forms)))
-
-(defmacro semantic-throw-on-input (from)
- "Exit with `throw' when in `semantic-exit-on-input' on user input.
-FROM is an indication of where this function is called from as a value
-to pass to `throw'. It is recommended to use the name of the function
-calling this one."
- `(when (and semantic-current-input-throw-symbol
- (or (input-pending-p)
- (with-current-buffer
- (marker-buffer semantic--on-input-start-marker)
- ;; Timers might run during accept-process-output.
- ;; If they redisplay, point must be where the user
- ;; expects. (Bug#15045)
- (save-excursion
- (goto-char semantic--on-input-start-marker)
- (accept-process-output)))))
- (throw semantic-current-input-throw-symbol ,from)))
-
-\f
-;;; Special versions of Find File
-;;
-(defvar recentf-exclude)
-(defvar semantic-init-hook)
-(defvar ede-auto-add-method)
-(defvar flymake-start-syntax-check-on-find-file)
-(defvar auto-insert)
-
-(defun semantic-find-file-noselect (file &optional nowarn rawfile wildcards)
- "Call `find-file-noselect' with various features turned off.
-Use this when referencing a file that will be soon deleted.
-FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'."
- (let* ((recentf-exclude '(always))
- ;; This is a brave statement. Don't waste time loading in
- ;; lots of modes. Especially decoration mode can waste a lot
- ;; of time for a buffer we intend to kill.
- (semantic-init-hook nil)
- ;; This disables the part of EDE that asks questions
- (ede-auto-add-method 'never)
- ;; Ask font-lock to not colorize these buffers, nor to
- ;; whine about it either.
- (global-font-lock-mode nil)
- (font-lock-verbose nil)
- ;; This forces flymake to ignore this buffer on find-file, and
- ;; prevents flymake processes from being started.
- (flymake-start-syntax-check-on-find-file nil)
- ;; Disable revision control
- (vc-handled-backends nil)
- ;; Don't prompt to insert a template if we visit an empty file
- (auto-insert nil)
- ;; We don't want emacs to query about unsafe local variables
- (enable-local-variables :safe)
- ;; ... or eval variables
- (enable-local-eval nil)
- )
- (save-match-data
- (find-file-noselect file nowarn rawfile wildcards))))
-
-;;; Database restriction settings
-;;
-(defmacro semanticdb-without-unloaded-file-searches (forms)
- "Execute FORMS with `unloaded' removed from the current throttle."
- (declare (indent 1))
- `(let ((semanticdb-find-default-throttle
- (if (featurep 'semantic/db-find)
- (remq 'unloaded semanticdb-find-default-throttle)
- nil)))
- ,forms))
-
-\f
-;; ;;; Editor goodies ;-)
-;; ;;
-;; (defconst semantic-fw-font-lock-keywords
-;; (eval-when-compile
-;; (let* (
-;; ;; Variable declarations
-;; (vl nil)
-;; (kv (if vl (regexp-opt vl t) ""))
-;; ;; Function declarations
-;; (vf '(
-;; "define-lex"
-;; "define-lex-analyzer"
-;; "define-lex-block-analyzer"
-;; "define-lex-regex-analyzer"
-;; "define-lex-spp-macro-declaration-analyzer"
-;; "define-lex-spp-macro-undeclaration-analyzer"
-;; "define-lex-spp-include-analyzer"
-;; "define-lex-simple-regex-analyzer"
-;; "define-lex-keyword-type-analyzer"
-;; "define-lex-sexp-type-analyzer"
-;; "define-lex-regex-type-analyzer"
-;; "define-lex-string-type-analyzer"
-;; "define-lex-block-type-analyzer"
-;; ;;"define-semantic-child-mode"
-;; "define-semantic-idle-service"
-;; "define-semantic-decoration-style"
-;; "define-wisent-lexer"
-;; "semantic-make-obsolete-overload"
-;; "defcustom-mode-local-semantic-dependency-system-include-path"
-;; ))
-;; (kf (if vf (regexp-opt vf t) ""))
-;; ;; Regexp depths
-;; (kv-depth (if kv (regexp-opt-depth kv) nil))
-;; (kf-depth (if kf (regexp-opt-depth kf) nil))
-;; )
-;; `((,(concat
-;; ;; Declarative things
-;; "(\\(" kv "\\|" kf "\\)"
-;; ;; Whitespaces & names
-;; "\\>[ \t]*\\(\\sw+\\)?[ \t]*\\(\\sw+\\)?"
-;; )
-;; (1 font-lock-keyword-face)
-;; (,(+ 1 kv-depth kf-depth 1)
-;; (cond ((match-beginning 2)
-;; font-lock-type-face)
-;; ((match-beginning ,(+ 1 kv-depth 1))
-;; font-lock-function-name-face)
-;; )
-;; nil t)
-;; (,(+ 1 kv-depth kf-depth 1 1)
-;; (cond ((match-beginning 2)
-;; font-lock-variable-name-face)
-;; )
-;; nil t)))
-;; ))
-;; "Highlighted Semantic keywords.")
-
-;; (font-lock-add-keywords 'emacs-lisp-mode
-;; semantic-fw-font-lock-keywords)
-\f
-
-(provide 'semantic/fw)
-
-;;; semantic/fw.el ends here
+++ /dev/null
-;;; semantic/grammar.el --- Major mode framework for Semantic grammars -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2002-2005, 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Major mode framework for editing Semantic's input grammar files.
-
-;;; Code:
-
-(require 'semantic)
-(require 'semantic/wisent)
-(require 'semantic/ctxt)
-(require 'semantic/format)
-;; FIXME this is a generated file, but we need to load this file to
-;; generate it!
-;; We need `semantic/grammar-wy.el' but we're also needed to generate
-;; that file from `grammar.wy', so to break the dependency, we keep
-;; a bootstrap copy of `grammar-wy.el' in `grm-wy-boot.el'. See bug#16008.
-(eval-and-compile
- (unless (require 'semantic/grammar-wy nil t)
- (load "semantic/grm-wy-boot")))
-(require 'semantic/idle)
-(require 'help-fns)
-(require 'semantic/analyze)
-
-(declare-function semantic-momentary-highlight-tag "semantic/decorate")
-(declare-function semantic-analyze-tags-of-class-list
- "semantic/analyze/complete")
-
-(eval-when-compile
- (require 'eldoc)
- (require 'semantic/edit)
- (require 'semantic/find)
- (require 'semantic/db))
-
-(declare-function semantic-grammar-wy--install-parser "semantic/grammar-wy")
-
-\f
-;;;;
-;;;; Set up lexer
-;;;;
-
-(defconst semantic-grammar-lex-c-char-re "'\\s\\?.'"
- "Regexp matching C-like character literals.")
-
-;; Most of the analyzers are auto-generated from the grammar, but the
-;; following which need special handling code.
-;;
-(define-lex-regex-analyzer semantic-grammar-lex-prologue
- "Detect and create a prologue token."
- "\\<%{"
- ;; Zing to the end of this brace block.
- (semantic-lex-push-token
- (semantic-lex-token
- 'PROLOGUE (point)
- (save-excursion
- (semantic-lex-unterminated-syntax-protection 'PROLOGUE
- (forward-char)
- (forward-sexp 1)
- (point))))))
-
-(defsubst semantic-grammar-epilogue-start ()
- "Return the start position of the grammar epilogue."
- (save-excursion
- (goto-char (point-min))
- (if (re-search-forward "^\\s-*\\<%%\\>\\s-*$" nil t 2)
- (match-beginning 0)
- (1+ (point-max)))))
-
-(define-lex-regex-analyzer semantic-grammar-lex-epilogue
- "Detect and create an epilogue or percent-percent token."
- "\\<%%\\>"
- (let ((start (match-beginning 0))
- (end (match-end 0))
- (class 'PERCENT_PERCENT))
- (when (>= start (semantic-grammar-epilogue-start))
- (setq class 'EPILOGUE
- end (point-max)))
- (semantic-lex-push-token
- (semantic-lex-token class start end))))
-
-(define-lex semantic-grammar-lexer
- "Lexical analyzer that handles Semantic grammar buffers.
-It ignores whitespaces, newlines and comments."
- semantic-lex-ignore-newline
- semantic-lex-ignore-whitespace
- ;; Must detect prologue/epilogue before other symbols/keywords!
- semantic-grammar-lex-prologue
- semantic-grammar-lex-epilogue
- semantic-grammar-wy--<keyword>-keyword-analyzer
- semantic-grammar-wy--<symbol>-regexp-analyzer
- semantic-grammar-wy--<char>-regexp-analyzer
- semantic-grammar-wy--<string>-sexp-analyzer
- ;; Must detect comments after strings because `comment-start-skip'
- ;; regexp match semicolons inside strings!
- semantic-lex-ignore-comments
- ;; Must detect prefixed list before punctuation because prefix chars
- ;; are also punctuation!
- semantic-grammar-wy--<qlist>-sexp-analyzer
- ;; Must detect punctuation after comments because the semicolon can
- ;; be punctuation or a comment start!
- semantic-grammar-wy--<punctuation>-string-analyzer
- semantic-grammar-wy--<block>-block-analyzer
- semantic-grammar-wy--<sexp>-sexp-analyzer)
-
-;;; Test the lexer
-;;
-(defun semantic-grammar-lex-buffer ()
- "Run `semantic-grammar-lex' on current buffer."
- (interactive)
- (semantic-lex-init)
- (setq semantic-lex-analyzer 'semantic-grammar-lexer)
- (let ((token-stream
- (semantic-lex (point-min) (point-max))))
- (with-current-buffer (get-buffer-create "*semantic-grammar-lex*")
- (erase-buffer)
- (pp token-stream (current-buffer))
- (goto-char (point-min))
- (pop-to-buffer (current-buffer)))))
-\f
-;;;;
-;;;; Semantic action expansion
-;;;;
-
-(defun semantic-grammar-ASSOC (&rest args)
- "Return expansion of built-in ASSOC expression.
-ARGS are ASSOC's key value list."
- (let ((key t))
- `(semantic-tag-make-plist
- ,@(mapcar (lambda (i)
- (prog1
- (if key
- (list 'quote i)
- i)
- (setq key (not key))))
- args))))
-
-(defsubst semantic-grammar-quote-p (sym)
- "Return non-nil if SYM is bound to the `quote' function."
- (condition-case nil
- (eq (indirect-function sym)
- (indirect-function 'quote))
- (error nil)))
-
-(defsubst semantic-grammar-backquote-p (sym)
- "Return non-nil if SYM is bound to the `backquote' function."
- (condition-case nil
- (eq (indirect-function sym)
- (indirect-function 'backquote))
- (error nil)))
-\f
-;;;;
-;;;; API to access grammar tags
-;;;;
-
-(define-mode-local-override semantic-tag-components
- semantic-grammar-mode (tag)
- "Return the children of tag TAG."
- (semantic-tag-get-attribute tag :children))
-
-(defun semantic-grammar-first-tag-name (class)
- "Return the name of the first tag of class CLASS found.
-Warn if other tags of class CLASS exist."
- (let* ((tags (semantic-find-tags-by-class
- class (current-buffer))))
- (if tags
- (prog1
- (semantic-tag-name (car tags))
- (if (cdr tags)
- (message "*** Ignore all but first declared %s"
- class))))))
-
-(defun semantic-grammar-tag-symbols (class)
- "Return the list of symbols defined in tags of class CLASS.
-That is tag names plus names defined in tag attribute `:rest'."
- (let* ((tags (semantic-find-tags-by-class
- class (current-buffer))))
- (apply #'append
- (mapcar
- (lambda (tag)
- (mapcar
- #'intern
- (cons (semantic-tag-name tag)
- (semantic-tag-get-attribute tag :rest))))
- tags))))
-
-(defsubst semantic-grammar-item-text (item)
- "Return the readable string form of ITEM."
- (if (string-match semantic-grammar-lex-c-char-re item)
- (concat "?" (substring item 1 -1))
- item))
-
-(defsubst semantic-grammar-item-value (item)
- "Return symbol or character value of ITEM string."
- (if (string-match semantic-grammar-lex-c-char-re item)
- (read (concat "?" (substring item 1 -1)))
- (intern item)))
-
-(defun semantic-grammar-prologue ()
- "Return grammar prologue code as a string value."
- (let ((tag (semantic-find-first-tag-by-name
- "prologue"
- (semantic-find-tags-by-class 'code (current-buffer)))))
- (if tag
- (save-excursion
- (concat
- (buffer-substring
- (progn
- (goto-char (semantic-tag-start tag))
- (skip-chars-forward "%{\r\n\t ")
- (point))
- (progn
- (goto-char (semantic-tag-end tag))
- (skip-chars-backward "\r\n\t %}")
- (point)))
- "\n"))
- "")))
-
-(defun semantic-grammar-epilogue ()
- "Return grammar epilogue code as a string value."
- (let ((tag (semantic-find-first-tag-by-name
- "epilogue"
- (semantic-find-tags-by-class 'code (current-buffer)))))
- (if tag
- (save-excursion
- (concat
- (buffer-substring
- (progn
- (goto-char (semantic-tag-start tag))
- (skip-chars-forward "%\r\n\t ")
- (point))
- (progn
- (goto-char (semantic-tag-end tag))
- (skip-chars-backward "\r\n\t")
- ;; If a grammar footer is found, skip it.
- (re-search-backward "^;;;\\s-+\\S-+\\s-+ends here"
- (line-beginning-position) t)
- (skip-chars-backward "\r\n\t")
- (point)))
- "\n"))
- "")))
-
-(defsubst semantic-grammar-buffer-file (&optional buffer)
- "Return name of file sans directory BUFFER is visiting.
-No argument or nil as argument means use the current buffer."
- (file-name-nondirectory (buffer-file-name buffer)))
-
-(defun semantic-grammar-package ()
- "Return the %package value as a string.
-If there is no %package statement in the grammar, return a default
-package name derived from the grammar file name. For example, the
-default package name for the grammar file foo.wy is foo-wy, and for
-foo.by it is foo-by."
- (or (semantic-grammar-first-tag-name 'package)
- (let* ((file (semantic-grammar-buffer-file))
- (ext (file-name-extension file))
- (i (string-match (format "\\([.]\\)%s\\'" ext) file)))
- (concat (substring file 0 i) "-" ext))))
-
-(defun semantic-grammar-expected-conflicts ()
- "Return the number of expected shift/reduce conflicts in the package."
- (semantic-grammar-tag-symbols 'expectedconflicts))
-
-(defsubst semantic-grammar-languagemode ()
- "Return the %languagemode value as a list of symbols or nil."
- (semantic-grammar-tag-symbols 'languagemode))
-
-(defsubst semantic-grammar-start ()
- "Return the %start value as a list of symbols or nil."
- (semantic-grammar-tag-symbols 'start))
-
-(defsubst semantic-grammar-scopestart ()
- "Return the %scopestart value as a symbol or nil."
- (intern (or (semantic-grammar-first-tag-name 'scopestart) "nil")))
-
-(defsubst semantic-grammar-quotemode ()
- "Return the %quotemode value as a symbol or nil."
- (intern (or (semantic-grammar-first-tag-name 'quotemode) "nil")))
-
-(defsubst semantic-grammar-keywords ()
- "Return the language keywords.
-That is an alist of (VALUE . TOKEN) where VALUE is the string value of
-the keyword and TOKEN is the terminal symbol identifying the keyword."
- (mapcar
- (lambda (key)
- (cons (semantic-tag-get-attribute key :value)
- (intern (semantic-tag-name key))))
- (semantic-find-tags-by-class 'keyword (current-buffer))))
-
-(defun semantic-grammar-keyword-properties (keywords)
- "Return the list of KEYWORDS properties."
- (let ((puts (semantic-find-tags-by-class
- 'put (current-buffer)))
- put keys key plist assoc pkey pval props)
- (while puts
- (setq put (car puts)
- puts (cdr puts)
- keys (mapcar
- #'intern
- (cons (semantic-tag-name put)
- (semantic-tag-get-attribute put :rest))))
- (while keys
- (setq key (car keys)
- keys (cdr keys)
- assoc (rassq key keywords))
- (if (null assoc)
- nil ;;(message "*** %%put to undefined keyword %s ignored" key)
- (setq key (car assoc)
- plist (semantic-tag-get-attribute put :value))
- (while plist
- (setq pkey (intern (caar plist))
- pval (read (cdar plist))
- props (cons (list key pkey pval) props)
- plist (cdr plist))))))
- props))
-
-(defun semantic-grammar-tokens ()
- "Return defined lexical tokens.
-That is an alist (TYPE . DEFS) where type is a %token <type> symbol
-and DEFS is an alist of (TOKEN . VALUE). TOKEN is the terminal symbol
-identifying the token and VALUE is the string value of the token or
-nil."
- (let (tags alist assoc tag type term names value)
-
- ;; Check for <type> in %left, %right & %nonassoc declarations
- (setq tags (semantic-find-tags-by-class
- 'assoc (current-buffer)))
- (while tags
- (setq tag (car tags)
- tags (cdr tags))
- (when (setq type (semantic-tag-type tag))
- (setq names (semantic-tag-get-attribute tag :value)
- assoc (assoc type alist))
- (or assoc (setq assoc (list type)
- alist (cons assoc alist)))
- (while names
- (setq term (car names)
- names (cdr names))
- (or (string-match semantic-grammar-lex-c-char-re term)
- (setcdr assoc (cons (list (intern term))
- (cdr assoc)))))))
-
- ;; Then process %token declarations so they can override any
- ;; previous specifications
- (setq tags (semantic-find-tags-by-class
- 'token (current-buffer)))
- (while tags
- (setq tag (car tags)
- tags (cdr tags))
- (setq names (cons (semantic-tag-name tag)
- (semantic-tag-get-attribute tag :rest))
- type (or (semantic-tag-type tag) "<no-type>")
- value (semantic-tag-get-attribute tag :value)
- assoc (assoc type alist))
- (or assoc (setq assoc (list type)
- alist (cons assoc alist)))
- (while names
- (setq term (intern (car names))
- names (cdr names))
- (setcdr assoc (cons (cons term value) (cdr assoc)))))
- alist))
-
-(defun semantic-grammar-token-%type-properties (&optional props)
- "Return properties set by %type statements.
-This declare a new type if necessary.
-If optional argument PROPS is non-nil, it is an existing list of
-properties where to add new properties."
- (let (type)
- (dolist (tag (semantic-find-tags-by-class 'type (current-buffer)))
- (setq type (semantic-tag-name tag))
- ;; Indicate to auto-generate the analyzer for this type
- (push (list type :declared t) props)
- (dolist (e (semantic-tag-get-attribute tag :value))
- (push (list type (intern (car e)) (read (or (cdr e) "nil")))
- props)))
- props))
-
-(defun semantic-grammar-token-%put-properties (tokens)
- "For types found in TOKENS, return properties set by %put statements."
- (let (found props)
- (dolist (put (semantic-find-tags-by-class 'put (current-buffer)))
- (dolist (type (cons (semantic-tag-name put)
- (semantic-tag-get-attribute put :rest)))
- (setq found (assoc type tokens))
- (if (null found)
- nil ;; %put <type> ignored, no token defined
- (setq type (car found))
- (dolist (e (semantic-tag-get-attribute put :value))
- (push (list type (intern (car e)) (read (or (cdr e) "nil")))
- props)))))
- props))
-
-(defsubst semantic-grammar-token-properties (tokens)
- "Return properties of declared types.
-Types are explicitly declared by %type statements. Types found in
-TOKENS are those declared implicitly by %token statements.
-Properties can be set by %put and %type statements.
-Properties set by %type statements take precedence over those set by
-%put statements."
- (let ((props (semantic-grammar-token-%put-properties tokens)))
- (semantic-grammar-token-%type-properties props)))
-
-(defun semantic-grammar-use-macros ()
- "Return macro definitions from %use-macros statements.
-Also load the specified macro libraries."
- (let (lib defs)
- (dolist (tag (semantic-find-tags-by-class 'macro (current-buffer)))
- (setq lib (intern (semantic-tag-type tag)))
- (condition-case nil
- ;;(load lib) ;; Be sure to use the latest macro library.
- (require lib)
- (error nil))
- (dolist (mac (semantic-tag-get-attribute tag :value))
- (push (cons (intern mac)
- (intern (format "%s-%s" lib mac)))
- defs)))
- (nreverse defs)))
-
-(defvar-local semantic-grammar-macros nil
- "List of associations (MACRO-NAME . EXPANDER).")
-
-(defun semantic-grammar-macros ()
- "Build and return the alist of defined macros."
- (append
- ;; Definitions found in tags.
- (semantic-grammar-use-macros)
- ;; Other pre-installed definitions.
- semantic-grammar-macros))
-\f
-;;;;
-;;;; Overloaded functions that build parser data.
-;;;;
-
-;;; Keyword table builder
-;;
-(defun semantic-grammar-keywordtable-builder-default ()
- "Return the default value of the keyword table."
- (let ((keywords (semantic-grammar-keywords)))
- `(semantic-lex-make-keyword-table
- ',keywords
- ',(semantic-grammar-keyword-properties keywords))))
-
-(define-overloadable-function semantic-grammar-keywordtable-builder ()
- "Return the keyword table value.")
-
-;;; Token table builder
-;;
-(defun semantic-grammar-tokentable-builder-default ()
- "Return the default value of the table of lexical tokens."
- (let ((tokens (semantic-grammar-tokens)))
- `(semantic-lex-make-type-table
- ',tokens
- ',(semantic-grammar-token-properties tokens))))
-
-(define-overloadable-function semantic-grammar-tokentable-builder ()
- "Return the value of the table of lexical tokens.")
-
-;;; Parser table builder
-;;
-(defun semantic-grammar-parsetable-builder-default ()
- "Return the default value of the parse table."
- (error "`semantic-grammar-parsetable-builder' not defined"))
-
-(define-overloadable-function semantic-grammar-parsetable-builder ()
- "Return the parser table value.")
-
-;;; Parser setup code builder
-;;
-(defun semantic-grammar-setupcode-builder-default ()
- "Return the default value of the setup code form."
- (error "`semantic-grammar-setupcode-builder' not defined"))
-
-(define-overloadable-function semantic-grammar-setupcode-builder ()
- "Return the parser setup code form.")
-\f
-;;;;
-;;;; Lisp code generation
-;;;;
-(defvar semantic--grammar-input-buffer nil)
-(defvar semantic--grammar-output-buffer nil)
-(defvar semantic--grammar-package nil)
-(defvar semantic--grammar-provide nil)
-
-(defsubst semantic-grammar-keywordtable ()
- "Return the variable name of the keyword table."
- (concat semantic--grammar-package
- "--keyword-table"))
-
-(defsubst semantic-grammar-tokentable ()
- "Return the variable name of the token table."
- (concat semantic--grammar-package
- "--token-table"))
-
-(defsubst semantic-grammar-parsetable ()
- "Return the variable name of the parse table."
- (concat semantic--grammar-package
- "--parse-table"))
-
-(defsubst semantic-grammar-setupfunction ()
- "Return the name of the parser setup function."
- (concat semantic--grammar-package
- "--install-parser"))
-
-(defmacro semantic-grammar-as-string (object)
- "Return OBJECT as a string value."
- `(if (stringp ,object)
- ,object
- ;;(require 'pp)
- (pp-to-string ,object)))
-
-(defun semantic-grammar-insert-defconst (name value docstring)
- "Insert declaration of constant NAME with VALUE and DOCSTRING."
- (let ((start (point)))
- (insert (format "(defconst %s\n%s%S)\n\n" name value docstring))
- (save-excursion
- (goto-char start)
- (indent-sexp))))
-
-(defun semantic-grammar-insert-defconst-with-eval (name value docstring)
- "Insert declaration of constant NAME with VALUE and DOCSTRING."
- (let ((start (point)))
- (insert (format "(eval-and-compile (defconst %s\n%s%S))\n\n" name value docstring))
- (save-excursion
- (goto-char start)
- (indent-sexp))))
-
-(defun semantic-grammar-insert-defun (name body docstring)
- "Insert declaration of function NAME with BODY and DOCSTRING."
- (let ((start (point)))
- (insert (format "(defun %s ()\n%S\n%s)\n\n" name docstring body))
- (save-excursion
- (goto-char start)
- (indent-sexp))))
-
-(defun semantic-grammar-insert-define (define)
- "Insert the declaration specified by DEFINE expression.
-Typically a DEFINE expression should look like this:
-
-\(define-thing name docstring expression1 ...)"
- ;;(require 'pp)
- (let ((start (point)))
- (insert (format "(%S %S" (car define) (nth 1 define)))
- (dolist (item (nthcdr 2 define))
- (insert "\n")
- (delete-blank-lines)
- (pp item (current-buffer)))
- (insert ")\n\n")
- (save-excursion
- (goto-char start)
- (indent-sexp))))
-
-(defvar semantic-grammar-require-form
- '(eval-when-compile (require 'semantic/bovine))
- "The form to use to load the parser engine.")
-
-(defconst semantic-grammar-header-template
- '("\
-;;; " file " --- Generated parser support file
-
-" copy "
-
-;; Author: " user-full-name " <" user-mail-address ">
-;; Created: " date "
-;; Keywords: syntax
-;; X-RCS: " vcid "
-
-;; This file is not part of GNU Emacs.
-
-;; This program is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU General Public License as
-;; published by the Free Software Foundation, either version 3 of
-;; the License, or (at your option) any later version.
-
-;; This software is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; PLEASE DO NOT MANUALLY EDIT THIS FILE! It is automatically
-;; generated from the grammar file " gram ".
-
-;;; Code:
-
-(require 'semantic/lex)
-" require-form "
-")
- "Generated header template.
-The symbols in the template are local variables in
-`semantic-grammar-header'")
-
-(defconst semantic-grammar-footer-template
- '("\
-
-\(provide '" libr ")
-
-;; Local Variables:
-;; version-control: never
-;; no-update-autoloads: t
-;; End:
-
-;;; " file " ends here
-")
- "Generated footer template.
-The symbols in the list are local variables in
-`semantic-grammar-footer'.")
-
-(defun semantic-grammar-copyright-line ()
- "Return the grammar copyright line, or nil if not found."
- (save-excursion
- (goto-char (point-min))
- (when (re-search-forward "^;;+[ \t]+Copyright (C) .*$"
- ;; Search only in the four top lines
- (save-excursion (forward-line 4) (point))
- t)
- (match-string 0))))
-
-(defun semantic-grammar--template-expand (template env)
- (mapconcat (lambda (S)
- (if (stringp S) S
- (let ((x (assq S env)))
- (cond
- (x (cdr x))
- ((symbolp S) (symbol-value S))))))
- template))
-
-(defun semantic-grammar-header ()
- "Return text of a generated standard header."
- (semantic-grammar--template-expand
- semantic-grammar-header-template
- `((file . ,(semantic-grammar-buffer-file
- semantic--grammar-output-buffer))
- (gram . ,(semantic-grammar-buffer-file))
- (date . ,(format-time-string "%Y-%m-%d %T%z"))
- (require-form . ,(format "%S" semantic-grammar-require-form))
- (vcid . ,(concat "$" "Id" "$")) ;; Avoid expansion
- ;; Try to get the copyright from the input grammar, or
- ;; generate a new one if not found.
- (copy . ,(or (semantic-grammar-copyright-line)
- (concat (format-time-string ";; Copyright (C) %Y ")
- user-full-name))))))
-
-(defun semantic-grammar-footer ()
- "Return text of a generated standard footer."
- (semantic-grammar--template-expand
- semantic-grammar-footer-template
- `((file . ,(semantic-grammar-buffer-file
- semantic--grammar-output-buffer))
- (libr . ,(or semantic--grammar-provide
- semantic--grammar-package)))))
-
-(defun semantic-grammar-token-data ()
- "Return the string value of the table of lexical tokens."
- (semantic-grammar-as-string
- (semantic-grammar-tokentable-builder)))
-
-(defun semantic-grammar-keyword-data ()
- "Return the string value of the table of keywords."
- (semantic-grammar-as-string
- (semantic-grammar-keywordtable-builder)))
-
-(defun semantic-grammar-parser-data ()
- "Return the parser table as a string value."
- (semantic-grammar-as-string
- (semantic-grammar-parsetable-builder)))
-
-(defun semantic-grammar-setup-data ()
- "Return the parser setup code form as a string value."
- (semantic-grammar-as-string
- (semantic-grammar-setupcode-builder)))
-\f
-;;; Generation of lexical analyzers.
-;;
-(defvar semantic-grammar--lex-block-specs)
-
-(defsubst semantic-grammar--lex-delim-spec (block-spec)
- "Return delimiters specification from BLOCK-SPEC."
- (condition-case nil
- (let* ((standard-input (cdr block-spec))
- (delim-spec (read)))
- (if (and (consp delim-spec)
- (car delim-spec) (symbolp (car delim-spec))
- (cadr delim-spec) (symbolp (cadr delim-spec)))
- delim-spec
- (error "Invalid delimiter")))
- (error
- (error "Invalid delimiters specification %s in block token %s"
- (cdr block-spec) (car block-spec)))))
-
-(defun semantic-grammar--lex-block-specs ()
- "Compute lexical block specifications for the current buffer.
-Block definitions are read from the current table of lexical types."
- (cond
- ;; Block specifications have been parsed and are invalid.
- ((eq semantic-grammar--lex-block-specs 'error)
- nil
- )
- ;; Parse block specifications.
- ((null semantic-grammar--lex-block-specs)
- (condition-case err
- (let* ((blocks (cdr (semantic-lex-type-value "block" t)))
- (open-delims (cdr (semantic-lex-type-value "open-paren" t)))
- (close-delims (cdr (semantic-lex-type-value "close-paren" t)))
- olist clist delim-spec open-spec close-spec)
- (dolist (block-spec blocks)
- (setq delim-spec (semantic-grammar--lex-delim-spec block-spec)
- open-spec (assq (car delim-spec) open-delims)
- close-spec (assq (cadr delim-spec) close-delims))
- (or open-spec
- (error "Missing open-paren token %s required by block %s"
- (car delim-spec) (car block-spec)))
- (or close-spec
- (error "Missing close-paren token %s required by block %s"
- (cdr delim-spec) (car block-spec)))
- ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...)
- (push (list (cdr open-spec) (car open-spec) (car block-spec))
- olist)
- ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...)
- (push (list (cdr close-spec) (car close-spec))
- clist))
- (setq semantic-grammar--lex-block-specs (cons olist clist)))
- (error
- (setq semantic-grammar--lex-block-specs 'error)
- (message "%s" (error-message-string err))
- nil))
- )
- ;; Block specifications already parsed.
- (t
- semantic-grammar--lex-block-specs)))
-
-(defsubst semantic-grammar-quoted-form (exp)
- "Return a quoted form of EXP if it isn't a self evaluating form."
- (if (and (not (null exp))
- (or (listp exp) (symbolp exp)))
- (list 'quote exp)
- exp))
-
-(defun semantic-grammar-insert-defanalyzer (type)
- "Insert declaration of the lexical analyzer defined with TYPE."
- (let* ((type-name (symbol-name type))
- (type-value (symbol-value type))
- (syntax (get type 'syntax))
- (declared (get type :declared))
- spec mtype prefix name doc)
- ;; Generate an analyzer if the corresponding type has been
- ;; explicitly declared in a %type statement, and if at least the
- ;; syntax property has been provided.
- (when (and declared syntax)
- (setq prefix semantic--grammar-package
- mtype (or (get type 'matchdatatype) 'regexp)
- name (intern (format "%s--<%s>-%s-analyzer" prefix type mtype))
- doc (format "%s analyzer for <%s> tokens." mtype type))
- (cond
- ;; Regexp match analyzer
- ((eq mtype 'regexp)
- (semantic-grammar-insert-define
- `(define-lex-regex-type-analyzer ,name
- ,doc ,syntax
- ,(semantic-grammar-quoted-form (cdr type-value))
- ',(or (car type-value) (intern type-name))))
- )
- ;; String compare analyzer
- ((eq mtype 'string)
- (semantic-grammar-insert-define
- `(define-lex-string-type-analyzer ,name
- ,doc ,syntax
- ,(semantic-grammar-quoted-form (cdr type-value))
- ',(or (car type-value) (intern type-name))))
- )
- ;; Block analyzer
- ((and (eq mtype 'block)
- (setq spec (semantic-grammar--lex-block-specs)))
- (semantic-grammar-insert-define
- `(define-lex-block-type-analyzer ,name
- ,doc ,syntax
- ,(semantic-grammar-quoted-form spec)))
- )
- ;; Sexp analyzer
- ((eq mtype 'sexp)
- (semantic-grammar-insert-define
- `(define-lex-sexp-type-analyzer ,name
- ,doc ,syntax
- ',(or (car type-value) (intern type-name))))
- )
- ;; keyword analyzer
- ((eq mtype 'keyword)
- (semantic-grammar-insert-define
- `(define-lex-keyword-type-analyzer ,name
- ,doc ,syntax))
- )
- ))
- ))
-
-(defun semantic-grammar-insert-defanalyzers ()
- "Insert declarations of lexical analyzers."
- (let (tokens props)
- (with-current-buffer semantic--grammar-input-buffer
- (setq tokens (semantic-grammar-tokens)
- props (semantic-grammar-token-properties tokens)))
- (let ((semantic-lex-types-obarray
- (semantic-lex-make-type-table tokens props))
- semantic-grammar--lex-block-specs)
- (mapatoms #'semantic-grammar-insert-defanalyzer
- semantic-lex-types-obarray))))
-\f
-;;; Generation of the grammar support file.
-;;
-(defcustom semantic-grammar-file-regexp "\\.[wb]y\\'"
- "Regexp which matches grammar source files."
- :group 'semantic
- :type 'regexp)
-
-(defun semantic-grammar-create-package (&optional force uptodate)
- "Create package Lisp code from grammar in current buffer.
-If the Lisp code seems up to date, do nothing (if UPTODATE
-is non-nil, return nil in such cases).
-If optional argument FORCE is non-nil, unconditionally re-generate the
-Lisp code."
- (interactive "P")
- (unless (semantic-active-p)
- (error "You have to activate semantic-mode to create a package"))
- (setq force (or force current-prefix-arg))
- (semantic-fetch-tags)
- (let* (
- ;; Values of the following local variables are obtained from
- ;; the grammar parsed tree in current buffer, that is before
- ;; switching to the output file.
- (semantic--grammar-package (semantic-grammar-package))
- (semantic--grammar-provide (semantic-grammar-first-tag-name 'provide))
- (output (concat (or semantic--grammar-provide
- semantic--grammar-package)
- ".el"))
- (semantic--grammar-input-buffer (current-buffer))
- (semantic--grammar-output-buffer
- (find-file-noselect
- (file-name-nondirectory output)))
- (header (semantic-grammar-header))
- (prologue (semantic-grammar-prologue))
- (epilogue (semantic-grammar-epilogue))
- (footer (semantic-grammar-footer))
- )
- (if (and (not force)
- (not (buffer-modified-p))
- (file-newer-than-file-p
- (buffer-file-name semantic--grammar-output-buffer)
- (buffer-file-name semantic--grammar-input-buffer)))
- (progn
- (message "Package `%s' is up to date." semantic--grammar-package)
- ;; It would be better if this were always the case, IMO,
- ;; but the (unspecified) return value of this function is
- ;; assumed to be non-nil in some places, it seems.
- (if uptodate (setq output nil)))
- ;; Create the package
- (set-buffer semantic--grammar-output-buffer)
- ;; Use Unix EOLs, so that the file is portable to all platforms.
- (setq buffer-file-coding-system 'raw-text-unix)
- (erase-buffer)
- (unless (derived-mode-p 'emacs-lisp-mode)
- (emacs-lisp-mode))
-
-;;;; Header + Prologue
-
- (insert header
- "\f\n;;; Prologue\n;;\n"
- prologue
- )
- ;; Evaluate the prologue now, because it might provide definition
- ;; of grammar macro expanders.
- (eval-region (point-min) (point))
-
- (save-excursion
-
-;;;; Declarations
-
- (insert "\f\n;;; Declarations\n;;\n")
-
- (semantic-grammar-insert-defconst-with-eval
- (concat semantic--grammar-package "--expected-conflicts")
- (with-current-buffer semantic--grammar-input-buffer
- (format "%s\n" (car (semantic-grammar-expected-conflicts))))
- "The number of expected shift/reduce conflicts in this grammar.")
-
- ;; `eval-defun' is not necessary to reset `defconst' values.
- (semantic-grammar-insert-defconst
- (semantic-grammar-keywordtable)
- (with-current-buffer semantic--grammar-input-buffer
- (semantic-grammar-keyword-data))
- "Table of language keywords.")
-
- (semantic-grammar-insert-defconst
- (semantic-grammar-tokentable)
- (with-current-buffer semantic--grammar-input-buffer
- (semantic-grammar-token-data))
- "Table of lexical tokens.")
-
- (semantic-grammar-insert-defconst
- (semantic-grammar-parsetable)
- (with-current-buffer semantic--grammar-input-buffer
- (semantic-grammar-parser-data))
- "Parser table.")
-
- (semantic-grammar-insert-defun
- (semantic-grammar-setupfunction)
- (with-current-buffer semantic--grammar-input-buffer
- (semantic-grammar-setup-data))
- "Setup the Semantic Parser.")
-
-;;;; Analyzers
- (insert "\f\n;;; Analyzers\n;;\n")
-
- (semantic-grammar-insert-defanalyzers)
-
-;;;; Epilogue & Footer
-
- (insert "\f\n;;; Epilogue\n;;\n"
- epilogue
- footer
- )
-
- )
-
- (save-buffer 16)
-
- ;; If running in batch mode, there is nothing more to do.
- ;; Save the generated file and quit.
- (if noninteractive
- (let ((version-control t)
- (delete-old-versions t)
- (make-backup-files t)
- (vc-make-backup-files t))
- (kill-buffer (current-buffer)))
- ;; If running interactively, eval declarations and epilogue
- ;; code, then pop to the buffer visiting the generated file.
- (eval-region (point) (point-max))
- ;; Loop over the defvars and eval them explicitly to force
- ;; them to be evaluated and ready to use.
- (goto-char (point-min))
- (while (re-search-forward "(defvar " nil t)
- (eval-defun nil))
- ;; Move cursor to a logical spot in the generated code.
- (goto-char (point-min))
- (pop-to-buffer (current-buffer))
- ;; The generated code has been evaluated and updated into
- ;; memory. Now find all buffers that match the major modes we
- ;; have created this language for, and force them to call our
- ;; setup function again, refreshing all semantic data, and
- ;; enabling them to work with the new code just created.
-;;;; FIXME?
- ;; At this point, I don't know any user's defined setup code :-(
- ;; At least, what I can do for now, is to run the generated
- ;; parser-install function.
- (semantic-map-mode-buffers
- (semantic-grammar-setupfunction)
- (semantic-grammar-languagemode)))
- )
- ;; Return the name of the generated package file.
- output))
-
-(defun semantic-grammar-recreate-package ()
- "Unconditionally create Lisp code from grammar in current buffer.
-Like \\[universal-argument] \\[semantic-grammar-create-package]."
- (interactive)
- (semantic-grammar-create-package t))
-
-(defun semantic-grammar-batch-build-one-package (file)
- "Build a Lisp package from the grammar in FILE.
-That is, generate Lisp code from FILE, and `byte-compile' it.
-Return non-nil if there were no errors, nil if errors."
- ;; We need this require so that we can find `byte-compile-dest-file'.
- (require 'bytecomp)
- (unless (auto-save-file-name-p file)
- ;; Create the package
- (let ((packagename
- (condition-case err
- (with-current-buffer (find-file-noselect file)
- (let ((semantic-new-buffer-setup-functions nil)
- (vc-handled-backends nil))
- (setq semanticdb-new-database-class 'semanticdb-project-database)
- (semantic-mode 1)
- (semantic-grammar-create-package t)))
- (error
- (message "%s" (error-message-string err))
- nil))))
- (when packagename
- ;; Only byte compile if out of date
- (if (file-newer-than-file-p
- packagename (byte-compile-dest-file packagename))
- (let (;; Some complex grammar table expressions need a few
- ;; more resources than the default.
- (max-lisp-eval-depth (max 1000 max-lisp-eval-depth))
- )
- ;; byte compile the resultant file
- (byte-compile-file packagename))
- t)))))
-
-(defun semantic-grammar-batch-build-packages ()
- "Build Lisp packages from grammar files on the command line.
-That is, run `semantic-grammar-batch-build-one-package' for each file.
-Each file is processed even if an error occurred previously.
-Must be used from the command line, with `-batch'.
-For example, to process grammar files in current directory, invoke:
-
- \"emacs -batch -f semantic-grammar-batch-build-packages .\".
-
-See also the variable `semantic-grammar-file-regexp'."
- (or noninteractive
- (error "\
-`semantic-grammar-batch-build-packages' must be used with -batch"
- ))
- (let ((status 0)
- ;; Remove vc from find-file-hook. It causes bad stuff to
- ;; happen in Emacs 20.
- (find-file-hook (delete 'vc-find-file-hook find-file-hook)))
- (dolist (arg command-line-args-left)
- (unless (and arg (file-exists-p arg))
- (error "Argument %s is not a valid file name" arg))
- (setq arg (expand-file-name arg))
- (if (file-directory-p arg)
- ;; Directory as argument
- (dolist (src (condition-case nil
- (directory-files
- arg nil semantic-grammar-file-regexp)
- (error
- (error "Unable to read directory files"))))
- (or (semantic-grammar-batch-build-one-package
- (expand-file-name src arg))
- (setq status 1)))
- ;; Specific file argument
- (or (semantic-grammar-batch-build-one-package arg)
- (setq status 1))))
- (kill-emacs status)
- ))
-\f
-;;;;
-;;;; Macros highlighting
-;;;;
-
-(defvar-local semantic--grammar-macros-regexp-1 nil)
-
-(defun semantic--grammar-macros-regexp-1 ()
- "Return font-lock keyword regexp for pre-installed macro names."
- (and semantic-grammar-macros
- (not semantic--grammar-macros-regexp-1)
- (condition-case nil
- (setq semantic--grammar-macros-regexp-1
- (concat "(\\s-*"
- (regexp-opt
- (mapcar (lambda (e) (symbol-name (car e)))
- semantic-grammar-macros)
- t)
- "\\>"))
- (error nil)))
- semantic--grammar-macros-regexp-1)
-
-(defconst semantic--grammar-macdecl-re
- "\\<%use-macros\\>[ \t\r\n]+\\(\\sw\\|\\s_\\)+[ \t\r\n]+{"
- "Regexp that matches a macro declaration statement.")
-
-(defvar-local semantic--grammar-macros-regexp-2 nil)
-
-(defun semantic--grammar-clear-macros-regexp-2 (&rest _)
- "Clear the cached regexp that match macros local in this grammar.
-IGNORE arguments.
-Added to `before-change-functions' hooks to be run before each text
-change."
- (setq semantic--grammar-macros-regexp-2 nil))
-
-(defun semantic--grammar-macros-regexp-2 ()
- "Return the regexp that match macros local in this grammar."
- (unless semantic--grammar-macros-regexp-2
- (let (macs)
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward semantic--grammar-macdecl-re nil t)
- (condition-case nil
- (setq macs (nconc macs
- (split-string
- (buffer-substring-no-properties
- (point)
- (progn
- (backward-char)
- (forward-list 1)
- (down-list -1)
- (point))))))
- (error nil)))
- (when macs
- (setq semantic--grammar-macros-regexp-2
- (concat "(\\s-*" (regexp-opt macs t) "\\>"))))))
- semantic--grammar-macros-regexp-2)
-
-(defun semantic--grammar-macros-matcher (end)
- "Search for a grammar macro name to highlight.
-END is the limit of the search."
- (let ((regexp (semantic--grammar-macros-regexp-1)))
- (or (and regexp (re-search-forward regexp end t))
- (and (setq regexp (semantic--grammar-macros-regexp-2))
- (re-search-forward regexp end t)))))
-\f
-;;;;
-;;;; Define major mode
-;;;;
-
-(defvar semantic-grammar-mode-syntax-table
- (let ((table (make-syntax-table (standard-syntax-table))))
- (modify-syntax-entry ?\: "." table) ;; COLON
- (modify-syntax-entry ?\> "." table) ;; GT
- (modify-syntax-entry ?\< "." table) ;; LT
- (modify-syntax-entry ?\| "." table) ;; OR
- (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
- (modify-syntax-entry ?\n ">" table) ;; Comment end
- (modify-syntax-entry ?\" "\"" table) ;; String
- (modify-syntax-entry ?\% "w" table) ;; Word
- (modify-syntax-entry ?\- "_" table) ;; Symbol
- (modify-syntax-entry ?\. "_" table) ;; Symbol
- (modify-syntax-entry ?\\ "\\" table) ;; Quote
- (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
- (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
- (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
- (modify-syntax-entry ?\# "'" table) ;; Prefix # (sharp)
- table)
- "Syntax table used in a Semantic grammar buffers.")
-
-(defvar semantic-grammar-mode-hook nil
- "Hook run when starting Semantic grammar mode.")
-
-(defvar semantic-grammar-mode-keywords-1
- `(("\\(\\<%%\\>\\|\\<%[{}]\\)"
- 0 font-lock-constant-face)
- ("\\(%\\)\\(\\(\\sw\\|\\s_\\)+\\)"
- (1 font-lock-constant-face)
- (2 font-lock-keyword-face))
- ("\\<error\\>"
- 0 (unless (semantic-grammar-in-lisp-p) 'bold))
- ("^\\(\\(\\sw\\|\\s_\\)+\\)[ \n\r\t]*:"
- 1 font-lock-function-name-face)
- (semantic--grammar-macros-matcher
- 1 font-lock-builtin-face)
- ("\\$\\(\\sw\\|\\s_\\)*"
- 0 font-lock-variable-name-face)
- ("<\\(\\(\\sw\\|\\s_\\)+\\)>"
- 1 font-lock-type-face)
- (,semantic-grammar-lex-c-char-re
- 0 font-lock-constant-face t)
- ;; Must highlight :keyword here, because ':' is a punctuation in
- ;; grammar mode!
- ("[\r\n\t ]+:\\sw+\\>"
- 0 font-lock-builtin-face)
- ;; ;; Append the Semantic keywords
- ;; ,@semantic-fw-font-lock-keywords
- )
- "Font Lock keywords used to highlight Semantic grammar buffers.")
-
-(defvar semantic-grammar-mode-keywords-2
- (append semantic-grammar-mode-keywords-1
- (if (boundp 'lisp-font-lock-keywords-1)
- lisp-font-lock-keywords-1
- lisp-el-font-lock-keywords-1))
- "Font Lock keywords used to highlight Semantic grammar buffers.")
-
-(defvar semantic-grammar-mode-keywords-3
- (append semantic-grammar-mode-keywords-1
- (if (boundp 'lisp-font-lock-keywords-2)
- lisp-font-lock-keywords-2
- lisp-el-font-lock-keywords-2))
- "Font Lock keywords used to highlight Semantic grammar buffers.")
-
-(defvar semantic-grammar-mode-keywords
- semantic-grammar-mode-keywords-1
- "Font Lock keywords used to highlight Semantic grammar buffers.")
-
-(defvar semantic-grammar-mode-map
- (let ((km (make-sparse-keymap)))
-
- (define-key km "|" #'semantic-grammar-electric-punctuation)
- (define-key km ";" #'semantic-grammar-electric-punctuation)
- (define-key km "%" #'semantic-grammar-electric-punctuation)
- (define-key km "(" #'semantic-grammar-electric-punctuation)
- (define-key km ")" #'semantic-grammar-electric-punctuation)
- (define-key km ":" #'semantic-grammar-electric-punctuation)
-
- (define-key km "\t" #'semantic-grammar-indent)
- (define-key km "\M-\t" #'semantic-grammar-complete)
- (define-key km "\C-c\C-c" #'semantic-grammar-create-package)
- (define-key km "\C-cm" #'semantic-grammar-find-macro-expander)
- (define-key km "\C-cik" #'semantic-grammar-insert-keyword)
-;; (define-key km "\C-cc" #'semantic-grammar-generate-and-load)
-;; (define-key km "\C-cr" #'semantic-grammar-generate-one-rule)
-
- km)
- "Keymap used in `semantic-grammar-mode'.")
-
-(defvar semantic-grammar-menu
- '("Grammar"
- ["Indent Line" semantic-grammar-indent]
- ["Complete Symbol" semantic-grammar-complete]
- ["Find Macro" semantic-grammar-find-macro-expander]
- "--"
- ["Insert %keyword" semantic-grammar-insert-keyword]
- "--"
- ["Update Lisp Package" semantic-grammar-create-package]
- ["Recreate Lisp Package" semantic-grammar-recreate-package]
- )
- "Common semantic grammar menu.")
-
-(defun semantic-grammar-setup-menu-emacs (symbol mode-menu)
- "Setup a GNU Emacs grammar menu in variable SYMBOL.
-MODE-MENU is an optional specific menu whose items are appended to the
-common grammar menu."
- (let ((items (make-symbol "items")))
- `(unless (boundp ',symbol)
- (easy-menu-define ,symbol (current-local-map)
- "Grammar Menu" semantic-grammar-menu)
- (let ((,items (cdr ,mode-menu)))
- (when ,items
- (easy-menu-add-item ,symbol nil "--")
- (while ,items
- (easy-menu-add-item ,symbol nil (car ,items))
- (setq ,items (cdr ,items))))))
- ))
-
-(defun semantic-grammar-setup-menu-xemacs (symbol mode-menu)
- "Setup an XEmacs grammar menu in variable SYMBOL.
-MODE-MENU is an optional specific menu whose items are appended to the
-common grammar menu."
- (declare (obsolete nil "28.1"))
- (let ((items (make-symbol "items"))
- (path (make-symbol "path")))
- `(progn
- (unless (boundp ',symbol)
- (easy-menu-define ,symbol nil
- "Grammar Menu" (copy-sequence semantic-grammar-menu)))
- (when (featurep 'xemacs)
- (easy-menu-add ,symbol))
- (let ((,items (cdr ,mode-menu))
- (,path (list (car ,symbol))))
- (when ,items
- (easy-menu-add-item nil ,path "--")
- (while ,items
- (easy-menu-add-item nil ,path (car ,items))
- (setq ,items (cdr ,items))))))
- ))
-
-(defmacro semantic-grammar-setup-menu (&optional mode-menu)
- "Setup a mode local grammar menu.
-MODE-MENU is an optional specific menu whose items are appended to the
-common grammar menu."
- (semantic-grammar-setup-menu-emacs
- (intern (format "%s-menu" major-mode)) mode-menu))
-
-(defsubst semantic-grammar-in-lisp-p ()
- "Return non-nil if point is in Lisp code."
- (or (>= (point) (semantic-grammar-epilogue-start))
- (condition-case nil
- (save-excursion
- (up-list -1)
- t)
- (error nil))))
-
-(defun semantic-grammar-edits-new-change-hook-fcn (overlay)
- "Function set into `semantic-edits-new-change-hook'.
-Argument OVERLAY is the overlay created to mark the change.
-When OVERLAY marks a change in the scope of a nonterminal tag extend
-the change bounds to encompass the whole nonterminal tag."
- (let ((outer (car (semantic-find-tag-by-overlay-in-region
- (semantic-edits-os overlay)
- (semantic-edits-oe overlay)))))
- (if (semantic-tag-of-class-p outer 'nonterminal)
- (move-overlay overlay
- (semantic-tag-start outer)
- (semantic-tag-end outer)))))
-
-(define-derived-mode semantic-grammar-mode
- fundamental-mode "Semantic Grammar Framework"
- "Initialize a buffer for editing Semantic grammars.
-
-\\{semantic-grammar-mode-map}"
- (setq-local parse-sexp-ignore-comments t)
- (setq-local comment-start ";;")
- ;; Look within the line for a ; following an even number of backslashes
- ;; after either a non-backslash or the line beginning.
- (setq-local comment-start-skip
- "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
- (setq-local indent-line-function #'semantic-grammar-indent)
- (setq-local fill-paragraph-function #'lisp-fill-paragraph)
- (setq-local font-lock-multiline 'undecided)
- (setq-local font-lock-defaults
- '((semantic-grammar-mode-keywords
- semantic-grammar-mode-keywords-1
- semantic-grammar-mode-keywords-2
- semantic-grammar-mode-keywords-3)
- nil ;; perform string/comment fontification
- nil ;; keywords are case sensitive.
- ;; This puts _ & - as a word constituent,
- ;; simplifying our keywords significantly
- ((?_ . "w") (?- . "w"))))
- ;; Setup Semantic to parse grammar
- (semantic-grammar-wy--install-parser)
- (setq semantic-lex-comment-regex ";;"
- semantic-lex-analyzer #'semantic-grammar-lexer
- semantic-type-relation-separator-character '(":")
- semantic-symbol->name-assoc-list
- '(
- (code . "Setup Code")
- (keyword . "Keyword")
- (token . "Token")
- (nonterminal . "Nonterminal")
- (rule . "Rule")
- ))
- (setq-local semantic-format-face-alist
- '((code . default)
- (keyword . font-lock-keyword-face)
- (token . font-lock-type-face)
- (nonterminal . font-lock-function-name-face)
- (rule . default)))
- (setq-local semantic-stickyfunc-sticky-classes
- '(nonterminal))
- ;; Before each change, clear the cached regexp used to highlight
- ;; macros local in this grammar.
- (add-hook 'before-change-functions
- #'semantic--grammar-clear-macros-regexp-2 nil t)
- ;; Handle safe re-parse of grammar rules.
- (add-hook 'semantic-edits-new-change-functions
- #'semantic-grammar-edits-new-change-hook-fcn
- nil t))
-\f
-;;;;
-;;;; Useful commands
-;;;;
-
-(defvar semantic-grammar-skip-quoted-syntax-table
- (let ((st (copy-syntax-table semantic-grammar-mode-syntax-table)))
- (modify-syntax-entry ?\' "$" st)
- st)
- "Syntax table to skip a whole quoted expression in grammar code.
-Consider quote as a \"paired delimiter\", so `forward-sexp' will skip
-whole quoted expression.")
-
-(defsubst semantic-grammar-backward-item ()
- "Move point to beginning of the previous grammar item."
- (forward-comment (- (point-max)))
- (if (zerop (skip-syntax-backward "."))
- (if (eq (char-before) ?\')
- (with-syntax-table
- ;; Can't be Lisp code here! Temporarily consider quote
- ;; as a "paired delimiter", so `forward-sexp' can skip
- ;; the whole quoted expression.
- semantic-grammar-skip-quoted-syntax-table
- (forward-sexp -1))
- (forward-sexp -1))))
-
-(defun semantic-grammar-anchored-indentation ()
- "Return indentation based on previous anchor character found."
- (let (indent)
- (save-excursion
- (while (not indent)
- (semantic-grammar-backward-item)
- (cond
- ((bobp)
- (setq indent 0))
- ((looking-at ":\\(\\s-\\|$\\)")
- (setq indent (current-column))
- (forward-char)
- (skip-syntax-forward "-")
- (if (eolp) (setq indent 2))
- )
- ((and (looking-at "[;%]")
- (not (looking-at "\\<%prec\\>")))
- (setq indent 0)
- ))))
- indent))
-
-(defun semantic-grammar-do-grammar-indent ()
- "Indent a line of grammar.
-When called the point is not in Lisp code."
- (let (indent n)
- (save-excursion
- (beginning-of-line)
- (skip-syntax-forward "-")
- (setq indent (current-column))
- (cond
- ((or (bobp)
- (looking-at "\\(\\w\\|\\s_\\)+\\s-*:")
- (and (looking-at "%")
- (not (looking-at "%prec\\>"))))
- (setq n 0))
- ((looking-at ":")
- (setq n 2))
- ((and (looking-at ";;")
- (save-excursion (forward-comment (point-max))
- (looking-at ":")))
- (setq n 1))
- (t
- (setq n (semantic-grammar-anchored-indentation))
- (unless (zerop n)
- (cond
- ((looking-at ";;")
- (setq n (1- n)))
- ((looking-at "[|;]")
- )
- (t
- (setq n (+ n 2)))))))
- (when (/= n indent)
- (beginning-of-line)
- (delete-horizontal-space)
- (indent-to n)))))
-
-(defvar semantic-grammar-brackets-as-parens-syntax-table
- (let ((st (copy-syntax-table emacs-lisp-mode-syntax-table)))
- (modify-syntax-entry ?\{ "(} " st)
- (modify-syntax-entry ?\} "){ " st)
- st)
- "Syntax table that consider brackets as parenthesis.
-So `lisp-indent-line' will work inside bracket blocks.")
-
-(defun semantic-grammar-do-lisp-indent ()
- "Maybe run the Emacs Lisp indenter on a line of code.
-Return nil if not in a Lisp expression."
- (condition-case nil
- (save-excursion
- (beginning-of-line)
- (skip-chars-forward "\t ")
- (let ((first (point)))
- (or (>= first (semantic-grammar-epilogue-start))
- (up-list -1))
- (condition-case nil
- (while t
- (up-list -1))
- (error nil))
- (beginning-of-line)
- (save-restriction
- (narrow-to-region (point) first)
- (goto-char (point-max))
- (with-syntax-table
- ;; Temporarily consider brackets as parenthesis so
- ;; `lisp-indent-line' can indent Lisp code inside
- ;; brackets.
- semantic-grammar-brackets-as-parens-syntax-table
- (lisp-indent-line))))
- t)
- (error nil)))
-
-(defun semantic-grammar-indent ()
- "Indent the current line.
-Use the Lisp or grammar indenter depending on point location."
- (interactive)
- (let ((orig (point))
- first)
- (or (semantic-grammar-do-lisp-indent)
- (semantic-grammar-do-grammar-indent))
- (setq first (save-excursion
- (beginning-of-line)
- (skip-chars-forward "\t ")
- (point)))
- (if (or (< orig first) (/= orig (point)))
- (goto-char first))))
-
-(defun semantic-grammar-electric-punctuation ()
- "Insert and reindent for the symbol just typed in."
- (interactive)
- (self-insert-command 1)
- (save-excursion
- (semantic-grammar-indent)))
-
-(defun semantic-grammar-complete ()
- "Attempt to complete the symbol under point.
-Completion is position sensitive. If the cursor is in a match section of
-a rule, then nonterminals symbols are scanned. If the cursor is in a Lisp
-expression then Lisp symbols are completed."
- (interactive)
- (if (semantic-grammar-in-lisp-p)
- ;; We are in lisp code. Do lisp completion.
- (let ((completion-at-point-functions
- (append '(lisp-completion-at-point)
- completion-at-point-functions)))
- (completion-at-point))
- ;; We are not in lisp code. Do rule completion.
- (let* ((nonterms (semantic-find-tags-by-class 'nonterminal (current-buffer)))
- (sym (car (semantic-ctxt-current-symbol)))
- (ans (try-completion sym nonterms)))
- (cond ((eq ans t)
- ;; All done
- (message "Symbols is already complete"))
- ((and (stringp ans) (string= ans sym))
- ;; Max matchable. Show completions.
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list (all-completions sym nonterms)))
- )
- ((stringp ans)
- ;; Expand the completions
- (forward-sexp -1)
- (delete-region (point) (progn (forward-sexp 1) (point)))
- (insert ans))
- (t (message "No Completions."))
- ))
- ))
-
-(defun semantic-grammar-insert-keyword (name)
- "Insert a new %keyword declaration with NAME.
-Assumes it is typed in with the correct casing."
- (interactive "sKeyword: ")
- (if (not (bolp)) (insert "\n"))
- (insert "%keyword " (upcase name) " \"" name "\"
-%put " (upcase name) " summary
-\"\"\n")
- (forward-char -2))
-
-;;; Macro facilities
-;;
-
-(defsubst semantic--grammar-macro-function-tag (name)
- "Search for a function tag for the grammar macro with name NAME.
-Return the tag found or nil if not found."
- (car (semantic-find-tags-by-class
- 'function
- (or (semantic-find-tags-by-name name (current-buffer))
- (and (featurep 'semantic/db)
- semanticdb-current-database
- (cdar (semanticdb-find-tags-by-name name nil t)))))))
-
-(defsubst semantic--grammar-macro-lib-part (def)
- "Return the library part of the grammar macro defined by DEF."
- (let ((suf (format "-%s\\'" (regexp-quote (symbol-name (car def)))))
- (fun (symbol-name (cdr def))))
- (substring fun 0 (string-match suf fun))))
-
-(defun semantic--grammar-macro-compl-elt (def &optional full)
- "Return a completion entry for the grammar macro defined by DEF.
-If optional argument FULL is non-nil qualify the macro name with the
-library found in DEF."
- (let ((mac (car def))
- (lib (semantic--grammar-macro-lib-part def)))
- (cons (if full
- (format "%s/%s" mac lib)
- (symbol-name mac))
- (list mac lib))))
-
-(defun semantic--grammar-macro-compl-dict ()
- "Return a completion dictionary of macro definitions."
- (let ((defs (semantic-grammar-macros))
- def dups dict)
- (while defs
- (setq def (car defs)
- defs (cdr defs))
- (if (or (assoc (car def) defs) (assoc (car def) dups))
- (push def dups)
- (push (semantic--grammar-macro-compl-elt def) dict)))
- (while dups
- (setq def (car dups)
- dups (cdr dups))
- (push (semantic--grammar-macro-compl-elt def t) dict))
- dict))
-
-(defun semantic-grammar-find-macro-expander (macro-name library)
- "Visit the Emacs Lisp library where a grammar macro is implemented.
-MACRO-NAME is a symbol that identifies a grammar macro.
-LIBRARY is the name (sans extension) of the Emacs Lisp library where
-to start searching the macro implementation. Lookup in included
-libraries, if necessary.
-Find a function tag (in current tags table) whose name contains MACRO-NAME.
-Select the buffer containing the tag's definition, and move point there."
- (interactive
- (let* ((dic (semantic--grammar-macro-compl-dict))
- (def (assoc (completing-read "Macro: " dic nil 1) dic)))
- (or (cdr def) '(nil nil))))
- (when (and macro-name library)
- (let* ((lib (format "%s.el" library))
- (buf (find-file-noselect (or (locate-library lib t) lib)))
- (tag (with-current-buffer buf
- (semantic--grammar-macro-function-tag
- (format "%s-%s" library macro-name)))))
- (if tag
- (progn
- (require 'semantic/decorate)
- (pop-to-buffer (semantic-tag-buffer tag))
- (goto-char (semantic-tag-start tag))
- (semantic-momentary-highlight-tag tag))
- (pop-to-buffer buf)
- (message "No expander found in library %s for macro %s"
- library macro-name)))))
-
-;;; Additional help
-;;
-
-(defvar semantic-grammar-syntax-help
- '(
- ;; Lexical Symbols
- ("symbol" . "Syntax: A symbol of alpha numeric and symbol characters")
- ("number" . "Syntax: Numeric characters.")
- ("punctuation" . "Syntax: Punctuation character.")
- ("semantic-list" . "Syntax: A list delimited by any valid list characters")
- ("open-paren" . "Syntax: Open Parenthesis character")
- ("close-paren" . "Syntax: Close Parenthesis character")
- ("string" . "Syntax: String character delimited text")
- ("comment" . "Syntax: Comment character delimited text")
- ;; Special Macros
- ("EMPTY" . "Syntax: Match empty text")
- ("ASSOC" . "Lambda Key: (ASSOC key1 value1 key2 value2 ...)")
- ("EXPAND" . "Lambda Key: (EXPAND <list id> <rule>)")
- ("EXPANDFULL" . "Lambda Key: (EXPANDFULL <list id> <rule>)")
- ;; Tag Generator Macros
- ("TAG" . "Generic Tag Generation: (TAG <name> <tag-class> [ :key value ]*)")
- ("VARIABLE-TAG" . "(VARIABLE-TAG <name> <lang-type> <default-value> [ :key value ]*)")
- ("FUNCTION-TAG" . "(FUNCTION-TAG <name> <lang-type> <arg-list> [ :key value ]*)")
- ("TYPE-TAG" . "(TYPE-TAG <name> <lang-type> <part-list> <parents> [ :key value ]*)")
- ("INCLUDE-TAG" . "(INCLUDE-TAG <name> <system-flag> [ :key value ]*)")
- ("PACKAGE-TAG" . "(PACKAGE-TAG <name> <detail> [ :key value ]*)")
- ("CODE-TAG" . "(CODE-TAG <name> <detail> [ :key value ]*)")
- ("ALIAS-TAG" . "(ALIAS-TAG <name> <aliasclass> <definition> [:key value]*)")
- ;; Special value macros
- ("$1" . "Match Value: Value from match list in slot 1")
- ("$2" . "Match Value: Value from match list in slot 2")
- ("$3" . "Match Value: Value from match list in slot 3")
- ("$4" . "Match Value: Value from match list in slot 4")
- ("$5" . "Match Value: Value from match list in slot 5")
- ("$6" . "Match Value: Value from match list in slot 6")
- ("$7" . "Match Value: Value from match list in slot 7")
- ("$8" . "Match Value: Value from match list in slot 8")
- ("$9" . "Match Value: Value from match list in slot 9")
- ;; Same, but with annoying , in front.
- (",$1" . "Match Value: Value from match list in slot 1")
- (",$2" . "Match Value: Value from match list in slot 2")
- (",$3" . "Match Value: Value from match list in slot 3")
- (",$4" . "Match Value: Value from match list in slot 4")
- (",$5" . "Match Value: Value from match list in slot 5")
- (",$6" . "Match Value: Value from match list in slot 6")
- (",$7" . "Match Value: Value from match list in slot 7")
- (",$8" . "Match Value: Value from match list in slot 8")
- (",$9" . "Match Value: Value from match list in slot 9")
- )
- "Association of syntax elements, and the corresponding help.")
-
-(defvar semantic-grammar-eldoc-last-data (cons nil nil))
-
-(defun semantic--docstring-format-sym-doc (prefix doc &optional face)
- "Combine PREFIX and DOC, and shorten the result to fit in the echo area.
-
-When PREFIX is a symbol, propertize its symbol name with FACE
-before combining it with DOC. If FACE is not provided, just
-apply the nil face.
-
-See also: `eldoc-echo-area-use-multiline-p'."
- ;; Hoisted from old `eldoc-docstring-format-sym-doc'.
- ;; If the entire line cannot fit in the echo area, the symbol name may be
- ;; truncated or eliminated entirely from the output to make room for the
- ;; description.
- (when (symbolp prefix)
- (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": ")))
- (let* ((ea-multi eldoc-echo-area-use-multiline-p)
- ;; Subtract 1 from window width since emacs will not write
- ;; any chars to the last column, or in later versions, will
- ;; cause a wraparound and resize of the echo area.
- (ea-width (1- (window-width (minibuffer-window))))
- (strip (- (+ (length prefix)
- (length doc))
- ea-width)))
- (cond ((or (<= strip 0)
- (eq ea-multi t)
- (and ea-multi (> (length doc) ea-width)))
- (concat prefix doc))
- ((> (length doc) ea-width)
- (substring (format "%s" doc) 0 ea-width))
- ((>= strip (string-match-p ":? *\\'" prefix))
- doc)
- (t
- ;; Show the end of the partial symbol name, rather
- ;; than the beginning, since the former is more likely
- ;; to be unique given package namespace conventions.
- (concat (substring prefix strip) doc)))))
-
-(defun semantic-grammar-eldoc-get-macro-docstring (macro expander)
- "Return a one-line docstring for the given grammar MACRO.
-EXPANDER is the name of the function that expands MACRO."
- (require 'eldoc)
- (cond
- ((eq expander (car semantic-grammar-eldoc-last-data))
- (cdr semantic-grammar-eldoc-last-data))
- ((fboundp 'eldoc-function-argstring) ;; Emacs<25
- (let* ((doc (help-split-fundoc (documentation expander t) expander)))
- (cond
- (doc
- (setq doc (car doc))
- (string-match "\\`[^ )]* ?" doc)
- (setq doc (concat "(" (substring doc (match-end 0)))))
- (t
- (setq doc (eldoc-function-argstring expander))))
- (when doc
- (setq doc
- (semantic--docstring-format-sym-doc
- macro (format "==> %s %s" expander doc) 'default))
- (setq semantic-grammar-eldoc-last-data (cons expander doc)))
- doc))
- ((fboundp 'elisp-get-fnsym-args-string) ;; Emacs≥25
- (concat (propertize (symbol-name macro)
- 'face 'font-lock-keyword-face)
- " ==> "
- (propertize (symbol-name macro)
- 'face 'font-lock-function-name-face)
- ": "
- (elisp-get-fnsym-args-string expander nil )))))
-
-(define-mode-local-override semantic-idle-summary-current-symbol-info
- semantic-grammar-mode ()
- "Display additional eldoc information about grammar syntax elements.
-Syntax element is the current symbol at point.
-If it is associated a help string in `semantic-grammar-syntax-help',
-return that string.
-If it is a macro name, return a description of the associated expander
-function parameter list.
-If it is a function name, return a description of this function
-parameter list.
-If it is a variable name, return a brief (one-line) documentation
-string for the variable.
-If a default description of the current context can be obtained,
-return it.
-Otherwise return nil."
- (require 'eldoc)
- (let* ((elt (car (semantic-ctxt-current-symbol)))
- (val (and elt (cdr (assoc elt semantic-grammar-syntax-help)))))
- (when (and (not val) elt (semantic-grammar-in-lisp-p))
- ;; Ensure to load macro definitions before doing `intern-soft'.
- (setq val (semantic-grammar-macros)
- elt (intern-soft elt)
- val (and elt (cdr (assq elt val))))
- (cond
- ;; Grammar macro
- ((and val (fboundp val))
- (setq val (semantic-grammar-eldoc-get-macro-docstring elt val)))
- ;; Function
- ((and elt (fboundp elt))
- (setq val (if (fboundp 'eldoc-get-fnsym-args-string)
- (eldoc-get-fnsym-args-string elt)
- (elisp-get-fnsym-args-string elt))))
- ;; Variable
- ((and elt (boundp elt))
- (setq val (if (fboundp 'eldoc-get-var-docstring)
- (eldoc-get-var-docstring elt)
- (elisp-get-var-docstring elt))))
- (t nil)))
- (or val (semantic-idle-summary-current-symbol-info-default))))
-
-(define-mode-local-override semantic-tag-boundary-p
- semantic-grammar-mode (tag)
- "Return non-nil for tags that should have a boundary drawn.
-Only tags of type `nonterminal' will be so marked."
- (let ((c (semantic-tag-class tag)))
- (eq c 'nonterminal)))
-
-(define-mode-local-override semantic-ctxt-current-function
- semantic-grammar-mode (&optional point)
- "Determine the name of the current function at POINT."
- (save-excursion
- (and point (goto-char point))
- (when (semantic-grammar-in-lisp-p)
- (with-mode-local emacs-lisp-mode
- (semantic-ctxt-current-function)))))
-
-(define-mode-local-override semantic-ctxt-current-argument
- semantic-grammar-mode (&optional point)
- "Determine the argument index of the called function at POINT."
- (save-excursion
- (and point (goto-char point))
- (when (semantic-grammar-in-lisp-p)
- (with-mode-local emacs-lisp-mode
- (semantic-ctxt-current-argument)))))
-
-(define-mode-local-override semantic-ctxt-current-assignment
- semantic-grammar-mode (&optional point)
- "Determine the tag being assigned into at POINT."
- (save-excursion
- (and point (goto-char point))
- (when (semantic-grammar-in-lisp-p)
- (with-mode-local emacs-lisp-mode
- (semantic-ctxt-current-assignment)))))
-
-(define-mode-local-override semantic-ctxt-current-class-list
- semantic-grammar-mode (&optional point)
- "Determine the class of tags that can be used at POINT."
- (save-excursion
- (and point (goto-char point))
- (if (semantic-grammar-in-lisp-p)
- (with-mode-local emacs-lisp-mode
- (semantic-ctxt-current-class-list))
- '(nonterminal token keyword))))
-
-(define-mode-local-override semantic-ctxt-current-mode
- semantic-grammar-mode (&optional point)
- "Return the major mode active at POINT.
-POINT defaults to the value of point in current buffer.
-Return `emacs-lisp-mode' is POINT is within Lisp code, otherwise
-return the current major mode."
- (save-excursion
- (and point (goto-char point))
- (if (semantic-grammar-in-lisp-p)
- 'emacs-lisp-mode
- (semantic-ctxt-current-mode-default))))
-
-(define-mode-local-override semantic-format-tag-abbreviate
- semantic-grammar-mode (tag &optional parent color)
- "Return a string abbreviation of TAG.
-Optional PARENT is not used.
-Optional COLOR is used to flag if color is added to the text."
- (let ((class (semantic-tag-class tag))
- (name (semantic-format-tag-name tag parent color)))
- (cond
- ((eq class 'nonterminal)
- (concat name ":"))
- ((eq class 'setting)
- "%settings%")
- ((memq class '(rule keyword))
- name)
- (t
- (concat "%" (symbol-name class) " " name)))))
-
-(define-mode-local-override semantic-format-tag-summarize
- semantic-grammar-mode (tag &optional parent color)
- "Return a string summarizing TAG.
-Optional PARENT is not used.
-Optional argument COLOR determines if color is added to the text."
- (let ((class (semantic-tag-class tag))
- (name (semantic-format-tag-name tag parent color))
- (label nil)
- (desc nil))
- (cond
- ((eq class 'nonterminal)
- (setq label "Nonterminal: "
- desc (format
- " with %d match lists."
- (length (semantic-tag-components tag)))))
- ((eq class 'keyword)
- (setq label "Keyword: ")
- (let (summary)
- (semantic--find-tags-by-function
- (lambda (put)
- (unless summary
- (setq summary (cdr (assoc "summary"
- (semantic-tag-get-attribute
- put :value))))))
- ;; Get `put' tag with TAG name.
- (semantic-find-tags-by-name-regexp
- (regexp-quote (semantic-tag-name tag))
- (semantic-find-tags-by-class 'put (current-buffer))))
- (setq desc (concat " = "
- (semantic-tag-get-attribute tag :value)
- (if summary
- (concat " - " (read summary))
- "")))))
- ((eq class 'token)
- (setq label "Token: ")
- (let ((val (semantic-tag-get-attribute tag :value))
- (names (semantic-tag-get-attribute tag :rest))
- (type (semantic-tag-type tag)))
- (if names
- (setq name (mapconcat #'identity (cons name names) " ")))
- (setq desc (concat
- (if type
- (format " <%s>" type)
- "")
- (if val
- (format "%s%S" val (if type " " ""))
- "")))))
- ((eq class 'assoc)
- (setq label "Assoc: ")
- (let ((val (semantic-tag-get-attribute tag :value))
- (type (semantic-tag-type tag)))
- (setq desc (concat
- (if type
- (format " <%s>" type)
- "")
- (if val
- (concat " " (mapconcat #'identity val " "))
- "")))))
- (t
- (setq desc (semantic-format-tag-abbreviate tag parent color))))
- (if (and color label)
- (setq label (semantic--format-colorize-text label 'label)))
- (if (and color label desc)
- (setq desc (semantic--format-colorize-text desc 'comment)))
- (if label
- (concat label name desc)
- ;; Just a description is the abbreviated version
- desc)))
-
-;;; Semantic Analysis
-
-(define-mode-local-override semantic-analyze-current-context
- semantic-grammar-mode (point)
- "Provide a semantic analysis object describing a context in a grammar."
- (if (semantic-grammar-in-lisp-p)
- (with-mode-local emacs-lisp-mode
- (semantic-analyze-current-context point))
-
- (let* ((context-return nil)
- (prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
- (prefix (car prefixandbounds))
- (bounds (nth 2 prefixandbounds))
- (prefixsym nil)
- (prefixclass (semantic-ctxt-current-class-list))
- )
-
- ;; Do context for rules when in a match list.
- (setq prefixsym
- (semantic-find-first-tag-by-name
- (car prefix)
- (current-buffer)))
-
- (setq context-return
- (semantic-analyze-context
- :buffer (current-buffer)
- :scope nil
- :bounds bounds
- :prefix (if prefixsym
- (list prefixsym)
- prefix)
- :prefixtypes nil
- :prefixclass prefixclass
- ))
-
- context-return)))
-
-(define-mode-local-override semantic-analyze-possible-completions
- semantic-grammar-mode (context &rest _flags)
- "Return a list of possible completions based on CONTEXT."
- (require 'semantic/analyze/complete)
- (if (semantic-grammar-in-lisp-p)
- (with-mode-local emacs-lisp-mode
- (semantic-analyze-possible-completions context))
- (with-current-buffer (oref context buffer)
- (let* ((prefix (car (reverse (oref context prefix))))
- (completetext (cond ((semantic-tag-p prefix)
- (semantic-tag-name prefix))
- ((stringp prefix)
- prefix)
- ((stringp (car prefix))
- (car prefix))))
- (tags (semantic-find-tags-for-completion completetext
- (current-buffer))))
- (semantic-analyze-tags-of-class-list
- tags (oref context prefixclass)))
- )))
-
-(provide 'semantic/grammar)
-
-\f
-;; Local variables:
-;; generated-autoload-load-name: "semantic/grammar"
-;; End:
-
-;;; semantic/grammar.el ends here
+++ /dev/null
-;;; semantic/grammar-wy.el --- Generated parser support file -*- lexical-binding:t -*-
-
-;; Copyright (C) 2002-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This file was generated from admin/grammars/grammar.wy.
-
-;;; Code:
-
-(require 'semantic/lex)
-(require 'semantic/wisent)
-\f
-;;; Prologue
-;;
-(defvar semantic-grammar-lex-c-char-re)
-
-;; Current parsed nonterminal name.
-(defvar semantic-grammar-wy--nterm nil)
-;; Index of rule in a nonterminal clause.
-(defvar semantic-grammar-wy--rindx nil)
-\f
-;;; Declarations
-;;
-(eval-and-compile (defconst semantic-grammar-wy--expected-conflicts
- nil
- "The number of expected shift/reduce conflicts in this grammar."))
-
-(defconst semantic-grammar-wy--keyword-table
- (semantic-lex-make-keyword-table
- '(("%default-prec" . DEFAULT-PREC)
- ("%no-default-prec" . NO-DEFAULT-PREC)
- ("%keyword" . KEYWORD)
- ("%languagemode" . LANGUAGEMODE)
- ("%left" . LEFT)
- ("%nonassoc" . NONASSOC)
- ("%package" . PACKAGE)
- ("%expectedconflicts" . EXPECTEDCONFLICTS)
- ("%provide" . PROVIDE)
- ("%prec" . PREC)
- ("%put" . PUT)
- ("%quotemode" . QUOTEMODE)
- ("%right" . RIGHT)
- ("%scopestart" . SCOPESTART)
- ("%start" . START)
- ("%token" . TOKEN)
- ("%type" . TYPE)
- ("%use-macros" . USE-MACROS))
- 'nil)
- "Table of language keywords.")
-
-(defconst semantic-grammar-wy--token-table
- (semantic-lex-make-type-table
- '(("punctuation"
- (GT . ">")
- (LT . "<")
- (OR . "|")
- (SEMI . ";")
- (COLON . ":"))
- ("close-paren"
- (RBRACE . "}")
- (RPAREN . ")"))
- ("open-paren"
- (LBRACE . "{")
- (LPAREN . "("))
- ("block"
- (BRACE_BLOCK . "(LBRACE RBRACE)")
- (PAREN_BLOCK . "(LPAREN RPAREN)"))
- ("code"
- (EPILOGUE . "%%...EOF")
- (PROLOGUE . "%{...%}"))
- ("sexp"
- (SEXP))
- ("qlist"
- (PREFIXED_LIST))
- ("char"
- (CHARACTER))
- ("symbol"
- (PERCENT_PERCENT . "\\`%%\\'")
- (SYMBOL))
- ("string"
- (STRING)))
- '(("punctuation" :declared t)
- ("block" :declared t)
- ("sexp" matchdatatype sexp)
- ("sexp" syntax "\\=")
- ("sexp" :declared t)
- ("qlist" matchdatatype sexp)
- ("qlist" syntax "\\s'\\s-*(")
- ("qlist" :declared t)
- ("char" syntax semantic-grammar-lex-c-char-re)
- ("char" :declared t)
- ("symbol" syntax ":?\\(\\sw\\|\\s_\\)+")
- ("symbol" :declared t)
- ("string" :declared t)
- ("keyword" :declared t)))
- "Table of lexical tokens.")
-
-(defconst semantic-grammar-wy--parse-table
- (wisent-compiled-grammar
- ((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE LEFT NONASSOC PACKAGE EXPECTEDCONFLICTS PROVIDE PREC PUT QUOTEMODE RIGHT SCOPESTART START TOKEN TYPE USE-MACROS STRING SYMBOL PERCENT_PERCENT CHARACTER PREFIXED_LIST SEXP PROLOGUE EPILOGUE PAREN_BLOCK BRACE_BLOCK LPAREN RPAREN LBRACE RBRACE COLON SEMI OR LT GT)
- nil
- (grammar
- ((prologue))
- ((epilogue))
- ((declaration))
- ((nonterminal))
- ((PERCENT_PERCENT)))
- (prologue
- ((PROLOGUE)
- (wisent-raw-tag
- (semantic-tag-new-code "prologue" nil))))
- (epilogue
- ((EPILOGUE)
- (wisent-raw-tag
- (semantic-tag-new-code "epilogue" nil))))
- (declaration
- ((decl)
- (eval $1 t)))
- (decl
- ((default_prec_decl))
- ((no_default_prec_decl))
- ((languagemode_decl))
- ((package_decl))
- ((expectedconflicts_decl))
- ((provide_decl))
- ((precedence_decl))
- ((put_decl))
- ((quotemode_decl))
- ((scopestart_decl))
- ((start_decl))
- ((keyword_decl))
- ((token_decl))
- ((type_decl))
- ((use_macros_decl)))
- (default_prec_decl
- ((DEFAULT-PREC)
- `(wisent-raw-tag
- (semantic-tag "default-prec" 'assoc :value
- '("t")))))
- (no_default_prec_decl
- ((NO-DEFAULT-PREC)
- `(wisent-raw-tag
- (semantic-tag "default-prec" 'assoc :value
- '("nil")))))
- (languagemode_decl
- ((LANGUAGEMODE symbols)
- `(wisent-raw-tag
- (semantic-tag ',(car $2)
- 'languagemode :rest ',(cdr $2)))))
- (package_decl
- ((PACKAGE SYMBOL)
- `(wisent-raw-tag
- (semantic-tag-new-package ',$2 nil))))
- (expectedconflicts_decl
- ((EXPECTEDCONFLICTS symbols)
- `(wisent-raw-tag
- (semantic-tag ',(car $2)
- 'expectedconflicts :rest ',(cdr $2)))))
- (provide_decl
- ((PROVIDE SYMBOL)
- `(wisent-raw-tag
- (semantic-tag ',$2 'provide))))
- (precedence_decl
- ((associativity token_type_opt items)
- `(wisent-raw-tag
- (semantic-tag ',$1 'assoc :type ',$2 :value ',$3))))
- (associativity
- ((LEFT)
- (progn "left"))
- ((RIGHT)
- (progn "right"))
- ((NONASSOC)
- (progn "nonassoc")))
- (put_decl
- ((PUT put_name put_value)
- `(wisent-raw-tag
- (semantic-tag ',$2 'put :value ',(list $3))))
- ((PUT put_name put_value_list)
- `(wisent-raw-tag
- (semantic-tag ',$2 'put :value ',$3)))
- ((PUT put_name_list put_value)
- `(wisent-raw-tag
- (semantic-tag ',(car $2)
- 'put :rest ',(cdr $2)
- :value ',(list $3))))
- ((PUT put_name_list put_value_list)
- `(wisent-raw-tag
- (semantic-tag ',(car $2)
- 'put :rest ',(cdr $2)
- :value ',$3))))
- (put_name_list
- ((BRACE_BLOCK)
- (mapcar #'semantic-tag-name
- (semantic-parse-region
- (car $region1)
- (cdr $region1)
- 'put_names 1))))
- (put_names
- ((LBRACE)
- nil)
- ((RBRACE)
- nil)
- ((put_name)
- (wisent-raw-tag
- (semantic-tag $1 'put-name))))
- (put_name
- ((SYMBOL))
- ((token_type)))
- (put_value_list
- ((BRACE_BLOCK)
- (mapcar #'semantic-tag-code-detail
- (semantic-parse-region
- (car $region1)
- (cdr $region1)
- 'put_values 1))))
- (put_values
- ((LBRACE)
- nil)
- ((RBRACE)
- nil)
- ((put_value)
- (wisent-raw-tag
- (semantic-tag-new-code "put-value" $1))))
- (put_value
- ((SYMBOL any_value)
- (cons $1 $2)))
- (scopestart_decl
- ((SCOPESTART SYMBOL)
- `(wisent-raw-tag
- (semantic-tag ',$2 'scopestart))))
- (quotemode_decl
- ((QUOTEMODE SYMBOL)
- `(wisent-raw-tag
- (semantic-tag ',$2 'quotemode))))
- (start_decl
- ((START symbols)
- `(wisent-raw-tag
- (semantic-tag ',(car $2)
- 'start :rest ',(cdr $2)))))
- (keyword_decl
- ((KEYWORD SYMBOL string_value)
- `(wisent-raw-tag
- (semantic-tag ',$2 'keyword :value ',$3))))
- (token_decl
- ((TOKEN token_type_opt SYMBOL string_value)
- `(wisent-raw-tag
- (semantic-tag ',$3 ',(if $2 'token 'keyword)
- :type ',$2 :value ',$4)))
- ((TOKEN token_type_opt symbols)
- `(wisent-raw-tag
- (semantic-tag ',(car $3)
- 'token :type ',$2 :rest ',(cdr $3)))))
- (token_type_opt
- (nil)
- ((token_type)))
- (token_type
- ((LT SYMBOL GT)
- (progn $2)))
- (type_decl
- ((TYPE token_type plist_opt)
- `(wisent-raw-tag
- (semantic-tag ',$2 'type :value ',$3))))
- (plist_opt
- (nil)
- ((plist)))
- (plist
- ((plist put_value)
- (append
- (list $2)
- $1))
- ((put_value)
- (list $1)))
- (use_name_list
- ((BRACE_BLOCK)
- (mapcar #'semantic-tag-name
- (semantic-parse-region
- (car $region1)
- (cdr $region1)
- 'use_names 1))))
- (use_names
- ((LBRACE)
- nil)
- ((RBRACE)
- nil)
- ((SYMBOL)
- (wisent-raw-tag
- (semantic-tag $1 'use-name))))
- (use_macros_decl
- ((USE-MACROS SYMBOL use_name_list)
- `(wisent-raw-tag
- (semantic-tag "macro" 'macro :type ',$2 :value ',$3))))
- (string_value
- ((STRING)
- (read $1)))
- (any_value
- ((SYMBOL))
- ((STRING))
- ((PAREN_BLOCK))
- ((PREFIXED_LIST))
- ((SEXP)))
- (symbols
- ((lifo_symbols)
- (nreverse $1)))
- (lifo_symbols
- ((lifo_symbols SYMBOL)
- (cons $2 $1))
- ((SYMBOL)
- (list $1)))
- (nonterminal
- ((SYMBOL
- (setq semantic-grammar-wy--nterm $1 semantic-grammar-wy--rindx 0)
- COLON rules SEMI)
- (wisent-raw-tag
- (semantic-tag $1 'nonterminal :children $4))))
- (rules
- ((lifo_rules)
- (apply #'nconc
- (nreverse $1))))
- (lifo_rules
- ((lifo_rules OR rule)
- (cons $3 $1))
- ((rule)
- (list $1)))
- (rule
- ((rhs)
- (let*
- ((nterm semantic-grammar-wy--nterm)
- (rindx semantic-grammar-wy--rindx)
- (rhs $1)
- comps prec action elt)
- (setq semantic-grammar-wy--rindx
- (1+ semantic-grammar-wy--rindx))
- (while rhs
- (setq elt
- (car rhs)
- rhs
- (cdr rhs))
- (cond
- ((vectorp elt)
- (if prec
- (error "Duplicate %%prec in `%s:%d' rule" nterm rindx))
- (setq prec
- (aref elt 0)))
- ((consp elt)
- (if
- (or action comps)
- (setq comps
- (cons elt comps)
- semantic-grammar-wy--rindx
- (1+ semantic-grammar-wy--rindx))
- (setq action
- (car elt))))
- (t
- (setq comps
- (cons elt comps)))))
- (wisent-cook-tag
- (wisent-raw-tag
- (semantic-tag
- (format "%s:%d" nterm rindx)
- 'rule :type
- (if comps "group" "empty")
- :value comps :prec prec :expr action))))))
- (rhs
- (nil)
- ((rhs item)
- (cons $2 $1))
- ((rhs action)
- (cons
- (list $2)
- $1))
- ((rhs PREC item)
- (cons
- (vector $3)
- $1)))
- (action
- ((PAREN_BLOCK))
- ((PREFIXED_LIST))
- ((BRACE_BLOCK)
- (format "(progn\n%s)"
- (let
- ((s $1))
- (if
- (string-match "^{[\r\n ]*" s)
- (setq s
- (substring s
- (match-end 0))))
- (if
- (string-match "[\r\n ]*}$" s)
- (setq s
- (substring s 0
- (match-beginning 0))))
- s))))
- (items
- ((lifo_items)
- (nreverse $1)))
- (lifo_items
- ((lifo_items item)
- (cons $2 $1))
- ((item)
- (list $1)))
- (item
- ((SYMBOL))
- ((CHARACTER))))
- (grammar prologue epilogue declaration nonterminal rule put_names put_values use_names))
- "Parser table.")
-
-(defun semantic-grammar-wy--install-parser ()
- "Setup the Semantic Parser."
- (semantic-install-function-overrides
- '((semantic-parse-stream . wisent-parse-stream)))
- (setq semantic-parser-name "LALR"
- semantic--parse-table semantic-grammar-wy--parse-table
- semantic-debug-parser-source "grammar.wy"
- semantic-flex-keywords-obarray semantic-grammar-wy--keyword-table
- semantic-lex-types-obarray semantic-grammar-wy--token-table)
- ;; Collect unmatched syntax lexical tokens
- (add-hook 'wisent-discarding-token-functions
- #'wisent-collect-unmatched-syntax nil t))
-
-\f
-;;; Analyzers
-;;
-(define-lex-keyword-type-analyzer semantic-grammar-wy--<keyword>-keyword-analyzer
- "keyword analyzer for <keyword> tokens."
- "\\(\\sw\\|\\s_\\)+")
-
-(define-lex-regex-type-analyzer semantic-grammar-wy--<char>-regexp-analyzer
- "regexp analyzer for <char> tokens."
- semantic-grammar-lex-c-char-re
- nil
- 'CHARACTER)
-
-(define-lex-sexp-type-analyzer semantic-grammar-wy--<string>-sexp-analyzer
- "sexp analyzer for <string> tokens."
- "\\s\""
- 'STRING)
-
-(define-lex-block-type-analyzer semantic-grammar-wy--<block>-block-analyzer
- "block analyzer for <block> tokens."
- "\\s(\\|\\s)"
- '((("(" LPAREN PAREN_BLOCK)
- ("{" LBRACE BRACE_BLOCK))
- (")" RPAREN)
- ("}" RBRACE))
- )
-
-(define-lex-string-type-analyzer semantic-grammar-wy--<punctuation>-string-analyzer
- "string analyzer for <punctuation> tokens."
- "\\(\\s.\\|\\s$\\|\\s'\\)+"
- '((GT . ">")
- (LT . "<")
- (OR . "|")
- (SEMI . ";")
- (COLON . ":"))
- 'punctuation)
-
-(define-lex-regex-type-analyzer semantic-grammar-wy--<symbol>-regexp-analyzer
- "regexp analyzer for <symbol> tokens."
- ":?\\(\\sw\\|\\s_\\)+"
- '((PERCENT_PERCENT . "\\`%%\\'"))
- 'SYMBOL)
-
-(define-lex-sexp-type-analyzer semantic-grammar-wy--<qlist>-sexp-analyzer
- "sexp analyzer for <qlist> tokens."
- "\\s'\\s-*("
- 'PREFIXED_LIST)
-
-(define-lex-sexp-type-analyzer semantic-grammar-wy--<sexp>-sexp-analyzer
- "sexp analyzer for <sexp> tokens."
- "\\="
- 'SEXP)
-
-\f
-;;; Epilogue
-;;
-
-
-
-
-(provide 'semantic/grammar-wy)
-
-;; Local Variables:
-;; version-control: never
-;; no-update-autoloads: t
-;; End:
-
-;;; semantic/grammar-wy.el ends here
+++ /dev/null
-;;; semantic/html.el --- Semantic details for html files -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2004-2005, 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Parse HTML files and organize them in a nice way.
-;; Pay attention to anchors, including them in the tag list.
-;;
-;; Copied from the original semantic-texi.el.
-;;
-;; ToDo: Find <script> tags, and parse the contents in other
-;; parsers, such as javascript, php, shtml, or others.
-
-;;; Code:
-
-(require 'semantic)
-(require 'semantic/format)
-(require 'sgml-mode)
-
-(defvar semantic-command-separation-character)
-
-(defvar semantic-html-super-regex
- "<\\(h[1-9]\\|title\\|script\\|body\\|a +href\\)\\>"
- "Regular expression used to find special sections in an HTML file.")
-
-(defvar semantic-html-section-list
- '(("title" 1)
- ("script" 1)
- ("body" 1)
- ("a" 11)
- ("h1" 2)
- ("h2" 3)
- ("h3" 4)
- ("h4" 5)
- ("h5" 6)
- ("h6" 7)
- ("h7" 8)
- ("h8" 9)
- ("h9" 10)
- )
- "Alist of sectioning commands and their relative level.")
-
-(define-mode-local-override semantic-parse-region
- html-mode (&rest _ignore)
- "Parse the current html buffer for semantic tags.
-IGNORE any arguments. Always parse the whole buffer.
-Each tag returned is of the form:
- (\"NAME\" section (:members CHILDREN))
-or
- (\"NAME\" anchor)"
- (mapcar #'semantic-html-expand-tag
- (semantic-html-parse-headings)))
-
-(define-mode-local-override semantic-parse-changes
- html-mode ()
- "We can't parse changes for HTML mode right now."
- (semantic-parse-tree-set-needs-rebuild))
-
-(defun semantic-html-expand-tag (tag)
- "Expand the HTML tag TAG."
- (let ((chil (semantic-html-components tag)))
- (if chil
- (semantic-tag-put-attribute
- tag :members (mapcar #'semantic-html-expand-tag chil)))
- (car (semantic--tag-expand tag))))
-
-(define-mode-local-override semantic-tag-components html-mode (tag)
- "Return components belonging to TAG."
- ;; Keep this η-regexp because `semantic-html-components' is called
- ;; from elsewhere.
- (semantic-html-components tag))
-(defun semantic-html-components (tag)
- "Return components belonging to TAG."
- (semantic-tag-get-attribute tag :members))
-
-(defun semantic-html-parse-headings ()
- "Parse the current html buffer for all semantic tags."
- (let ((pass1 nil))
- ;; First search and snarf.
- (save-excursion
- (goto-char (point-min))
-
- (let ((semantic--progress-reporter
- (make-progress-reporter
- (format "Parsing %s..."
- (file-name-nondirectory buffer-file-name))
- (point-min) (point-max))))
- (while (re-search-forward semantic-html-super-regex nil t)
- (setq pass1 (cons (match-beginning 0) pass1))
- (progress-reporter-update semantic--progress-reporter (point)))
- (progress-reporter-done semantic--progress-reporter)))
-
- (setq pass1 (nreverse pass1))
- ;; Now, make some tags while creating a set of children.
- (car (semantic-html-recursive-combobulate-list pass1 0))
- ))
-
-(defun semantic-html-set-endpoint (metataglist pnt)
- "Set the end point of the first section tag in METATAGLIST to PNT.
-METATAGLIST is a list of tags in the intermediate tag format used by the
-html parser. PNT is the new point to set."
- (let ((metatag nil))
- (while (and metataglist
- (not (eq (semantic-tag-class (car metataglist)) 'section)))
- (setq metataglist (cdr metataglist)))
- (setq metatag (car metataglist))
- (when metatag
- (setcar (nthcdr (1- (length metatag)) metatag) pnt)
- metatag)))
-
-(defsubst semantic-html-new-section-tag (name members level start end)
- "Create a semantic tag of class section.
-NAME is the name of this section.
-MEMBERS is a list of semantic tags representing the elements that make
-up this section.
-LEVEL is the leveling level.
-START and END define the location of data described by the tag."
- (let ((anchorp (eq level 11)))
- (append (semantic-tag name
- (cond (anchorp 'anchor)
- (t 'section))
- :members members)
- (list start (if anchorp (point) end)) )))
-
-(defun semantic-html-extract-section-name ()
- "Extract a section name from the current buffer and point.
-Assume the cursor is in the tag representing the section we
-need the name from."
- (save-excursion
- ; Skip over the HTML tag.
- (forward-sexp -1)
- (forward-char -1)
- (forward-sexp 1)
- (skip-chars-forward "\n\t ")
- (while (looking-at "<")
- (forward-sexp 1)
- (skip-chars-forward "\n\t ")
- )
- (let ((start (point))
- (end nil))
- (if (re-search-forward "</" nil t)
- (progn
- (goto-char (match-beginning 0))
- (skip-chars-backward " \n\t")
- (setq end (point))
- (buffer-substring-no-properties start end))
- ""))
- ))
-
-(defun semantic-html-recursive-combobulate-list (sectionlist level)
- "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL.
-Return the rearranged new list, with all remaining tags from
-SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a
-tag with greater section value than LEVEL is found."
- (let ((newl nil)
- (oldl sectionlist)
- (case-fold-search t)
- tag
- )
- (save-excursion
- (catch 'level-jump
- (while oldl
- (goto-char (car oldl))
- (if (looking-at "<\\(\\w+\\)")
- (let* ((word (match-string 1))
- (levelmatch (assoc-string
- word semantic-html-section-list t))
- text begin tmp
- )
- (when (not levelmatch)
- (error "Tag %s matched in regexp but is not in list"
- word))
- ;; Set begin to the right location
- (setq begin (point))
- ;; Get out of here if there if we made it that far.
- (if (and levelmatch (<= (car (cdr levelmatch)) level))
- (progn
- (when newl
- (semantic-html-set-endpoint newl begin))
- (throw 'level-jump t)))
- ;; When there is a match, the descriptive text
- ;; consists of the rest of the line.
- (goto-char (match-end 1))
- (skip-chars-forward " \t")
- (setq text (semantic-html-extract-section-name))
- ;; Next, recurse into the body to find the end.
- (setq tmp (semantic-html-recursive-combobulate-list
- (cdr oldl) (car (cdr levelmatch))))
- ;; Build a tag
- (setq tag (semantic-html-new-section-tag
- text (car tmp) (car (cdr levelmatch)) begin (point-max)))
- ;; Before appending the newtag, update the previous tag
- ;; if it is a section tag.
- (when newl
- (semantic-html-set-endpoint newl begin))
- ;; Append new tag to our master list.
- (setq newl (cons tag newl))
- ;; continue
- (setq oldl (cdr tmp))
- )
- (error "Problem finding section in semantic/html parser"))
- ;; (setq oldl (cdr oldl))
- )))
- ;; Return the list
- (cons (nreverse newl) oldl)))
-
-(define-mode-local-override semantic-sb-tag-children-to-expand
- html-mode (tag)
- "The children TAG expands to."
- (semantic-html-components tag))
-
-;; In semantic/imenu.el, not part of Emacs.
-(defvar semantic-imenu-expandable-tag-classes)
-(defvar semantic-imenu-bucketize-file)
-(defvar semantic-imenu-bucketize-type-members)
-
-;;;###autoload
-(defun semantic-default-html-setup ()
- "Set up a buffer for parsing of HTML files."
- ;; This will use our parser.
- (setq semantic-parser-name "HTML"
- semantic--parse-table t
- imenu-create-index-function #'semantic-create-imenu-index
- semantic-command-separation-character ">"
- semantic-type-relation-separator-character '(":")
- semantic-symbol->name-assoc-list '((section . "Section")
-
- )
- semantic-imenu-expandable-tag-classes '(section)
- semantic-imenu-bucketize-file nil
- semantic-imenu-bucketize-type-members nil
- senator-step-at-start-end-tag-classes '(section)
- senator-step-at-tag-classes '(section)
- semantic-stickyfunc-sticky-classes '(section)
- ))
-
-;; `html-helper-mode' hasn't been updated since 2004, so it's not very
-;; relevant nowadays.
-;;(define-child-mode html-helper-mode html-mode
-;; "`html-helper-mode' needs the same semantic support as `html-mode'.")
-
-(provide 'semantic/html)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/html"
-;; End:
-
-;;; semantic/html.el ends here
+++ /dev/null
-;;; semantic/ia-sb.el --- Speedbar analysis display interactor -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Speedbar node for displaying derived context information.
-;;
-
-(require 'semantic/analyze)
-(require 'speedbar)
-
-;;; Code:
-(defvar semantic-ia-sb-key-map
- (let ((map (speedbar-make-specialized-keymap)))
- ;; Basic features.
- (define-key map "\C-m" #'speedbar-edit-line)
- (define-key map "I" #'semantic-ia-sb-show-tag-info)
- map)
- "Keymap used when in semantic analysis display mode.")
-
-(defvar semantic-ia-sb-easymenu-definition
- '( "---"
-; [ "Expand" speedbar-expand-line nil ]
-; [ "Contract" speedbar-contract-line nil ]
- [ "Tag Information" semantic-ia-sb-show-tag-info t ]
- [ "Jump to Tag" speedbar-edit-line t ]
- [ "Complete" speedbar-edit-line t ]
- )
- "Extra menu items Analysis mode.")
-
-;; Make sure our special speedbar major mode is loaded
-(speedbar-add-expansion-list '("Analyze"
- semantic-ia-sb-easymenu-definition
- semantic-ia-sb-key-map
- semantic-ia-speedbar))
-
-(speedbar-add-mode-functions-list
- (list "Analyze"
- ;;'(speedbar-item-info . eieio-speedbar-item-info)
- '(speedbar-line-directory . semantic-ia-sb-line-path)))
-
-;;;###autoload
-(defun semantic-speedbar-analysis ()
- "Start Speedbar in semantic analysis mode.
-The analyzer displays information about the current context, plus a smart
-list of possible completions."
- (interactive)
- ;; Make sure that speedbar is active
- (speedbar-frame-mode 1)
- ;; Now, throw us into Analyze mode on speedbar.
- (speedbar-change-initial-expansion-list "Analyze")
- )
-
-(defun semantic-ia-speedbar (_directory _zero)
- "Create buttons in speedbar which define the current analysis at POINT.
-DIRECTORY is the current directory, which is ignored, and ZERO is 0."
- (let ((analysis nil)
- (scope nil)
- (buffer nil)
- (completions nil)
- (cf (selected-frame))
- (cnt nil)
- (mode-local-active-mode nil)
- )
- ;; Try and get some sort of analysis
- (condition-case nil
- (progn
- (speedbar-select-attached-frame)
- (setq buffer (current-buffer))
- (setq mode-local-active-mode major-mode)
- (save-excursion
- ;; Get the current scope
- (setq scope (semantic-calculate-scope (point)))
- ;; Get the analysis
- (setq analysis (semantic-analyze-current-context (point)))
- (setq cnt (semantic-find-tag-by-overlay))
- (when analysis
- (setq completions (semantic-analyze-possible-completions analysis))
- )
- ))
- (error nil))
- (select-frame cf)
- (with-current-buffer speedbar-buffer
- ;; If we have something, do something spiff with it.
- (erase-buffer)
- (speedbar-insert-separator "Buffer/Function")
- ;; Note to self: Turn this into an expandable file name.
- (speedbar-make-tag-line 'bracket ? nil nil
- (buffer-name buffer)
- nil nil 'speedbar-file-face 0)
-
- (when cnt
- (semantic-ia-sb-string-list cnt
- 'speedbar-tag-face
- 'semantic-sb-token-jump))
- (when analysis
- ;; If this analyzer happens to point at a complete symbol, then
- ;; see if we can dig up some documentation for it.
- (semantic-ia-sb-show-doc analysis))
-
- (when analysis
- ;; Let different classes draw more buttons.
- (semantic-ia-sb-more-buttons analysis)
- (when completions
- (speedbar-insert-separator "Completions")
- (semantic-ia-sb-completion-list completions
- 'speedbar-tag-face
- 'semantic-ia-sb-complete))
- )
-
- ;; Show local variables
- (when scope
- (semantic-ia-sb-show-scope scope))
-
- )))
-
-(cl-defmethod semantic-ia-sb-show-doc ((context semantic-analyze-context))
- "Show documentation about CONTEXT if CONTEXT points at a complete symbol."
- (let ((sym (car (reverse (oref context prefix))))
- (doc nil))
- (when (semantic-tag-p sym)
- (setq doc (semantic-documentation-for-tag sym))
- (when doc
- (speedbar-insert-separator "Documentation")
- (insert doc)
- (insert "\n")
- ))
- ))
-
-(defun semantic-ia-sb-show-scope (scope)
- "Show SCOPE information."
- (let ((localvars (when scope
- (oref scope localvar)))
- )
- (when localvars
- (speedbar-insert-separator "Local Variables")
- (semantic-ia-sb-string-list localvars
- 'speedbar-tag-face
- ;; This is from semantic-sb
- 'semantic-sb-token-jump))))
-
-(cl-defmethod semantic-ia-sb-more-buttons ((context semantic-analyze-context))
- "Show a set of speedbar buttons specific to CONTEXT."
- (let ((prefix (oref context prefix)))
- (when prefix
- (speedbar-insert-separator "Prefix")
- (semantic-ia-sb-string-list prefix
- 'speedbar-tag-face
- 'semantic-sb-token-jump))
- ))
-
-(cl-defmethod semantic-ia-sb-more-buttons ((context semantic-analyze-context-assignment))
- "Show a set of speedbar buttons specific to CONTEXT."
- (cl-call-next-method)
- (let ((assignee (oref context assignee)))
- (when assignee
- (speedbar-insert-separator "Assignee")
- (semantic-ia-sb-string-list assignee
- 'speedbar-tag-face
- 'semantic-sb-token-jump))))
-
-(cl-defmethod semantic-ia-sb-more-buttons ((context semantic-analyze-context-functionarg))
- "Show a set of speedbar buttons specific to CONTEXT."
- (cl-call-next-method)
- (let ((func (oref context function)))
- (when func
- (speedbar-insert-separator "Function")
- (semantic-ia-sb-string-list func
- 'speedbar-tag-face
- 'semantic-sb-token-jump)
- ;; An index for the argument the prefix is in:
- (let ((arg (oref context argument))
- (args (semantic-tag-function-arguments (car func)))
- ;; (idx 0)
- )
- (speedbar-insert-separator
- (format "Argument #%d" (oref context index)))
- (if args
- (semantic-ia-sb-string-list args
- 'speedbar-tag-face
- 'semantic-sb-token-jump
- (oref context index)
- 'speedbar-selected-face)
- ;; Else, no args list, so use what the context had.
- (semantic-ia-sb-string-list arg
- 'speedbar-tag-face
- 'semantic-sb-token-jump))
- ))))
-
-(defun semantic-ia-sb-string-list (list face function &optional idx idxface)
- "Create some speedbar buttons from LIST.
-Each button will use FACE, and be activated with FUNCTION.
-Optional IDX is an index into LIST to apply IDXFACE instead."
- (let ((count 1))
- (while list
- (let* ((usefn nil)
- (string (cond ((stringp (car list))
- (car list))
- ((semantic-tag-p (car list))
- (setq usefn (semantic-tag-with-position-p (car list)))
- (semantic-format-tag-uml-concise-prototype (car list)))
- (t "<No Tag>")))
- (localface (if (or (not idx) (/= idx count))
- face
- idxface))
- )
- (if (semantic-tag-p (car list))
- (speedbar-make-tag-line 'angle ?i
- 'semantic-ia-sb-tag-info (car list)
- string (if usefn function) (car list) localface
- 0)
- (speedbar-make-tag-line 'statictag ??
- nil nil
- string (if usefn function) (car list) localface
- 0))
- (setq list (cdr list)
- count (1+ count)))
- )))
-
-(defun semantic-ia-sb-completion-list (list face function)
- "Create some speedbar buttons from LIST.
-Each button will use FACE, and be activated with FUNCTION."
- (while list
- (let* ((documentable nil)
- (string (cond ((stringp (car list))
- (car list))
- ((semantic-tag-p (car list))
- (setq documentable t)
- (semantic-format-tag-uml-concise-prototype (car list)))
- (t "foo"))))
- (if documentable
- (speedbar-make-tag-line 'angle ?i
- 'semantic-ia-sb-tag-info
- (car list)
- string function (car list) face
- 0)
- (speedbar-make-tag-line 'statictag ? nil nil
- string function (car list) face
- 0))
- (setq list (cdr list)))))
-
-(defun semantic-ia-sb-show-tag-info ()
- "Display information about the tag on the current line.
-Same as clicking on the <i> button.
-See `semantic-ia-sb-tag-info' for more."
- (interactive)
- (let ((tok nil))
- (save-excursion
- (end-of-line)
- (forward-char -1)
- (setq tok (get-text-property (point) 'speedbar-token)))
- (semantic-ia-sb-tag-info nil tok 0)))
-
-(defun semantic-ia-sb-tag-info (_text tag _indent)
- "Display as much information as we can about tag.
-Show the information in a shrunk split-buffer and expand
-out as many details as possible.
-TEXT, TAG, and INDENT are speedbar function arguments."
- (when (semantic-tag-p tag)
- (unwind-protect
- (let ((ob nil))
- (speedbar-select-attached-frame)
- (setq ob (current-buffer))
- (with-output-to-temp-buffer "*Tag Information*"
- ;; Output something about this tag:
- (with-current-buffer "*Tag Information*"
- (goto-char (point-max))
- (insert
- (semantic-format-tag-prototype tag nil t)
- "\n")
- (let ((typetok
- (condition-case nil
- (with-current-buffer ob
- ;; @todo - We need a context to derive a scope from.
- (semantic-analyze-tag-type tag nil))
- (error nil))))
- (if typetok
- (insert (semantic-format-tag-prototype
- typetok nil t))
- ;; No type found by the analyzer
- ;; The below used to try and select the buffer from the last
- ;; analysis, but since we are already in the correct buffer, I
- ;; don't think that is needed.
- (let ((type (semantic-tag-type tag)))
- (cond ((semantic-tag-p type)
- (setq type (semantic-tag-name type)))
- ((listp type)
- (setq type (car type))))
- (if (semantic-lex-keyword-p type)
- (setq typetok
- (semantic-lex-keyword-get type 'summary))))
- (if typetok
- (insert typetok))
- ))
- ))
- ;; Make it small
- (shrink-window-if-larger-than-buffer
- (get-buffer-window "*Tag Information*")))
- (select-frame speedbar-frame))))
-
-(defun semantic-ia-sb-line-path (&optional _depth)
- "Return the file name associated with DEPTH."
- (save-match-data
- (let* ((tok (speedbar-line-token))
- (buff (or (semantic-tag-buffer tok)
- (current-buffer))))
- (buffer-file-name buff))))
-
-(defun semantic-ia-sb-complete (_text tag _indent)
- "At point in the attached buffer, complete the symbol clicked on.
-TEXT TAG and INDENT are the details."
- ;; Find the specified bounds from the current analysis.
- (speedbar-select-attached-frame)
- (unwind-protect
- (let* ((a (semantic-analyze-current-context (point)))
- (bounds (oref a bounds))
- (movepoint nil)
- )
- (save-excursion
- (if (and (<= (point) (cdr bounds)) (>= (point) (car bounds)))
- (setq movepoint t))
- (goto-char (car bounds))
- (delete-region (car bounds) (cdr bounds))
- (insert (semantic-tag-name tag))
- (if movepoint (setq movepoint (point)))
- ;; I'd like to use this to add fancy () or what not at the end
- ;; but we need the parent file which requires an upgrade to the
- ;; analysis tool.
- ;;(semantic-insert-foreign-tag tag ??))
- )
- (if movepoint
- (let ((cf (selected-frame)))
- (speedbar-select-attached-frame)
- (goto-char movepoint)
- (select-frame cf))))
- (select-frame speedbar-frame)))
-
-(provide 'semantic/ia-sb)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/ia-sb"
-;; End:
-
-;;; semantic/ia-sb.el ends here
+++ /dev/null
-;;; semantic/ia.el --- Interactive Analysis functions -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Interactive access to `semantic-analyze'.
-;;
-;; These routines are fairly simple, and show how to use the Semantic
-;; analyzer to provide things such as completion lists, summaries,
-;; locations, or documentation.
-;;
-
-;;; TODO
-;;
-;; fast-jump. For a virtual method, offer some of the possible
-;; implementations in various sub-classes.
-
-(require 'semantic/analyze)
-(require 'semantic/format)
-(require 'pulse)
-(require 'semantic/senator)
-(require 'semantic/analyze/refs)
-(eval-when-compile
- (require 'semantic/analyze)
- (require 'semantic/find))
-
-(declare-function imenu--mouse-menu "imenu")
-
-;;; Code:
-
-;;; COMPLETION
-;;
-;; This set of routines provides some simplisting completion
-;; functions.
-
-(defcustom semantic-ia-completion-format-tag-function
- 'semantic-format-tag-prototype
- "Function used to convert a tag to a string during completion."
- :group 'semantic
- :type semantic-format-tag-custom-list)
-
-;;; COMPLETION HELPER
-;;
-;; This overload function handles inserting a tag
-;; into a buffer for these local completion routines.
-;;
-;; By creating the functions as overloadable, it can be
-;; customized. For example, the default will put a paren "("
-;; character after function names. For Lisp, it might check
-;; to put a "(" in front of a function name.
-
-(define-overloadable-function semantic-ia-insert-tag (tag)
- "Insert TAG into the current buffer based on completion.")
-
-(defun semantic-ia-insert-tag-default (tag)
- "Insert TAG into the current buffer based on completion."
- (insert (semantic-tag-name tag))
- (let ((tt (semantic-tag-class tag)))
- (cond ((eq tt 'function)
- (insert "("))
- (t nil))))
-
-(defun semantic-ia-get-completions (context _point)
- "Fetch the completion of CONTEXT at POINT."
- (declare (obsolete semantic-analyze-possible-completions "28.1"))
- (semantic-analyze-possible-completions context))
-
-;;;###autoload
-(defun semantic-ia-complete-symbol (&optional pos)
- "Complete the current symbol at POS.
-If POS is nil, default to point.
-Completion options are calculated with `semantic-analyze-possible-completions'."
- (interactive "d")
- (when (semantic-active-p)
- (or pos (setq pos (point)))
- ;; Calculating completions is a two step process.
- ;;
- ;; The first analyzer the current context, which finds tags for
- ;; all the stuff that may be references by the code around POS.
- ;;
- ;; The second step derives completions from that context.
- (let* ((a (semantic-analyze-current-context pos))
- (syms (semantic-analyze-possible-completions a))
- (pre (car (reverse (oref a prefix)))))
- ;; If PRE was actually an already completed symbol, it doesn't
- ;; come in as a string, but as a tag instead.
- (if (semantic-tag-p pre)
- ;; We will try completions on it anyway.
- (setq pre (semantic-tag-name pre)))
- ;; Complete this symbol.
- (if (null syms)
- (if (semantic-analyze-context-p a)
- ;; This is a clever hack. If we were unable to find any
- ;; smart completions, let's divert to how senator derives
- ;; completions.
- ;;
- ;; This is a way of making this fcn more useful since
- ;; the smart completion engine sometimes fails.
- (semantic-complete-symbol))
- ;; Use try completion to seek a common substring.
- (let* ((completion-ignore-case (string= (downcase pre) pre))
- (tc (try-completion (or pre "") syms)))
- (if (and (stringp tc) (not (string= tc (or pre ""))))
- (let ((tok (semantic-find-first-tag-by-name
- tc syms)))
- ;; Delete what came before...
- (when (and (car (oref a bounds)) (cdr (oref a bounds)))
- (delete-region (car (oref a bounds))
- (cdr (oref a bounds)))
- (goto-char (car (oref a bounds))))
- ;; We have some new text. Stick it in.
- (if tok
- (semantic-ia-insert-tag tok)
- (insert tc)))
- ;; We don't have new text. Show all completions.
- (when (cdr (oref a bounds))
- (goto-char (cdr (oref a bounds))))
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list
- (mapcar semantic-ia-completion-format-tag-function syms)))))))))
-
-(defcustom semantic-ia-completion-menu-format-tag-function
- 'semantic-format-tag-uml-concise-prototype
- "Function used to convert a tag to a string during completion."
- :group 'semantic
- :type semantic-format-tag-custom-list)
-
-;;;###autoload
-(defun semantic-ia-complete-symbol-menu (point)
- "Complete the current symbol via a menu based at POINT.
-Completion options are calculated with `semantic-analyze-possible-completions'."
- (interactive "d")
- (require 'imenu)
- (let* ((a (semantic-analyze-current-context point))
- (syms (semantic-analyze-possible-completions a))
- )
- ;; Complete this symbol.
- (if (not syms)
- (progn
- (message "No smart completions found.")
- ;; Disabled - see https://debbugs.gnu.org/14522
- ;; (message "No smart completions found. Trying Senator.")
- ;; (when (semantic-analyze-context-p a)
- ;; ;; This is a quick way of getting a nice completion list
- ;; ;; in the menu if the regular context mechanism fails.
- ;; (senator-completion-menu-popup))
- )
-
- (let* ((menu
- (mapcar
- (lambda (tag)
- (cons
- (funcall semantic-ia-completion-menu-format-tag-function tag)
- (vector tag)))
- syms))
- (ans
- (imenu--mouse-menu
- ;; XEmacs needs that the menu has at least 2 items. So,
- ;; include a nil item that will be ignored by imenu.
- (cons nil menu)
- `(down-mouse-1 ,(posn-at-point))
- "Completions")))
- (when ans
- (if (not (semantic-tag-p ans))
- (setq ans (aref (cdr ans) 0)))
- (delete-region (car (oref a bounds)) (cdr (oref a bounds)))
- (semantic-ia-insert-tag ans))
- ))))
-
-;;; Completions Tip
-;;
-;; This functions shows how to get the list of completions,
-;; to place in a tooltip. It doesn't actually do any completion.
-
-;;;###autoload
-(defun semantic-ia-complete-tip (point)
- "Pop up a tooltip for completion at POINT."
- (interactive "d")
- (let* ((a (semantic-analyze-current-context point))
- (syms (semantic-analyze-possible-completions a))
- (x (mod (- (current-column) (window-hscroll))
- (window-width)))
- (y (save-excursion
- (save-restriction
- (widen)
- (narrow-to-region (window-start) (point))
- (goto-char (point-min))
- (1+ (vertical-motion (buffer-size))))))
- (str (mapconcat #'semantic-tag-name
- syms
- "\n"))
- )
- (cond ((fboundp 'x-show-tip)
- (x-show-tip str
- (selected-frame)
- nil
- nil
- x y)
- )
- (t (message str))
- )))
-
-;;; Summary
-;;
-;; Like idle-summary-mode, this shows how to get something to
-;; show a summary on.
-
-;;;###autoload
-(defun semantic-ia-show-summary (point)
- "Display a summary for the symbol under POINT."
- (interactive "P")
- (let* ((ctxt (semantic-analyze-current-context point))
- (pf (when ctxt
- ;; The CTXT is an EIEIO object. The below
- ;; method will attempt to pick the most interesting
- ;; tag associated with the current context.
- (semantic-analyze-interesting-tag ctxt)))
- )
- (if pf
- (message "%s" (semantic-format-tag-summarize pf nil t))
- (message "No summary info available"))))
-
-;;; Variants
-;;
-;; Show all variants for the symbol under point.
-
-;;;###autoload
-(defun semantic-ia-show-variants (point)
- "Display a list of all variants for the symbol under POINT."
- (interactive "d")
- (let* ((ctxt (semantic-analyze-current-context point))
- (comp nil))
-
- ;; We really want to look at the function if we are on an
- ;; argument. Are there some additional rules we care about for
- ;; changing the CTXT we look at?
- (when (semantic-analyze-context-functionarg-p ctxt)
- (goto-char (cdr (oref ctxt bounds)))
- (setq ctxt (semantic-analyze-current-context (point))))
-
- ;; Get the "completion list", but remove ALL filters to get the master list
- ;; of all the possible things.
- (setq comp (semantic-analyze-possible-completions ctxt 'no-unique 'no-tc))
-
- ;; Special case for a single type. List the constructors?
- (when (and (= (length comp) 1) (semantic-tag-of-class-p (car comp) 'type))
- (setq comp (semantic-find-tags-by-name (semantic-tag-name (car comp))
- (semantic-tag-type-members (car comp)))))
-
- ;; Display the results.
- (cond ((= (length comp) 0)
- (message "No Variants found."))
- ((= (length comp) 1)
- (message "%s" (semantic-format-tag-summarize (car comp) nil t)))
- (t
- (with-output-to-temp-buffer "*Symbol Variants*"
- (semantic-analyze-princ-sequence comp "" (current-buffer)))
- (shrink-window-if-larger-than-buffer
- (get-buffer-window "*Symbol Variants*")))
- )))
-
-;;; FAST Jump
-;;
-;; Jump to a destination based on the local context.
-;;
-;; This shows how to use the analyzer context, and the
-;; analyzer references objects to choose a good destination.
-
-(defun semantic-ia--fast-jump-helper (dest)
- "Jump to DEST, a Semantic tag.
-This helper manages the mark, buffer switching, and pulsing."
- ;; We have a tag, but in C++, we usually get a prototype instead
- ;; because of header files. Let's try to find the actual
- ;; implementation instead.
- (when (semantic-tag-prototype-p dest)
- (let* ((refs (semantic-analyze-tag-references dest))
- (impl (semantic-analyze-refs-impl refs t))
- )
- (when impl (setq dest (car impl)))))
-
- ;; Make sure we have a place to go...
- (if (not (and (or (semantic-tag-with-position-p dest)
- (semantic-tag-get-attribute dest :line))
- (semantic-tag-file-name dest)))
- (error "Tag %s has no buffer information"
- (semantic-format-tag-name dest)))
-
- ;; Once we have the tag, we can jump to it. Here
- ;; are the key bits to the jump:
-
- ;; 1) Push the mark, so you can pop global mark back, or
- ;; use semantic-mru-bookmark mode to do so.
- (push-mark)
- (when (fboundp 'xref-push-marker-stack)
- (xref-push-marker-stack))
- ;; 2) Visits the tag.
- (semantic-go-to-tag dest)
- ;; 3) go-to-tag doesn't switch the buffer in the current window,
- ;; so it is like find-file-noselect. Bring it forward.
- (pop-to-buffer-same-window (current-buffer))
- ;; 4) Fancy pulsing.
- (pulse-momentary-highlight-one-line (point))
- )
-
-(declare-function semantic-decoration-include-visit "semantic/decorate/include")
-
-;;;###autoload
-(defun semantic-ia-fast-jump (point)
- "Jump to the tag referred to by the code at POINT.
-Uses `semantic-analyze-current-context' output to identify an accurate
-origin of the code at point."
- (interactive "d")
- (let* ((ctxt (semantic-analyze-current-context point))
- (pf (and ctxt (reverse (oref ctxt prefix))))
- ;; In the analyzer context, the PREFIX is the list of items
- ;; that makes up the code context at point. Thus the c++ code
- ;; this.that().theothe
- ;; would make a list:
- ;; ( ("this" variable ..) ("that" function ...) "theothe")
- ;; Where the first two elements are the semantic tags of the prefix.
- ;;
- ;; PF is the reverse of this list. If the first item is a string,
- ;; then it is an incomplete symbol, thus we pick the second.
- ;; The second cannot be a string, as that would have been an error.
- (first (car pf))
- (second (nth 1 pf))
- )
- (cond
- ((semantic-tag-p first)
- ;; We have a match. Just go there.
- (semantic-ia--fast-jump-helper first))
-
- ((semantic-tag-p second)
- ;; Because FIRST failed, we should visit our second tag.
- ;; HOWEVER, the tag we actually want that was only an unfound
- ;; string may be related to some take in the datatype that belongs
- ;; to SECOND. Thus, instead of visiting second directly, we
- ;; can offer to find the type of SECOND, and go there.
- (let ((secondclass (car (reverse (oref ctxt prefixtypes)))))
- (cond
- ((and (semantic-tag-with-position-p secondclass)
- (y-or-n-p (format-message
- "Could not find `%s'. Jump to %s? "
- first (semantic-tag-name secondclass))))
- (semantic-ia--fast-jump-helper secondclass)
- )
- ;; If we missed out on the class of the second item, then
- ;; just visit SECOND.
- ((and (semantic-tag-p second)
- (y-or-n-p (format-message
- "Could not find `%s'. Jump to %s? "
- first (semantic-tag-name second))))
- (semantic-ia--fast-jump-helper second)
- ))))
-
- ((semantic-tag-of-class-p (semantic-current-tag) 'include)
- ;; Just borrow this cool fcn.
- (require 'semantic/decorate/include)
-
- ;; Push the mark, so you can pop global mark back, or
- ;; use semantic-mru-bookmark mode to do so.
- (push-mark)
- (when (fboundp 'xref-push-marker-stack)
- (xref-push-marker-stack))
-
- (semantic-decoration-include-visit)
- )
-
- (t
- (error "Could not find suitable jump point for %s"
- first))
- )))
-
-;;;###autoload
-(defun semantic-ia-fast-mouse-jump (evt)
- "Jump to the tag referred to by the point clicked on.
-See `semantic-ia-fast-jump' for details on how it works.
- This command is meant to be bound to a mouse event."
- (interactive "e")
- (semantic-ia-fast-jump
- (save-excursion
- (posn-set-point (event-end evt))
- (point))))
-
-;;; DOC/DESCRIBE
-;;
-;; These routines show how to get additional information about a tag
-;; for purposes of describing or showing documentation about them.
-;;;###autoload
-(defun semantic-ia-show-doc (point)
- "Display the code-level documentation for the symbol at POINT."
- (interactive "d")
- (let* ((ctxt (semantic-analyze-current-context point))
- (pf (reverse (oref ctxt prefix)))
- )
- ;; If PF, the prefix is non-nil, then the last element is either
- ;; a string (incomplete type), or a semantic TAG. If it is a TAG
- ;; then we should be able to find DOC for it.
- (cond
- ((stringp (car pf))
- (message "Incomplete symbol name."))
- ((semantic-tag-p (car pf))
- ;; The `semantic-documentation-for-tag' fcn is language
- ;; specific. If it doesn't return what you expect, you may
- ;; need to implement something for your language.
- ;;
- ;; The default tries to find a comment in front of the tag
- ;; and then strings off comment prefixes.
- (let ((doc (semantic-documentation-for-tag (car pf))))
- (if (or (null doc) (string= doc ""))
- (message "Doc unavailable for: %s"
- (semantic-format-tag-prototype (car pf)))
- (with-output-to-temp-buffer "*TAG DOCUMENTATION*"
- (princ "Tag: ")
- (princ (semantic-format-tag-prototype (car pf)))
- (princ "\n")
- (princ "\n")
- (princ "Snarfed Documentation: ")
- (princ "\n")
- (princ "\n")
- (if doc
- (princ doc)
- (princ " Documentation unavailable."))
- ))))
- (t
- (message "Unknown tag.")))
- ))
-
-;;;###autoload
-(defun semantic-ia-describe-class (typename)
- "Display all known parts for the datatype TYPENAME.
-If the type in question is a class, all methods and other accessible
-parts of the parent classes are displayed."
- ;; @todo - use a fancy completing reader.
- (interactive "sType Name: ")
-
- ;; When looking for a tag of any name there are a couple ways to do
- ;; it. The simple `semanticdb-find-tag-by-...' are simple, and
- ;; you need to pass it the exact name you want.
- ;;
- ;; The analyzer function `semantic-analyze-find-tag' will take
- ;; more complex names, such as the cpp symbol foo::bar::baz,
- ;; and break it up, and dive through the namespaces.
- (let ((class (semantic-analyze-find-tag typename)))
-
- (when (not (semantic-tag-p class))
- (error "Cannot find class %s" class))
- (with-output-to-temp-buffer "*TAG DOCUMENTATION*"
- ;; There are many semantic-format-tag-* fcns.
- ;; The summarize routine is a fairly generic one.
- (princ (semantic-format-tag-summarize class))
- (princ "\n")
- (princ " Type Members:\n")
- ;; The type tag contains all the parts of the type.
- ;; In complex languages with inheritance, not all the
- ;; parts are in the tag. This analyzer fcn will traverse
- ;; the inheritance tree, and find all the pieces that
- ;; are inherited.
- (let ((parts (semantic-analyze-scoped-type-parts class)))
- (while parts
- (princ " ")
- (princ (semantic-format-tag-summarize (car parts)))
- (princ "\n")
- (setq parts (cdr parts)))
- )
- )))
-
-(provide 'semantic/ia)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/ia"
-;; End:
-
-;;; semantic/ia.el ends here
+++ /dev/null
-;;; idle.el --- Schedule parsing tasks in idle time -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2003-2006, 2008-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Originally, `semantic-auto-parse-mode' handled refreshing the
-;; tags in a buffer in idle time. Other activities can be scheduled
-;; in idle time, all of which require up-to-date tag tables.
-;; Having a specialized idle time scheduler that first refreshes
-;; the tags buffer, and then enables other idle time tasks reduces
-;; the amount of work needed. Any specialized idle tasks need not
-;; ask for a fresh tags list.
-;;
-;; NOTE ON SEMANTIC_ANALYZE
-;;
-;; Some of the idle modes use the semantic analyzer. The analyzer
-;; automatically caches the created context, so it is shared amongst
-;; all idle modes that will need it.
-
-(require 'semantic)
-(require 'semantic/ctxt)
-(require 'semantic/format)
-(require 'semantic/tag)
-(require 'semantic/analyze)
-(require 'timer)
-;;(require 'working)
-
-;; For the semantic-find-tags-by-name macro.
-(eval-when-compile (require 'semantic/find))
-
-(declare-function semantic-analyze-unsplit-name "semantic/analyze/fcn")
-(declare-function semantic-complete-analyze-inline-idle "semantic/complete")
-(declare-function semanticdb-deep-find-tags-by-name "semantic/db-find")
-(declare-function semanticdb-save-all-db-idle "semantic/db")
-(declare-function semanticdb-typecache-refresh-for-buffer "semantic/db-typecache")
-(declare-function semantic-decorate-flush-pending-decorations
- "semantic/decorate/mode")
-(declare-function pulse-momentary-highlight-region "pulse")
-(declare-function pulse-momentary-highlight-overlay "pulse")
-(declare-function semantic-symref-hits-in-region "semantic/symref/filter")
-
-;;; Code:
-
-;;; TIMER RELATED FUNCTIONS
-;;
-(defvar semantic-idle-scheduler-timer nil
- "Timer used to schedule tasks in idle time.")
-
-(defvar semantic-idle-scheduler-work-timer nil
- "Timer used to schedule tasks in idle time that may take a while.")
-
-(defcustom semantic-idle-scheduler-verbose-flag nil
- "Non-nil means that the idle scheduler should provide debug messages.
-Use this setting to debug idle activities."
- :group 'semantic
- :type 'boolean)
-
-(defcustom semantic-idle-scheduler-idle-time 1
- "Time in seconds of idle before scheduling events.
-This time should be short enough to ensure that idle-scheduler will be
-run as soon as Emacs is idle."
- :group 'semantic
- :type 'number
- :set (lambda (sym val)
- (set-default sym val)
- (when (timerp semantic-idle-scheduler-timer)
- (cancel-timer semantic-idle-scheduler-timer)
- (setq semantic-idle-scheduler-timer nil)
- (semantic-idle-scheduler-setup-timers))))
-
-(defcustom semantic-idle-scheduler-work-idle-time 60
- "Time in seconds of idle before scheduling big work.
-This time should be long enough that once any big work is started,
-it is unlikely the user would be ready to type again right away."
- :group 'semantic
- :type 'number
- :set (lambda (sym val)
- (set-default sym val)
- (when (timerp semantic-idle-scheduler-timer)
- (cancel-timer semantic-idle-scheduler-timer)
- (setq semantic-idle-scheduler-timer nil)
- (semantic-idle-scheduler-setup-timers))))
-
-(defun semantic-idle-scheduler-setup-timers ()
- "Lazy initialization of the auto parse idle timer."
- (or (timerp semantic-idle-scheduler-timer)
- (setq semantic-idle-scheduler-timer
- (run-with-idle-timer
- semantic-idle-scheduler-idle-time t
- #'semantic-idle-scheduler-function)))
- (or (timerp semantic-idle-scheduler-work-timer)
- (setq semantic-idle-scheduler-work-timer
- (run-with-idle-timer
- semantic-idle-scheduler-work-idle-time t
- #'semantic-idle-scheduler-work-function)))
- )
-
-(defun semantic-idle-scheduler-kill-timer ()
- "Kill the auto parse idle timer."
- (if (timerp semantic-idle-scheduler-timer)
- (cancel-timer semantic-idle-scheduler-timer))
- (setq semantic-idle-scheduler-timer nil))
-
-\f
-;;; MINOR MODE
-;;
-;; The minor mode portion of this code just sets up the minor mode
-;; which does the initial scheduling of the idle timers.
-;;
-
-(defcustom semantic-idle-scheduler-mode-hook nil
- "Hook run at the end of the function `semantic-idle-scheduler-mode'."
- :group 'semantic
- :type 'hook)
-
-(defvar-local semantic-idle-scheduler-mode nil
- "Non-nil if idle-scheduler minor mode is enabled.
-Use the command `semantic-idle-scheduler-mode' to change this variable.")
-
-(defcustom semantic-idle-scheduler-max-buffer-size 0
- "Maximum size in bytes of buffers where idle-scheduler is enabled.
-If this value is less than or equal to 0, idle-scheduler is enabled in
-all buffers regardless of their size."
- :group 'semantic
- :type 'number)
-
-(defsubst semantic-idle-scheduler-enabled-p ()
- "Return non-nil if idle-scheduler is enabled for this buffer.
-idle-scheduler is disabled when debugging or if the buffer size
-exceeds the `semantic-idle-scheduler-max-buffer-size' threshold."
- (let* ((remote-file? (when (stringp buffer-file-name) (file-remote-p buffer-file-name))))
- (and semantic-idle-scheduler-mode
- (not (and (boundp 'semantic-debug-enabled)
- semantic-debug-enabled))
- (not semantic-lex-debug)
- ;; local file should exist on disk
- ;; remote file should have active connection
- (or (and (null remote-file?) (stringp buffer-file-name)
- (file-exists-p buffer-file-name))
- (and remote-file? (file-remote-p buffer-file-name nil t)))
- (or (<= semantic-idle-scheduler-max-buffer-size 0)
- (< (buffer-size) semantic-idle-scheduler-max-buffer-size)))))
-
-;;;###autoload
-(define-minor-mode semantic-idle-scheduler-mode
- "Minor mode to auto parse buffer following a change.
-When this mode is off, a buffer is only rescanned for tokens when
-some command requests the list of available tokens. When idle-scheduler
-is enabled, Emacs periodically checks to see if the buffer is out of
-date, and reparses while the user is idle (not typing.)
-
-The minor mode can be turned on only if semantic feature is
-available and the current buffer was set up for parsing. Return
-non-nil if the minor mode is enabled."
- :lighter nil
- (if semantic-idle-scheduler-mode
- (if (not (and (featurep 'semantic) (semantic-active-p)))
- (progn
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-idle-scheduler-mode nil)
- (error "Buffer %s was not set up idle time scheduling"
- (buffer-name)))
- (semantic-idle-scheduler-setup-timers))))
-
-(semantic-add-minor-mode 'semantic-idle-scheduler-mode
- "ARP")
-\f
-;;; SERVICES services
-;;
-;; These are services for managing idle services.
-;;
-(defvar semantic-idle-scheduler-queue nil
- "List of functions to execute during idle time.
-These functions will be called in the current buffer after that
-buffer has had its tags made up to date. These functions
-will not be called if there are errors parsing the
-current buffer.")
-
-(defun semantic-idle-scheduler-add (function)
- "Schedule FUNCTION to occur during idle time."
- (add-to-list 'semantic-idle-scheduler-queue function))
-
-(defun semantic-idle-scheduler-remove (function)
- "Unschedule FUNCTION to occur during idle time."
- (setq semantic-idle-scheduler-queue
- (delete function semantic-idle-scheduler-queue)))
-
-;;; IDLE Function
-;;
-(defun semantic-idle-core-handler ()
- "Core idle function that handles reparsing.
-And also manages services that depend on tag values."
- (when semantic-idle-scheduler-verbose-flag
- (message "IDLE: Core handler..."))
- ;; FIXME: Use `while-no-input'?
- (semantic-exit-on-input 'idle-timer
- (let* ((inhibit-quit nil)
- (buffers (delq (current-buffer)
- (delq nil
- (mapcar (lambda (b)
- (and (buffer-file-name b)
- b))
- (buffer-list)))))
- ;; safe ;; This safe is not used, but could be.
- others
- mode)
- (when (semantic-idle-scheduler-enabled-p)
- (save-excursion
- ;; First, reparse the current buffer.
- (setq mode major-mode)
- ;; (setq safe
- (semantic-safe "Idle Parse Error: %S"
- ;(error "Goofy error 1")
- (semantic-idle-scheduler-refresh-tags))
-
- ;; Now loop over other buffers with same major mode, trying to
- ;; update them as well. Stop on keypress.
- (dolist (b buffers)
- (semantic-throw-on-input 'parsing-mode-buffers)
- (with-current-buffer b
- (if (eq major-mode mode)
- (and (semantic-idle-scheduler-enabled-p)
- (semantic-safe "Idle Parse Error: %S"
- ;(error "Goofy error")
- (semantic-idle-scheduler-refresh-tags)))
- (push (current-buffer) others))))
- (setq buffers others))
- ;; If re-parse of current buffer completed, evaluate all other
- ;; services. Stop on keypress.
-
- ;; NOTE ON COMMENTED SAFE HERE
- ;; We used to not execute the services if the buffer was
- ;; unparsable. We now assume that they are lexically
- ;; safe to do, because we have marked the buffer unparsable
- ;; if there was a problem.
- ;;(when safe
- (dolist (service semantic-idle-scheduler-queue)
- (save-excursion
- (semantic-throw-on-input 'idle-queue)
- (when semantic-idle-scheduler-verbose-flag
- (message "IDLE: execute service %s..." service))
- (semantic-safe (format "Idle Service Error %s: %%S" service)
- (funcall service))
- (when semantic-idle-scheduler-verbose-flag
- (message "IDLE: execute service %s...done" service))
- )))
- ;;)
- ;; Finally loop over remaining buffers, trying to update them as
- ;; well. Stop on keypress.
- (save-excursion
- (dolist (b buffers)
- (semantic-throw-on-input 'parsing-other-buffers)
- (with-current-buffer b
- (and (semantic-idle-scheduler-enabled-p)
- (semantic-idle-scheduler-refresh-tags)))))
- ))
- (when semantic-idle-scheduler-verbose-flag
- (message "IDLE: Core handler...done")))
-
-(defun semantic-debug-idle-function ()
- "Run the Semantic idle function with debugging turned on."
- (interactive)
- (let ((debug-on-error t))
- (semantic-idle-core-handler)
- ))
-
-(defun semantic-idle-scheduler-function ()
- "Function run when after `semantic-idle-scheduler-idle-time'.
-This function will reparse the current buffer, and if successful,
-call additional functions registered with the timer calls."
- (when (zerop (recursion-depth))
- (let ((debug-on-error nil))
- (save-match-data (semantic-idle-core-handler))
- )))
-
-\f
-;;; WORK FUNCTION
-;;
-;; Unlike the shorter timer, the WORK timer will kick of tasks that
-;; may take a long time to complete.
-(defcustom semantic-idle-work-parse-neighboring-files-flag nil
- "Non-nil means to parse files in the same dir as the current buffer.
-Disable to prevent lots of excessive parsing in idle time."
- :group 'semantic
- :type 'boolean)
-
-(defcustom semantic-idle-work-update-headers-flag nil
- "Non-nil means to parse through header files in idle time.
-Disable to prevent idle time parsing of many files. If completion
-is called that work will be done then instead."
- :group 'semantic
- :type 'boolean)
-
-(defun semantic-idle-work-for-one-buffer (buffer)
- "Do long-processing work for BUFFER.
-Uses `semantic-safe' and returns the output.
-Returns t if all processing succeeded."
- (with-current-buffer buffer
- (not (and
- ;; Just in case
- (semantic-safe "Idle Work Parse Error: %S"
- (semantic-idle-scheduler-refresh-tags)
- t)
-
- ;; Option to disable this work.
- semantic-idle-work-update-headers-flag
-
- ;; Force all our include files to get read in so we
- ;; are ready to provide good smart completion and idle
- ;; summary information
- (semantic-safe "Idle Work Including Error: %S"
- ;; Get the include related path.
- (when (and (featurep 'semantic/db) (semanticdb-minor-mode-p))
- (require 'semantic/db-find)
- (semanticdb-find-translate-path buffer nil)
- )
- t)
-
- ;; Pre-build the typecaches as needed.
- (semantic-safe "Idle Work Typecaching Error: %S"
- (when (featurep 'semantic/db-typecache)
- (semanticdb-typecache-refresh-for-buffer buffer))
- t)
- ))
- ))
-
-(defun semantic-idle-work-core-handler ()
- "Core handler for idle work processing of long running tasks.
-Visits Semantic controlled buffers, and makes sure all needed
-include files have been parsed, and that the typecache is up to date.
-Uses `semantic-idle-work-for-one-buffer' to do the work."
- (let*
- ((errbuf nil)
- (interrupted
- (semantic-exit-on-input 'idle-work-timer
- (let* ((inhibit-quit nil)
- (cb (current-buffer))
- (buffers (delq (current-buffer)
- (delq nil
- (mapcar (lambda (b)
- (and (buffer-file-name b)
- b))
- (buffer-list)))))
- safe) ;; errbuf
- ;; First, handle long tasks in the current buffer.
- (when (semantic-idle-scheduler-enabled-p)
- (save-excursion
- (setq safe (semantic-idle-work-for-one-buffer (current-buffer))
- )))
- (when (not safe) (push (current-buffer) errbuf))
-
- ;; Now loop over other buffers with same major mode, trying to
- ;; update them as well. Stop on keypress.
- (dolist (b buffers)
- (semantic-throw-on-input 'parsing-mode-buffers)
- (with-current-buffer b
- (when (semantic-idle-scheduler-enabled-p)
- (and (semantic-idle-scheduler-enabled-p)
- (unless (semantic-idle-work-for-one-buffer
- (current-buffer))
- (push (current-buffer) errbuf)))
- ))
- )
-
- (when (and (featurep 'semantic/db) (semanticdb-minor-mode-p))
- ;; Save everything.
- (semanticdb-save-all-db-idle)
-
- ;; Parse up files near our active buffer
- (when semantic-idle-work-parse-neighboring-files-flag
- (semantic-safe "Idle Work Parse Neighboring Files: %S"
- (set-buffer cb)
- (semantic-idle-scheduler-work-parse-neighboring-files))
- t)
-
- ;; Save everything... again
- (semanticdb-save-all-db-idle)
- )
-
- ;; Done with processing
- nil))))
-
- ;; Done
- (if interrupted
- "Interrupted"
- (cond ((not errbuf)
- "done")
- ((not (cdr errbuf))
- (format "done with 1 error in %s" (car errbuf)))
- (t
- (format "done with errors in %d buffers."
- (length errbuf)))))))
-
-(defun semantic-debug-idle-work-function ()
- "Run the Semantic idle work function with debugging turned on."
- (interactive)
- (let ((debug-on-error t))
- (semantic-idle-work-core-handler)
- ))
-
-(defun semantic-idle-scheduler-work-function ()
- "Function run when after `semantic-idle-scheduler-work-idle-time'.
-This routine handles difficult tasks that require a lot of parsing, such as
-parsing all the header files used by our active sources, or building up complex
-datasets."
- (when semantic-idle-scheduler-verbose-flag
- (message "Long Work Idle Timer..."))
- (let ((exit-type (save-match-data
- (semantic-idle-work-core-handler))))
- (when semantic-idle-scheduler-verbose-flag
- (message "Long Work Idle Timer...%s" exit-type)))
- )
-
-(defvar ede-auto-add-method)
-
-(defun semantic-idle-scheduler-work-parse-neighboring-files ()
- "Parse all the files in similar directories to buffers being edited."
- ;; Let's tell EDE to ignore all the files we're about to load
- (let ((ede-auto-add-method 'never)
- (matching-auto-mode-patterns nil))
- ;; Collect all patterns matching files of the same mode we edit.
- (mapc (lambda (pat) (and (eq (cdr pat) major-mode)
- (push (car pat) matching-auto-mode-patterns)))
- auto-mode-alist)
- ;; Loop over all files, and if one matches our mode, we force its
- ;; table to load.
- (dolist (file (directory-files default-directory t ".*" t))
- (catch 'found
- (mapc (lambda (pat)
- (semantic-throw-on-input 'parsing-mode-buffers)
- ;; We use string-match instead of passing the pattern
- ;; into directory files, because some patterns don't
- ;; work with directory files.
- (and (string-match pat file)
- (save-excursion
- (semanticdb-file-table-object file))
- (throw 'found t)))
- matching-auto-mode-patterns)))))
-
-\f
-;;; REPARSING
-;;
-;; Reparsing is installed as semantic idle service.
-;; This part ALWAYS happens, and other services occur
-;; afterwards.
-
-(defvar semantic-before-idle-scheduler-reparse-hook nil
- "Hook run before option `semantic-idle-scheduler' begins parsing.
-If any hook function throws an error, this variable is reset to nil.
-This hook is not protected from lexical errors.")
-
-(defvar semantic-after-idle-scheduler-reparse-hook nil
- "Hook run after option `semantic-idle-scheduler' has parsed.
-If any hook function throws an error, this variable is reset to nil.
-This hook is not protected from lexical errors.")
-
-(defun semantic-idle-scheduler-refresh-tags ()
- "Refreshes the current buffer's tags.
-This is called by `semantic-idle-scheduler-function' to update the
-tags in the current buffer.
-
-Return non-nil if the refresh was successful.
-Return nil if there is some sort of syntax error preventing a full
-reparse.
-
-Does nothing if the current buffer doesn't need reparsing."
-
- (prog1
- ;; These checks actually occur in `semantic-fetch-tags', but if we
- ;; do them here, then all the bovination hooks are not run, and
- ;; we save lots of time.
- (cond
- ;; If the buffer was previously marked unparsable,
- ;; then don't waste our time.
- ((semantic-parse-tree-unparseable-p)
- nil)
- ;; The parse tree is already ok.
- ((semantic-parse-tree-up-to-date-p)
- t)
- (t
- ;; If the buffer might need a reparse and it is safe to do so,
- ;; give it a try.
- (let* (;(semantic-working-type nil)
- (inhibit-quit nil)
- ;; (working-use-echo-area-p
- ;; (not semantic-idle-scheduler-working-in-modeline-flag))
- ;; (working-status-dynamic-type
- ;; (if semantic-idle-scheduler-no-working-message
- ;; nil
- ;; working-status-dynamic-type))
- ;; (working-status-percentage-type
- ;; (if semantic-idle-scheduler-no-working-message
- ;; nil
- ;; working-status-percentage-type))
- (lexically-safe t)
- )
- ;; Let people hook into this, but don't let them hose
- ;; us over!
- (condition-case nil
- (run-hooks 'semantic-before-idle-scheduler-reparse-hook)
- (error (setq semantic-before-idle-scheduler-reparse-hook nil)))
-
- (unwind-protect
- ;; Perform the parsing.
- (progn
- (when semantic-idle-scheduler-verbose-flag
- (message "IDLE: reparse %s..." (buffer-name)))
- (when (semantic-lex-catch-errors idle-scheduler
- (save-excursion (semantic-fetch-tags))
- nil)
- ;; If we are here, it is because the lexical step failed,
- ;; probably due to unterminated lists or something like that.
-
- ;; We do nothing, and just wait for the next idle timer
- ;; to go off. In the meantime, remember this, and make sure
- ;; no other idle services can get executed.
- (setq lexically-safe nil))
- (when semantic-idle-scheduler-verbose-flag
- (message "IDLE: reparse %s...done" (buffer-name))))
- ;; Let people hook into this, but don't let them hose
- ;; us over!
- (condition-case nil
- (run-hooks 'semantic-after-idle-scheduler-reparse-hook)
- (error (setq semantic-after-idle-scheduler-reparse-hook nil))))
- ;; Return if we are lexically safe (from prog1)
- lexically-safe)))
-
- ;; After updating the tags, handle any pending decorations for this
- ;; buffer.
- (require 'semantic/decorate/mode)
- (semantic-decorate-flush-pending-decorations (current-buffer))
- ))
-
-\f
-;;; IDLE SERVICES
-;;
-;; Idle Services are minor modes which enable or disable a services in
-;; the idle scheduler. Creating a new services only requires calling
-;; `semantic-create-idle-services' which does all the setup
-;; needed to create the minor mode that will enable or disable
-;; a services. The services must provide a single function.
-
-;; FIXME doc is incomplete.
-(defmacro define-semantic-idle-service (name doc &rest forms)
- "Create a new idle services with NAME.
-DOC will be a documentation string describing FORMS.
-FORMS will be called during idle time after the current buffer's
-semantic tag information has been updated.
-This routine creates the following functions and variables:"
- (declare (indent 1) (debug (&define name stringp def-body)))
- (let ((global (intern (concat "global-" (symbol-name name) "-mode")))
- (mode (intern (concat (symbol-name name) "-mode")))
- (hook (intern (concat (symbol-name name) "-mode-hook")))
- (map (intern (concat (symbol-name name) "-mode-map")))
- ;; (setup (intern (concat (symbol-name name) "-mode-setup")))
- (func (intern (concat (symbol-name name) "-idle-function"))))
-
- `(progn
- (define-minor-mode ,global
- ,(concat "Toggle " (symbol-name global) ".
-With ARG, turn the minor mode on if ARG is positive, off otherwise.\n\n"
- (internal--format-docstring-line
- "When this minor mode is enabled, `%s' is \
-turned on in every Semantic-supported buffer."
- (symbol-name mode)))
- :global t
- :group 'semantic
- :group 'semantic-modes
- :require 'semantic/idle
- (semantic-toggle-minor-mode-globally
- ',mode (if ,global 1 -1)))
-
- ;; FIXME: Get rid of this when define-minor-mode does it for us.
- (defcustom ,hook nil
- ,(concat "Hook run at the end of function `" (symbol-name mode) "'.")
- :group 'semantic
- :type 'hook)
-
- (defvar ,map
- (let ((km (make-sparse-keymap)))
- km)
- ,(concat "Keymap for `" (symbol-name mode) "'."))
-
- (define-minor-mode ,mode
- ,doc
- :keymap ,map
- (if ,mode
- (if (not (and (featurep 'semantic) (semantic-active-p)))
- (progn
- ;; Disable minor mode if semantic stuff not available
- (setq ,mode nil)
- (error "Buffer %s was not set up for parsing"
- (buffer-name)))
- ;; Enable the mode mode
- (semantic-idle-scheduler-add #',func))
- ;; Disable the mode mode
- (semantic-idle-scheduler-remove #',func)))
-
- (semantic-add-minor-mode ',mode
- "") ; idle schedulers are quiet?
-
- (defun ,func ()
- ,(internal--format-docstring-line
- "Perform idle activity for the minor mode `%s'."
- (symbol-name mode))
- ,@forms))))
-\f
-;;; SUMMARY MODE
-;;
-;; A mode similar to eldoc using semantic
-(defcustom semantic-idle-truncate-long-summaries t
- "Truncate summaries that are too long to fit in the minibuffer.
-This can prevent minibuffer resizing in idle time."
- :group 'semantic
- :type 'boolean)
-
-(defcustom semantic-idle-summary-function
- 'semantic-format-tag-summarize-with-file
- "Function to call when displaying tag information during idle time.
-This function should take a single argument, a Semantic tag, and
-return a string to display.
-Some useful functions are found in `semantic-format-tag-functions'."
- :group 'semantic
- :type semantic-format-tag-custom-list)
-
-(defsubst semantic-idle-summary-find-current-symbol-tag (sym)
- "Search for a semantic tag with name SYM in database tables.
-Return the tag found or nil if not found.
-If semanticdb is not in use, use the current buffer only."
- (car (if (and (featurep 'semantic/db)
- semanticdb-current-database
- (require 'semantic/db-find))
- (cdar (semanticdb-deep-find-tags-by-name sym))
- (semantic-deep-find-tags-by-name sym (current-buffer)))))
-
-(defun semantic-idle-summary-current-symbol-info-brutish ()
- "Return a string message describing the current context.
-Gets a symbol with `semantic-ctxt-current-thing' and then
-tries to find it with a deep targeted search."
- ;; Try the current "thing".
- (let ((sym (car (semantic-ctxt-current-thing))))
- (when sym
- (semantic-idle-summary-find-current-symbol-tag sym))))
-
-(defun semantic-idle-summary-current-symbol-keyword ()
- "Return a string message describing the current symbol.
-Returns a value only if it is a keyword."
- ;; Try the current "thing".
- (let ((sym (car (semantic-ctxt-current-thing))))
- (if (and sym (semantic-lex-keyword-p sym))
- (semantic-lex-keyword-get sym 'summary))))
-
-(defun semantic-idle-summary-current-symbol-info-context ()
- "Return a string message describing the current context.
-Use the semantic analyzer to find the symbol information."
- (let ((analysis (condition-case nil
- (semantic-analyze-current-context (point))
- (error nil))))
- (when analysis
- (semantic-analyze-interesting-tag analysis))))
-
-(defun semantic-idle-summary-current-symbol-info-default ()
- "Return a string message describing the current context.
-This function will disable loading of previously unloaded files
-by semanticdb as a time-saving measure."
- (semanticdb-without-unloaded-file-searches
- (save-excursion
- ;; use whichever has success first.
- (or
- (semantic-idle-summary-current-symbol-keyword)
-
- (semantic-idle-summary-current-symbol-info-context)
-
- (semantic-idle-summary-current-symbol-info-brutish)
- ))))
-
-(defvar semantic-idle-summary-out-of-context-faces
- '(
- font-lock-comment-face
- font-lock-string-face
- font-lock-doc-face
- )
- "List of font-lock faces that indicate a useless summary context.
-Those are generally faces used to highlight comments.
-
-It might be useful to override this variable to add comment faces
-specific to a major mode. For example, in jde mode:
-
-\(defvar-mode-local jde-mode semantic-idle-summary-out-of-context-faces
- (append (default-value \\='semantic-idle-summary-out-of-context-faces)
- \\='(jde-java-font-lock-doc-tag-face
- jde-java-font-lock-link-face
- jde-java-font-lock-bold-face
- jde-java-font-lock-underline-face
- jde-java-font-lock-pre-face
- jde-java-font-lock-code-face)))")
-
-(defun semantic-idle-summary-useful-context-p ()
- "Non-nil if we should show a summary based on context."
- (if (and font-lock-mode
- (memq (get-text-property (point) 'face)
- semantic-idle-summary-out-of-context-faces))
- ;; The best I can think of at the moment is to disable
- ;; in comments by detecting with font-lock.
- nil
- t))
-
-(define-overloadable-function semantic-idle-summary-current-symbol-info ()
- "Return a string message describing the current context.")
-
-(defcustom semantic-idle-summary-mode-hook nil
- "Hook run at the end of `semantic-idle-summary'."
- :group 'semantic
- :type 'hook)
-
-(defun semantic--eldoc-info (_callback &rest _)
- "Return the eldoc info for the current symbol.
-Call `semantic-idle-summary-current-symbol-info' for getting the
-current tag to display information."
- (or (eq major-mode 'emacs-lisp-mode)
- (not (semantic-idle-summary-useful-context-p))
- (let* ((found (save-excursion
- (semantic-idle-summary-current-symbol-info)))
- (str (cond ((stringp found) found)
- ((semantic-tag-p found)
- (funcall semantic-idle-summary-function
- found nil t)))))
- str)))
-
-(define-minor-mode semantic-idle-summary-mode
- "Toggle Semantic Idle Summary mode.
-
-When this minor mode is enabled, the echo area displays a summary
-of the lexical token at point whenever Emacs is idle."
- :group 'semantic
- :group 'semantic-modes
- (remove-hook 'eldoc-documentation-functions #'semantic--eldoc-info t)
- (when semantic-idle-summary-mode
- ;; Enable the mode
- (unless (and (featurep 'semantic) (semantic-active-p))
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-idle-summary-mode nil)
- (error "Buffer %s was not set up for parsing"
- (buffer-name)))
- (add-hook 'eldoc-documentation-functions #'semantic--eldoc-info nil t)
- (eldoc-mode 1)))
-
-(semantic-add-minor-mode 'semantic-idle-summary-mode "")
-
-(define-minor-mode global-semantic-idle-summary-mode
- "Toggle Global Semantic Idle Summary mode.
-
-When this minor mode is enabled, `semantic-idle-summary-mode' is
-turned on in every Semantic-supported buffer."
- :global t
- :group 'semantic
- :group 'semantic-modes
- (semantic-toggle-minor-mode-globally
- 'semantic-idle-summary-mode
- (if global-semantic-idle-summary-mode 1 -1)))
-
-\f
-;;; Current symbol highlight
-;;
-;; This mode will use context analysis to perform highlighting
-;; of all uses of the symbol that is under the cursor.
-;;
-;; This is to mimic the Eclipse tool of a similar nature.
-(defface semantic-idle-symbol-highlight
- '((t :inherit region))
- "Face used for highlighting local symbols."
- :group 'semantic-faces)
-(defvar semantic-idle-symbol-highlight-face 'semantic-idle-symbol-highlight
- "Face used for highlighting local symbols.")
-(make-obsolete-variable 'semantic-idle-symbol-highlight-face
- "customize the face `semantic-idle-symbol-highlight' instead" "24.4" 'set)
-
-(defvar pulse-flag)
-
-(defun semantic-idle-symbol-maybe-highlight (tag)
- "Perhaps add highlighting to the symbol represented by TAG.
-TAG was found as the symbol under point. If it happens to be
-visible, then highlight it."
- (require 'pulse)
- (let* ((region (when (and (semantic-tag-p tag)
- (semantic-tag-with-position-p tag))
- (semantic-tag-overlay tag)))
- (file (when (and (semantic-tag-p tag)
- (semantic-tag-with-position-p tag))
- (semantic-tag-file-name tag)))
- (buffer (when file (get-file-buffer file)))
- ;; We use pulse, but we don't want the flashy version,
- ;; just the stable version.
- (pulse-flag nil)
- )
- (cond ((overlayp region)
- (with-current-buffer (overlay-buffer region)
- (save-excursion
- (goto-char (overlay-start region))
- (when (pos-visible-in-window-p
- (point) (get-buffer-window (current-buffer) 'visible))
- (if (< (overlay-end region) (line-end-position))
- (pulse-momentary-highlight-overlay
- region semantic-idle-symbol-highlight-face)
- ;; Not the same
- (pulse-momentary-highlight-region
- (overlay-start region)
- (line-end-position)
- semantic-idle-symbol-highlight-face))))
- ))
- ((vectorp region)
- (let ((start (aref region 0))
- (end (aref region 1)))
- (save-excursion
- (when buffer (set-buffer buffer))
- ;; As a vector, we have no filename. Perhaps it is a
- ;; local variable?
- (when (and (<= end (point-max))
- (pos-visible-in-window-p
- start (get-buffer-window (current-buffer) 'visible)))
- (goto-char start)
- (when (re-search-forward
- (regexp-quote (semantic-tag-name tag))
- end t)
- ;; This is likely it, give it a try.
- (pulse-momentary-highlight-region
- start (if (<= end (line-end-position)) end
- (line-end-position))
- semantic-idle-symbol-highlight-face)))
- ))))
- nil))
-
-(define-semantic-idle-service semantic-idle-local-symbol-highlight
- "Highlight the tag and symbol references of the symbol under point.
-Call `semantic-analyze-current-context' to find the reference tag.
-Call `semantic-symref-hits-in-region' to identify local references."
- (require 'pulse)
- (when (semantic-idle-summary-useful-context-p)
- (let* ((ctxt
- (semanticdb-without-unloaded-file-searches
- (semantic-analyze-current-context)))
- (Hbounds (when ctxt (oref ctxt bounds)))
- (target (when ctxt (car (reverse (oref ctxt prefix)))))
- (tag (semantic-current-tag))
- ;; We use pulse, but we don't want the flashy version,
- ;; just the stable version.
- (pulse-flag nil))
- (when (and ctxt tag)
- ;; Highlight the original tag? Protect against problems.
- (condition-case nil
- (semantic-idle-symbol-maybe-highlight target)
- (error nil))
- ;; Identify all hits in this current tag.
- (when (semantic-tag-p target)
- (require 'semantic/symref/filter)
- (semantic-symref-hits-in-region
- target (lambda (start end _prefix)
- (when (/= start (car Hbounds))
- (pulse-momentary-highlight-region
- start end semantic-idle-symbol-highlight-face))
- (semantic-throw-on-input 'symref-highlight)
- )
- (semantic-tag-start tag)
- (semantic-tag-end tag)))
- ))))
-
-\f
-;;;###autoload
-(define-minor-mode global-semantic-idle-scheduler-mode
- "Toggle global use of option `semantic-idle-scheduler-mode'.
-
-The idle scheduler will automatically reparse buffers in idle
-time, and then schedule other jobs setup with
-`semantic-idle-scheduler-add'."
- :global t
- :group 'semantic
- :group 'semantic-modes
- ;; When turning off, disable other idle modes.
- (when (null global-semantic-idle-scheduler-mode)
- (global-semantic-idle-summary-mode -1)
- (global-semantic-idle-local-symbol-highlight-mode -1)
- (global-semantic-idle-completions-mode -1))
- (semantic-toggle-minor-mode-globally
- 'semantic-idle-scheduler-mode
- (if global-semantic-idle-scheduler-mode 1 -1)))
-
-\f
-;;; Completion Popup Mode
-;;
-;; This mode uses tooltips to display a (hopefully) short list of possible
-;; completions available for the text under point. It provides
-;; NO provision for actually filling in the values from those completions.
-(defun semantic-idle-completions-end-of-symbol-p ()
- "Return non-nil if the cursor is at the END of a symbol.
-If the cursor is in the middle of a symbol, then we shouldn't be
-doing fancy completions."
- (not (looking-at "\\w\\|\\s_")))
-
-(defun semantic-idle-completion-list-default ()
- "Calculate and display a list of completions."
- (when (and (semantic-idle-summary-useful-context-p)
- (semantic-idle-completions-end-of-symbol-p))
- ;; This mode can be fragile, hence don't raise errors, and only
- ;; report problems if semantic-idle-scheduler-verbose-flag is
- ;; non-nil. If something doesn't do what you expect, run the
- ;; below command by hand instead.
- (condition-case err
- (semanticdb-without-unloaded-file-searches
- ;; Use idle version.
- (semantic-complete-analyze-inline-idle)
- )
- (error
- (when semantic-idle-scheduler-verbose-flag
- (message " %s" (error-message-string err)))))
- ))
-
-(define-semantic-idle-service semantic-idle-completions
- "Toggle Semantic Idle Completions mode.
-With ARG, turn Semantic Idle Completions mode on if ARG is
-positive, off otherwise.
-
-This minor mode only takes effect if Semantic is active and
-`semantic-idle-scheduler-mode' is enabled.
-
-When enabled, Emacs displays a list of possible completions at
-idle time. The method for displaying completions is given by
-`semantic-complete-inline-analyzer-idle-displayer-class'; the
-default is to show completions inline.
-
-While a completion is displayed, RET accepts the completion; M-n
-and M-p cycle through completion alternatives; TAB attempts to
-complete as far as possible, and cycles if no additional
-completion is possible; and any other command cancels the
-completion.
-
-\\{semantic-complete-inline-map}"
- ;; Add the ability to override sometime.
- (semantic-idle-completion-list-default))
-
-\f
-;;; Breadcrumbs for tag under point
-;;
-;; Service that displays a breadcrumbs indication of the tag under
-;; point and its parents in the header or mode line.
-;;
-
-(defcustom semantic-idle-breadcrumbs-display-function
- #'semantic-idle-breadcrumbs--display-in-header-line
- "Function to display the tag under point in idle time.
-This function should take a list of Semantic tags as its only
-argument. The tags are sorted according to their nesting order,
-starting with the outermost tag. The function should call
-`semantic-idle-breadcrumbs-format-tag-list-function' to convert
-the tag list into a string."
- :group 'semantic
- :type '(choice
- (const :tag "Display in header line"
- semantic-idle-breadcrumbs--display-in-header-line)
- (const :tag "Display in mode line"
- semantic-idle-breadcrumbs--display-in-mode-line)
- (function :tag "Other function")))
-
-(defcustom semantic-idle-breadcrumbs-format-tag-list-function
- #'semantic-idle-breadcrumbs--format-linear
- "Function to format the list of tags containing point.
-This function should take a list of Semantic tags and an optional
-maximum length of the produced string as its arguments. The
-maximum length is a hint and can be ignored. When the maximum
-length is omitted, an unconstrained string should be produced.
-The tags are sorted according to their nesting order, starting
-with the outermost tag. Single tags should be formatted using
-`semantic-idle-breadcrumbs-format-tag-function' unless special
-formatting is required."
- :group 'semantic
- :type '(choice
- (const :tag "Format tags as list, innermost last"
- semantic-idle-breadcrumbs--format-linear)
- (const :tag "Innermost tag with details, followed by remaining tags"
- semantic-idle-breadcrumbs--format-innermost-first)
- (function :tag "Other function")))
-
-(defcustom semantic-idle-breadcrumbs-format-tag-function
- #'semantic-format-tag-abbreviate
- "Function to call to format information about tags.
-This function should take a single argument, a Semantic tag, and
-return a string to display.
-Some useful functions are found in `semantic-format-tag-functions'."
- :group 'semantic
- :type semantic-format-tag-custom-list)
-
-(defcustom semantic-idle-breadcrumbs-separator 'mode-specific
- "Specify how to separate tags in the breadcrumbs string.
-An arbitrary string or a mode-specific scope nesting
-string (like, for example, \"::\" in C++, or \".\" in Java) can
-be used."
- :group 'semantic
- :type '(choice
- (const :tag "Use mode specific separator"
- mode-specific)
- (string :tag "Specify separator string")))
-
-(defcustom semantic-idle-breadcrumbs-header-line-prefix
- semantic-stickyfunc-indent-string ;; TODO not optimal
- "String used to indent the breadcrumbs string.
-Customize this string to match the space used by scrollbars and
-fringe."
- :group 'semantic
- :type 'string)
-
-(defvar semantic-idle-breadcrumbs-popup-menu nil
- "Menu used when a tag displayed by `semantic-idle-breadcrumbs-mode' is clicked.")
-
-(defun semantic-idle-breadcrumbs--popup-menu (event)
- "Popup a menu that displays things to do to the clicked tag.
-Argument EVENT describes the event that caused this function to
-be called."
- (interactive "e")
- (let ((old-window (selected-window))
- (window (semantic-event-window event)))
- (select-window window t)
- (popup-menu semantic-idle-breadcrumbs-popup-menu)
- (select-window old-window)))
-
-(defun semantic-idle-breadcrumbs--tag-function (function)
- "Return lambda expression calling FUNCTION when called from a popup."
- (lambda (event)
- (interactive "e")
- (let* ((old-window (selected-window))
- (window (semantic-event-window event))
- (column (car (nth 6 (nth 1 event)))) ;; TODO semantic-event-column?
- (tag (progn
- (select-window window t)
- (plist-get
- (text-properties-at column header-line-format)
- 'tag))))
- (funcall function tag)
- (select-window old-window))))
-
-;; TODO does this work for mode-line case?
-(defvar semantic-idle-breadcrumbs-popup-map
- (let ((map (make-sparse-keymap)))
- ;; mouse-1 goes to clicked tag
- (define-key map
- [ header-line mouse-1 ]
- (semantic-idle-breadcrumbs--tag-function #'semantic-go-to-tag))
- ;; mouse-3 pops up a context menu
- (define-key map
- [ header-line mouse-3 ]
- #'semantic-idle-breadcrumbs--popup-menu)
- map)
- "Keymap for semantic idle breadcrumbs minor mode.")
-
-(easy-menu-define
- semantic-idle-breadcrumbs-popup-menu
- semantic-idle-breadcrumbs-popup-map
- "Semantic Breadcrumbs Mode Menu."
- (list
- "Breadcrumb Tag"
- (vector
- "Go to Tag"
- (semantic-idle-breadcrumbs--tag-function #'semantic-go-to-tag)
- :active t
- :help "Jump to this tag")
- ;; TODO these entries need minor changes (optional tag argument) in
- ;; senator-copy-tag etc
- ;; (semantic-menu-item
- ;; (vector
- ;; "Copy Tag"
- ;; (semantic-idle-breadcrumbs--tag-function #'senator-copy-tag)
- ;; :active t
- ;; :help "Copy this tag"))
- ;; (semantic-menu-item
- ;; (vector
- ;; "Kill Tag"
- ;; (semantic-idle-breadcrumbs--tag-function #'senator-kill-tag)
- ;; :active t
- ;; :help "Kill tag text to the kill ring, and copy the tag to
- ;; the tag ring"))
- ;; (semantic-menu-item
- ;; (vector
- ;; "Copy Tag to Register"
- ;; (semantic-idle-breadcrumbs--tag-function #'senator-copy-tag-to-register)
- ;; :active t
- ;; :help "Copy this tag"))
- ;; (semantic-menu-item
- ;; (vector
- ;; "Narrow to Tag"
- ;; (semantic-idle-breadcrumbs--tag-function #'senator-narrow-to-defun)
- ;; :active t
- ;; :help "Narrow to the bounds of the current tag"))
- ;; (semantic-menu-item
- ;; (vector
- ;; "Fold Tag"
- ;; (semantic-idle-breadcrumbs--tag-function #'senator-fold-tag-toggle)
- ;; :active t
- ;; :style 'toggle
- ;; :selected '(let ((tag (semantic-current-tag)))
- ;; (and tag (semantic-tag-folded-p tag)))
- ;; :help "Fold the current tag to one line"))
- "---"
- (vector
- "About this Header Line"
- (lambda ()
- (interactive)
- (describe-function 'semantic-idle-breadcrumbs-mode))
- :active t
- :help "Display help about this header line.")))
-
-(define-semantic-idle-service semantic-idle-breadcrumbs
- "Display breadcrumbs for the tag under point and its parents."
- (let* ((scope (semantic-calculate-scope))
- (tag-list (if scope
- ;; If there is a scope, extract the tag and its
- ;; parents.
- (append (oref scope parents)
- (when (oref scope tag)
- (list (oref scope tag))))
- ;; Fall back to tags by overlay
- (semantic-find-tag-by-overlay))))
- ;; Display the tags.
- (funcall semantic-idle-breadcrumbs-display-function tag-list)))
-
-(defun semantic-idle-breadcrumbs--display-in-header-line (tag-list)
- "Display the tags in TAG-LIST in the header line of their buffer."
- (let ((width (- (nth 2 (window-edges))
- (nth 0 (window-edges)))))
- ;; Format TAG-LIST and put the formatted string into the header
- ;; line.
- (setq header-line-format
- (replace-regexp-in-string ;; Since % is interpreted in the
- "\\(%\\)" "%\\1" ;; mode/header line format, we
- (concat ;; have to escape all occurrences.
- semantic-idle-breadcrumbs-header-line-prefix
- (if tag-list
- (semantic-idle-breadcrumbs--format-tag-list
- tag-list
- (- width
- (length semantic-idle-breadcrumbs-header-line-prefix)))
- (propertize
- "<not on tags>"
- 'face
- 'font-lock-comment-face))))))
-
- ;; Update the header line.
- (force-mode-line-update))
-
-(defun semantic-idle-breadcrumbs--display-in-mode-line (tag-list)
- "Display the tags in TAG-LIST in the mode line of their buffer.
-TODO THIS FUNCTION DOES NOT WORK YET."
-
- (error "This function does not work yet")
-
- (let ((width (- (nth 2 (window-edges))
- (nth 0 (window-edges)))))
- (setq mode-line-format
- (replace-regexp-in-string ;; see comment in
- "\\(%\\)" "%\\1" ;; `semantic-idle-breadcrumbs--display-in-header-line'
- (semantic-idle-breadcrumbs--format-tag-list tag-list width))))
-
- (force-mode-line-update))
-
-(defun semantic-idle-breadcrumbs--format-tag-list (tag-list max-length)
- "Format TAG-LIST using configured functions respecting MAX-LENGTH.
-If the initial formatting result is longer than MAX-LENGTH, it is
-shortened at the beginning."
- ;; Format TAG-LIST using the configured formatting function.
- (let* ((complete-format (funcall
- semantic-idle-breadcrumbs-format-tag-list-function
- tag-list max-length))
- ;; Determine length of complete format.
- (complete-length (length complete-format)))
- ;; Shorten string if necessary.
- (if (<= complete-length max-length)
- complete-format
- (concat "... "
- (substring
- complete-format
- (- complete-length (- max-length 4))))))
- )
-
-(defun semantic-idle-breadcrumbs--format-linear
- (tag-list &optional _max-length)
- "Format TAG-LIST as a linear list, starting with the outermost tag.
-MAX-LENGTH is not used."
- (require 'semantic/analyze/fcn)
- (let* ((format-pieces (mapcar
- #'semantic-idle-breadcrumbs--format-tag
- tag-list))
- ;; Format tag list, putting configured separators between the
- ;; tags.
- (complete-format (cond
- ;; Mode specific separator.
- ((eq semantic-idle-breadcrumbs-separator
- 'mode-specific)
- (semantic-analyze-unsplit-name format-pieces))
-
- ;; Custom separator.
- ((stringp semantic-idle-breadcrumbs-separator)
- (mapconcat
- #'identity
- format-pieces
- semantic-idle-breadcrumbs-separator)))))
- complete-format)
- )
-
-(defun semantic-idle-breadcrumbs--format-innermost-first
- (tag-list &optional max-length)
- "Format TAG-LIST placing the innermost tag first, separated from its parents.
-If MAX-LENGTH is non-nil, the innermost tag is shortened."
- (let* (;; Separate and format remaining tags. Calculate length of
- ;; resulting string.
- (rest-tags (butlast tag-list))
- (rest-format (if rest-tags
- (concat
- " | "
- (semantic-idle-breadcrumbs--format-linear
- rest-tags))
- ""))
- (rest-length (length rest-format))
- ;; Format innermost tag and calculate length of resulting
- ;; string.
- (inner-format (semantic-idle-breadcrumbs--format-tag
- (car (last tag-list))
- #'semantic-format-tag-prototype))
- (inner-length (length inner-format))
- ;; Calculate complete length and shorten string for innermost
- ;; tag if MAX-LENGTH is non-nil and the complete string is
- ;; too long.
- (complete-length (+ inner-length rest-length))
- (inner-short (if (and max-length
- (<= complete-length max-length))
- inner-format
- (concat (substring
- inner-format
- 0
- (- inner-length
- (- complete-length max-length)
- 4))
- " ..."))))
- ;; Concat both parts.
- (concat inner-short rest-format))
- )
-
-(defun semantic-idle-breadcrumbs--format-tag (tag &optional format-function)
- "Format TAG using the configured function or FORMAT-FUNCTION.
-This function also adds text properties for help-echo, mouse
-highlighting and a keymap."
- (let ((formatted (funcall
- (or format-function
- semantic-idle-breadcrumbs-format-tag-function)
- tag nil t)))
- (add-text-properties
- 0 (length formatted)
- (list
- 'tag
- tag
- 'help-echo
- (format
- "Tag %s
-Type: %s
-mouse-1: jump to tag
-mouse-3: popup context menu"
- (semantic-tag-name tag)
- (semantic-tag-class tag))
- 'mouse-face
- 'highlight
- 'keymap
- semantic-idle-breadcrumbs-popup-map)
- formatted)
- formatted))
-
-
-(provide 'semantic/idle)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/idle"
-;; End:
-
-;;; semantic/idle.el ends here
+++ /dev/null
-;;; semantic/imenu.el --- Use Semantic as an imenu tag generator -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000-2005, 2007-2008, 2010-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This support function can be used in any buffer which supports
-;; the bovinator to create the imenu index.
-;;
-;; To use this in a buffer, do this in a hook.
-;;
-;; (add-hook 'mode-hook
-;; (lambda ()
-;; (setq imenu-create-index-function 'semantic-create-imenu-index)
-;; ))
-
-;;; Code:
-
-(require 'semantic)
-(require 'semantic/format)
-(require 'semantic/db)
-(require 'semantic/db-file)
-(require 'semantic/sort)
-(require 'imenu)
-
-(declare-function pulse-momentary-highlight-one-line "pulse"
- (&optional point face))
-(declare-function semanticdb-semantic-init-hook-fcn "db-mode")
-
-;; Because semantic imenu tags will hose the current imenu handling
-;; code in speedbar, force semantic/sb in.
-(with-eval-after-load 'speedbar
- (require 'semantic/sb))
-
-(defgroup semantic-imenu nil
- "Semantic interface to Imenu."
- :group 'semantic
- :group 'imenu
- )
-
-;;;###autoload
-(defcustom semantic-imenu-summary-function 'semantic-format-tag-abbreviate
- "Function to use when creating items in Imenu.
-Some useful functions are found in `semantic-format-tag-functions'."
- :type semantic-format-tag-custom-list)
-(make-variable-buffer-local 'semantic-imenu-summary-function)
-
-;;;###autoload
-(defcustom semantic-imenu-bucketize-file t
- "Non-nil if tags in a file are to be grouped into buckets."
- :type 'boolean)
-(make-variable-buffer-local 'semantic-imenu-bucketize-file)
-
-(defcustom semantic-imenu-adopt-external-members t
- "Non-nil if types in a file should adopt externally defined members.
-C++ and CLOS can define methods that are not in the body of a class
-definition."
- :type 'boolean)
-
-(defcustom semantic-imenu-buckets-to-submenu t
- "Non-nil if buckets of tags are to be turned into submenus.
-This option is ignored if `semantic-imenu-bucketize-file' is nil."
- :type 'boolean)
-(make-variable-buffer-local 'semantic-imenu-buckets-to-submenu)
-
-;;;###autoload
-(defcustom semantic-imenu-expand-type-members t
- "Non-nil if types should have submenus with members in them."
- :type 'boolean)
-(make-variable-buffer-local 'semantic-imenu-expand-type-members)
-
-(defcustom semantic-imenu-bucketize-type-members t
- "Non-nil if members of a type should be grouped into buckets.
-A nil value means to keep them in the same order.
-Overridden to nil if `semantic-imenu-bucketize-file' is nil."
- :type 'boolean)
-(make-variable-buffer-local 'semantic-imenu-bucketize-type-members)
-
-(defcustom semantic-imenu-sort-bucket-function nil
- "Function to use when sorting tags in the buckets of functions.
-See `semantic-bucketize' and the FILTER argument for more details
-on this function."
- :type '(radio (const :tag "No Sorting" nil)
- (const semantic-sort-tags-by-name-increasing)
- (const semantic-sort-tags-by-name-decreasing)
- (const semantic-sort-tags-by-type-increasing)
- (const semantic-sort-tags-by-type-decreasing)
- (const semantic-sort-tags-by-name-increasing-ci)
- (const semantic-sort-tags-by-name-decreasing-ci)
- (const semantic-sort-tags-by-type-increasing-ci)
- (const semantic-sort-tags-by-type-decreasing-ci)
- (function)))
-(make-variable-buffer-local 'semantic-imenu-sort-bucket-function)
-
-(defcustom semantic-imenu-index-directory nil
- "Non-nil to index the entire directory for tags.
-Doesn't actually parse the entire directory, but displays tags for all files
-currently listed in the current Semantic database.
-This variable has no meaning if semanticdb is not active."
- :type 'boolean)
-
-(defcustom semantic-imenu-auto-rebuild-directory-indexes nil
- "If non-nil automatically rebuild directory index imenus.
-That is when a directory index imenu is updated, automatically rebuild
-other buffer local ones based on the same semanticdb."
- :type 'boolean)
-
-(defvar semantic-imenu-directory-current-file nil
- "When building a file index, this is the file name currently being built.")
-
-(defvar semantic-imenu-auto-rebuild-running nil
- "Non-nil if `semantic-imenu-rebuild-directory-indexes' is running.")
-
-;;;###autoload
-(defvar-local semantic-imenu-expandable-tag-classes '(type)
- "List of expandable tag classes.
-Tags of those classes will be given submenu with children.
-By default, a `type' has interesting children. In Texinfo, however, a
-`section' has interesting children.")
-
-(defun semantic-imenu-tag-overlay (tag)
- "Return the overlay belonging to tag.
-If TAG doesn't have an overlay, and instead as a vector of positions,
-concoct a combination of file name, and position."
- (let ((o (semantic-tag-overlay tag)))
- (if (not (overlayp o))
- (let ((v (make-vector 3 nil)))
- (aset v 0 semantic-imenu-directory-current-file)
- (aset v 1 (aref o 0))
- (aset v 2 (aref o 1))
- v)
- o)))
-
-
-(defun semantic-imenu-goto-function (name position &optional rest)
- "Move point associated with NAME to POSITION.
-Used to override function `imenu-default-goto-function' so that
-we can continue to use overlays to maintain the current position.
-Optional argument REST is some extra stuff."
- (require 'pulse)
- (if (overlayp position)
- (let ((os (overlay-start position))
- (ob (overlay-buffer position)))
- (if os
- (progn
- (if (not (eq ob (current-buffer)))
- (switch-to-buffer ob))
- (imenu-default-goto-function name os rest)
- (pulse-momentary-highlight-one-line (point))
- )
- ;; This should never happen, but check anyway.
- (message "Imenu is out of date, try again. (internal bug)")
- (setq imenu--index-alist nil)))
- ;; When the POSITION is actually a pair of numbers in an array, then
- ;; the file isn't loaded into the current buffer.
- (if (vectorp position)
- (let ((file (aref position 0))
- (pos (aref position 1)))
- (and file (find-file file))
- (imenu-default-goto-function name pos rest)
- (pulse-momentary-highlight-one-line (point))
- )
- ;; When the POSITION is the symbol 'file-only' it means that this
- ;; is a directory index entry and there is no tags in this
- ;; file. So just jump to the beginning of the file.
- (if (eq position 'file-only)
- (progn
- (find-file name)
- (imenu-default-goto-function name (point-min) rest)
- (pulse-momentary-highlight-one-line (point))
- )
- ;; Probably POSITION don't came from a semantic imenu. Try
- ;; the default imenu goto function.
- (condition-case nil
- (progn
- (imenu-default-goto-function name position rest)
- (pulse-momentary-highlight-one-line (point))
- )
- (error
- (message "Semantic Imenu override problem. (Internal bug)")
- (setq imenu--index-alist nil)))))
- ))
-
-(defun semantic-imenu-flush-fcn (&optional _ignore)
- "This function is called as a hook to clear the imenu cache.
-It is cleared after any parsing.
-IGNORE arguments."
- (if (eq imenu-create-index-function 'semantic-create-imenu-index)
- (setq imenu--index-alist nil
- imenu-menubar-modified-tick 0))
- (remove-hook 'semantic-after-toplevel-cache-change-hook
- #'semantic-imenu-flush-fcn t)
- (remove-hook 'semantic-after-partial-cache-change-hook
- #'semantic-imenu-flush-fcn t)
- )
-
-;;;###autoload
-(defun semantic-create-imenu-index (&optional stream)
- "Create an imenu index for any buffer which supports Semantic.
-Uses the output of the Semantic parser to create the index.
-Optional argument STREAM is an optional stream of tags used to create menus."
- (setq imenu-default-goto-function #'semantic-imenu-goto-function)
- (prog1
- (if (and semantic-imenu-index-directory
- (featurep 'semantic/db)
- (semanticdb-minor-mode-p))
- (semantic-create-imenu-directory-index
- (or stream (semantic-fetch-tags-fast)))
- (semantic-create-imenu-index-1
- (or stream (semantic-fetch-tags-fast)) nil))
- (add-hook 'semantic-after-toplevel-cache-change-hook
- #'semantic-imenu-flush-fcn nil t)
- (add-hook 'semantic-after-partial-cache-change-hook
- #'semantic-imenu-flush-fcn nil t)))
-
-(defun semantic-create-imenu-directory-index (&optional stream)
- "Create an imenu tag index based on all files active in semanticdb.
-Optional argument STREAM is the stream of tags for the current buffer."
- (if (not semanticdb-current-database)
- (semantic-create-imenu-index-1 stream nil)
- ;; We have a database, list all files, with the current file on top.
- (let ((index (list
- (cons (oref semanticdb-current-table file)
- (or (semantic-create-imenu-index-1 stream nil)
- ;; No tags in this file
- 'file-only))))
- (tables (semanticdb-get-database-tables semanticdb-current-database)))
- (while tables
- (let ((semantic-imenu-directory-current-file
- (oref (car tables) file))
- tags)
- (when (and (not (eq (car tables) semanticdb-current-table))
- (semanticdb-live-p (car tables))
- (semanticdb-equivalent-mode (car tables))
- )
- (setq tags (oref (car tables) tags)
- index (cons (cons semantic-imenu-directory-current-file
- (or (and tags
- ;; don't pass nil stream because
- ;; it will use the current
- ;; buffer
- (semantic-create-imenu-index-1
- (oref (car tables) tags)
- nil))
- ;; no tags in the file
- 'file-only))
- index)))
- (setq tables (cdr tables))))
-
- ;; If enabled automatically rebuild other imenu directory
- ;; indexes based on the same Semantic database
- (or (not semantic-imenu-auto-rebuild-directory-indexes)
- ;; If auto rebuild already in progress does nothing
- semantic-imenu-auto-rebuild-running
- (unwind-protect
- (progn
- (setq semantic-imenu-auto-rebuild-running t)
- (semantic-imenu-rebuild-directory-indexes
- semanticdb-current-database))
- (setq semantic-imenu-auto-rebuild-running nil)))
-
- (nreverse index))))
-
-(defun semantic-create-imenu-index-1 (stream &optional parent)
- "Create an imenu index for any buffer which supports Semantic.
-Uses the output of the Semantic parser to create the index.
-STREAM is a stream of tags used to create menus.
-Optional argument PARENT is a tag parent of STREAM."
- (let ((tags stream)
- (semantic-imenu-adopt-external-members
- semantic-imenu-adopt-external-members))
- ;; If we should regroup, do so.
- (if semantic-imenu-adopt-external-members
- (setq tags (semantic-adopt-external-members tags)
- ;; Don't allow recursion here.
- semantic-imenu-adopt-external-members nil))
- ;; Test for bucketing vs not.
- (if semantic-imenu-bucketize-file
- (let ((buckets (semantic-bucketize
- tags parent
- semantic-imenu-sort-bucket-function))
- item name
- index)
- (cond
- ((null buckets)
- nil)
- ((or (cdr-safe buckets) ;; if buckets has more than one item in it.
- (not semantic-imenu-buckets-to-submenu)) ;; to force separators between buckets
- (while buckets
- (setq name (car (car buckets))
- item (cdr (car buckets)))
- (if semantic-imenu-buckets-to-submenu
- (progn
- ;; Make submenus
- (if item
- (setq index
- (cons (cons name
- (semantic-create-imenu-subindex item))
- index))))
- ;; Glom everything together with "---" between
- (if item
- (setq index
- (append index
- ;; do not create a menu separator in the parent menu
- ;; when creating a sub-menu
- (if (memq (semantic-tag-class (car item))
- semantic-imenu-expandable-tag-classes)
- (semantic-create-imenu-subindex item)
- (cons
- '("---")
- (semantic-create-imenu-subindex item)))))
- ))
- (setq buckets (cdr buckets)))
- (if semantic-imenu-buckets-to-submenu
- (nreverse index)
- index))
- (t
- (setq name (car (car buckets))
- item (cdr (car buckets)))
- (semantic-create-imenu-subindex item))))
- ;; Else, group everything together
- (semantic-create-imenu-subindex tags))))
-
-(defun semantic-create-imenu-subindex (tags)
- "From TAGS, create an imenu index of interesting things."
- (let ((notypecheck (not semantic-imenu-expand-type-members))
- children index tag parts)
- (while tags
- (setq tag (car tags)
- children (semantic-tag-components-with-overlays tag))
- (if (and (not notypecheck)
- (memq (semantic-tag-class tag)
- semantic-imenu-expandable-tag-classes)
- children
- )
- ;; to keep an homogeneous menu organization, type menu items
- ;; always have a sub-menu with at least the *definition*
- ;; item (even if the tag has no type components)
- (progn
- (setq parts children)
- ;; There is options which create the submenu
- ;; * Type has an overlay, but children do.
- ;; The type doesn't have to have it's own overlay,
- ;; but a type with no overlay and no children should be
- ;; invalid.
- (setq index
- (cons
- (cons
- (funcall semantic-imenu-summary-function tag)
- ;; Add a menu for getting at the type definitions
- (if (and parts
- ;; Note to self: enable menu items for
- ;; sub parts even if they are not proper
- ;; tags.
- (semantic-tag-p (car parts)))
- (let ((submenu
- (if (and semantic-imenu-bucketize-type-members
- semantic-imenu-bucketize-file)
- (semantic-create-imenu-index-1 parts tag)
- (semantic-create-imenu-subindex parts))))
- ;; Only add a *definition* if we have a position
- ;; in that type tag.
- (if (semantic-tag-with-position-p tag)
- (cons
- (cons "*definition*"
- (semantic-imenu-tag-overlay tag))
- submenu)
- submenu))
- ;; There were no parts, or something like that, so
- ;; instead just put the definition here.
- (if (semantic-tag-with-position-p tag)
- (semantic-imenu-tag-overlay tag)
- nil)
- ))
- index)))
- (if (semantic-tag-with-position-p tag)
- (setq index (cons
- (cons
- (funcall semantic-imenu-summary-function tag)
- (semantic-imenu-tag-overlay tag))
- index))))
- (setq tags (cdr tags)))
- ;; `imenu--split-submenus' sort submenus according to
- ;; `imenu-sort-function' setting and split them up if they are
- ;; longer than `imenu-max-items'.
- (imenu--split-submenus (nreverse index))))
-
-;;; directory imenu rebuilding.
-;;
-(defun semantic-imenu-rebuild-directory-indexes (db)
- "Rebuild directory index imenus based on Semantic database DB."
- (let ((l (buffer-list))
- b)
- (while l
- (setq b (car l)
- l (cdr l))
- (if (and (not (eq b (current-buffer)))
- (buffer-live-p b))
- (with-current-buffer b
- ;; If there is a buffer local Semantic index directory
- ;; imenu
- (when (and (eq imenu-create-index-function
- 'semantic-create-imenu-index)
- semanticdb-current-database
- (eq semanticdb-current-database db))
- ;; Rebuild the imenu
- (imenu--cleanup)
- (setq imenu--index-alist nil)
- (imenu-update-menubar)))))))
-
-(defun semantic-imenu-semanticdb-hook ()
- "Function to be called from `semanticdb-mode-hook'.
-Clears all imenu menus that may be depending on the database."
- (require 'semantic/db-mode)
- (semantic-map-buffers
- (lambda ()
- ;; Set up semanticdb environment if enabled.
- (if (semanticdb-minor-mode-p)
- (semanticdb-semantic-init-hook-fcn))
- ;; Clear imenu cache to redraw the imenu.
- (semantic-imenu-flush-fcn))))
-
-(add-hook 'semanticdb-mode-hook #'semantic-imenu-semanticdb-hook)
-
-;;; Interactive Utilities
-;;
-(defun semantic-imenu-toggle-bucketize-file ()
- "Toggle the ability of imenu to bucketize the current file."
- (interactive)
- (setq semantic-imenu-bucketize-file (not semantic-imenu-bucketize-file))
- ;; Force a rescan
- (setq imenu--index-alist nil))
-
-(defun semantic-imenu-toggle-buckets-to-submenu ()
- "Toggle the ability of imenu to turn buckets into submenus."
- (interactive)
- (setq semantic-imenu-buckets-to-submenu (not semantic-imenu-buckets-to-submenu))
- ;; Force a rescan
- (setq imenu--index-alist nil))
-
-(defun semantic-imenu-toggle-bucketize-type-parts ()
- "Toggle the ability of imenu to bucketize the current file."
- (interactive)
- (setq semantic-imenu-bucketize-type-members (not semantic-imenu-bucketize-type-members))
- ;; Force a rescan
- (setq imenu--index-alist nil))
-
-;;; Which function support
-;;
-;; The which-function library will display the current function in the
-;; mode line. It tries to do this through imenu. With a semantic parsed
-;; buffer, there is a much more efficient way of doing this.
-;; Advise `which-function' so that we optionally use semantic tags
-;; instead, and get better stuff.
-
-(defvar semantic-which-function #'semantic-default-which-function
- "Function to convert semantic tags into `which-function' text.")
-
-(defcustom semantic-which-function-use-color nil
- "Use color when displaying the current function with `which-function'."
- :type 'boolean)
-
-(defun semantic-default-which-function (taglist)
- "Convert TAGLIST into a string usable by `which-function'.
-Returns the first tag name in the list, unless it is a type,
-in which case it concatenates them together."
- (cond ((eq (length taglist) 1)
- (semantic-format-tag-abbreviate
- (car taglist) nil semantic-which-function-use-color))
- ((memq (semantic-tag-class (car taglist))
- semantic-imenu-expandable-tag-classes)
- (concat (semantic-format-tag-name
- (car taglist) nil semantic-which-function-use-color)
- (car semantic-type-relation-separator-character)
- ;; recurse until we no longer have a type
- ;; or any tags left.
- (semantic-default-which-function (cdr taglist))))
- (t (semantic-format-tag-abbreviate
- (car taglist) nil semantic-which-function-use-color))))
-
-;; (defadvice which-function (around semantic-which activate)
-;; "Choose the function to display via semantic if it is currently active."
-;; (if (and (featurep 'semantic) semantic--buffer-cache)
-;; (let ((ol (semantic-find-tag-by-overlay)))
-;; (setq ad-return-value (funcall semantic-which-function ol)))
-;; ad-do-it))
-
-(provide 'semantic/imenu)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/imenu"
-;; End:
-
-;;; semantic/imenu.el ends here
+++ /dev/null
-;;; semantic/java.el --- Semantic functions for Java -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Common function for Java parsers.
-
-;;; 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
- (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][[:xdigit:]]+[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][[:xdigit:]]+
- ;
-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)))
-
- ((and (eq class 'type) (string-search "." (semantic-tag-name tag)))
- ;; javap outputs files where the package name is stuck onto the class or interface
- ;; name. To make this more regular, we extract the package name into a package statement,
- ;; then make the class name regular.
- (let* ((name (semantic-tag-name tag))
- (rsplit (nreverse (split-string name "\\." t)))
- (newclassname (car rsplit))
- (newpkg (mapconcat #'identity (reverse (cdr rsplit)) ".")))
- (semantic-tag-set-name tag newclassname)
- (setq xpand
- (list tag
- (semantic-tag-new-package newpkg nil))))
- ))
- 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 language.")
-
-;; 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))))
-
-;; Tag Protection
-;;
-(define-mode-local-override semantic-tag-protection
- java-mode (tag &optional parent)
- "Return the protection of TAG in PARENT.
-Override function for `semantic-tag-protection'."
- (let ((prot (semantic-tag-protection-default tag parent)))
- (or prot 'package)))
-
-;; 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-tag-prototype'."
- (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-tag-prototype'."
- (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-tag-prototype'."
- (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-tag-prototype
- 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)))
-
-;; 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 preceding 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
-<https://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 keywords which have a value for PROPERTY. FUN
-receives two arguments: the javadoc keyword and its associated
-`javadoc' property list. It can return any value. All 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/java)
-
-;; Local variables:
-;; generated-autoload-load-name: "semantic/java"
-;; End:
-
-;;; semantic/java.el ends here
+++ /dev/null
-;;; semantic/lex-spp.el --- Semantic Lexical Pre-processor -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2006-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; The Semantic Preprocessor works with semantic-lex to provide a phase
-;; during lexical analysis to do the work of a pre-processor.
-;;
-;; A pre-processor identifies lexical syntax mixed in with another language
-;; and replaces some keyword tokens with streams of alternate tokens.
-;;
-;; If you use SPP in your language, be sure to specify this in your
-;; semantic language setup function:
-;;
-;; (add-hook 'semantic-lex-reset-functions 'semantic-lex-spp-reset-hook nil t)
-;;
-;;
-;; Special Lexical Tokens:
-;;
-;; There are several special lexical tokens that are used by the
-;; Semantic PreProcessor lexer. They are:
-;;
-;; Declarations:
-;; spp-macro-def - A definition of a lexical macro.
-;; spp-macro-undef - A removal of a definition of a lexical macro.
-;; spp-system-include - A system level include file
-;; spp-include - An include file
-;; spp-concat - A lexical token representing textual concatenation
-;; of symbol parts.
-;;
-;; Operational tokens:
-;; spp-arg-list - Represents an argument list to a macro.
-;; spp-symbol-merge - A request for multiple symbols to be textually merged.
-;;
-;;; TODO:
-;;
-;; Use `semantic-push-parser-warning' for situations where there are likely
-;; macros that are undefined unexpectedly, or other problem.
-;;
-;; TODO:
-;;
-;; Try to handle the case of:
-;;
-;; #define NN namespace nn {
-;; #define NN_END }
-;;
-;; NN
-;; int mydecl() {}
-;; NN_END
-;;
-
-(require 'semantic)
-(require 'semantic/lex)
-
-(declare-function c-end-of-macro "cc-engine")
-
-;;; Code:
-(defvar-local semantic-lex-spp-macro-symbol-obarray nil
- "Table of macro keywords used by the Semantic Preprocessor.
-These symbols will be used in addition to those in
-`semantic-lex-spp-dynamic-macro-symbol-obarray'.")
-
-(defvar-local semantic-lex-spp-project-macro-symbol-obarray nil
- "Table of macro keywords for this project.
-These symbols will be used in addition to those in
-`semantic-lex-spp-dynamic-macro-symbol-obarray'.")
-
-(defvar-local semantic-lex-spp-dynamic-macro-symbol-obarray nil
- "Table of macro keywords used during lexical analysis.
-Macros are lexical symbols which are replaced by other lexical
-tokens during lexical analysis. During analysis symbols can be
-added and removed from this symbol table.")
-
-(defvar-local semantic-lex-spp-dynamic-macro-symbol-obarray-stack nil
- "A stack of obarrays for temporarily scoped macro values.")
-
-(defvar semantic-lex-spp-expanded-macro-stack nil
- "The stack of lexical SPP macros we have expanded.")
-;; The above is not buffer local. Some macro expansions need to be
-;; dumped into a secondary buffer for re-lexing.
-
-;;; NON-RECURSIVE MACRO STACK
-;; C Pre-processor does not allow recursive macros. Here are some utils
-;; for managing the symbol stack of where we've been.
-
-(defmacro semantic-lex-with-macro-used (name &rest body)
- "With the macro NAME currently being expanded, execute BODY.
-Pushes NAME into the macro stack. The above stack is checked
-by `semantic-lex-spp-symbol' to not return true for any symbol
-currently being expanded."
- (declare (indent 1) (debug (symbolp def-body)))
- `(unwind-protect
- (progn
- (push ,name semantic-lex-spp-expanded-macro-stack)
- ,@body)
- (pop semantic-lex-spp-expanded-macro-stack)))
-
-;;; MACRO TABLE UTILS
-;;
-;; The dynamic macro table is a buffer local variable that is modified
-;; during the analysis. OBARRAYs are used, so the language must
-;; have symbols that are compatible with Emacs Lisp symbols.
-;;
-(defsubst semantic-lex-spp-symbol (name)
- "Return spp symbol with NAME or nil if not found.
-The search priority is:
- 1. DYNAMIC symbols
- 2. PROJECT specified symbols.
- 3. SYSTEM specified symbols."
- (and
- ;; Only strings...
- (stringp name)
- ;; Make sure we don't recurse.
- (not (member name semantic-lex-spp-expanded-macro-stack))
- ;; Do the check of the various tables.
- (or
- ;; DYNAMIC
- (and (obarrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
- (intern-soft name semantic-lex-spp-dynamic-macro-symbol-obarray))
- ;; PROJECT
- (and (obarrayp semantic-lex-spp-project-macro-symbol-obarray)
- (intern-soft name semantic-lex-spp-project-macro-symbol-obarray))
- ;; SYSTEM
- (and (obarrayp semantic-lex-spp-macro-symbol-obarray)
- (intern-soft name semantic-lex-spp-macro-symbol-obarray))
- ;; ...
- )))
-
-(defsubst semantic-lex-spp-symbol-p (name)
- "Return non-nil if a keyword with NAME exists in any keyword table."
- (if (semantic-lex-spp-symbol name)
- t))
-
-(defsubst semantic-lex-spp-dynamic-map ()
- "Return the dynamic macro map for the current buffer."
- (or semantic-lex-spp-dynamic-macro-symbol-obarray
- (setq semantic-lex-spp-dynamic-macro-symbol-obarray
- (obarray-make 13))))
-
-(defsubst semantic-lex-spp-dynamic-map-stack ()
- "Return the dynamic macro map for the current buffer."
- (or semantic-lex-spp-dynamic-macro-symbol-obarray-stack
- (setq semantic-lex-spp-dynamic-macro-symbol-obarray-stack
- (obarray-make 13))))
-
-(defun semantic-lex-spp-value-valid-p (value)
- "Return non-nil if VALUE is valid."
- (or (null value)
- (stringp value)
- (and (consp value)
- (or (semantic-lex-token-p (car value))
- (eq (car (car value)) 'spp-arg-list)))))
-
-(defvar semantic-lex-spp-debug-symbol nil
- "A symbol to break on if it is being set somewhere.")
-
-(defun semantic-lex-spp-enable-debug-symbol (sym)
- "Enable debugging for symbol SYM.
-Disable debugging by entering nothing."
- (interactive "sSymbol: ")
- (if (string= sym "")
- (setq semantic-lex-spp-debug-symbol nil)
- (setq semantic-lex-spp-debug-symbol sym)))
-
-(defmacro semantic-lex-spp-validate-value (_name _value)
- "Validate the NAME and VALUE of a macro before it is set."
-; `(progn
-; (when (not (semantic-lex-spp-value-valid-p ,value))
-; (error "Symbol \"%s\" with bogus value %S" ,name ,value))
-; (when (and semantic-lex-spp-debug-symbol
-; (string= semantic-lex-spp-debug-symbol name))
-; (debug))
-; )
- nil
- )
-
-(defun semantic-lex-spp-symbol-set (name value &optional obarray-in)
- "Set value of spp symbol with NAME to VALUE and return VALUE.
-If optional OBARRAY-IN is non-nil, then use that obarray instead of
-the dynamic map."
- (semantic-lex-spp-validate-value name value)
- (if (and (stringp value) (string= value "")) (setq value nil))
- (set (intern name (or obarray-in
- (semantic-lex-spp-dynamic-map)))
- value))
-
-(defsubst semantic-lex-spp-symbol-remove (name &optional map)
- "Remove the spp symbol with NAME.
-If optional obarray MAP is non-nil, then use that obarray instead of
-the dynamic map."
- (unintern name (or map (semantic-lex-spp-dynamic-map))))
-
-(defun semantic-lex-spp-symbol-push (name value)
- "Push macro NAME with VALUE into the map.
-Reverse with `semantic-lex-spp-symbol-pop'."
- (semantic-lex-spp-validate-value name value)
- (let* ((map (semantic-lex-spp-dynamic-map))
- (stack (semantic-lex-spp-dynamic-map-stack))
- (mapsym (intern name map))
- (stacksym (intern name stack))
- (mapvalue (when (boundp mapsym) (symbol-value mapsym)))
- )
- (when (boundp mapsym)
- ;; Make sure there is a stack
- (if (not (boundp stacksym)) (set stacksym nil))
- ;; If there is a value to push, then push it.
- (set stacksym (cons mapvalue (symbol-value stacksym)))
- )
- ;; Set our new value here.
- (set mapsym value)
- ))
-
-(defun semantic-lex-spp-symbol-pop (name)
- "Pop macro NAME from the stackmap into the orig map.
-Reverse with `semantic-lex-spp-symbol-pop'."
- (let* ((map (semantic-lex-spp-dynamic-map))
- (stack (semantic-lex-spp-dynamic-map-stack))
- (mapsym (intern name map))
- (stacksym (intern name stack))
- ;; (oldvalue nil)
- )
- (if (or (not (boundp stacksym) )
- (= (length (symbol-value stacksym)) 0))
- ;; Nothing to pop, remove it.
- (unintern name map)
- ;; If there is a value to pop, then add it to the map.
- (set mapsym (car (symbol-value stacksym)))
- (set stacksym (cdr (symbol-value stacksym)))
- )))
-
-(defsubst semantic-lex-spp-symbol-stream (name)
- "Return replacement stream of macro with NAME."
- (let ((spp (semantic-lex-spp-symbol name)))
- (if spp
- (symbol-value spp))))
-
-(defun semantic-lex-make-spp-table (specs)
- "Convert spp macro list SPECS into an obarray and return it.
-SPECS must be a list of (NAME . REPLACEMENT) elements, where:
-
-NAME is the name of the spp macro symbol to define.
-REPLACEMENT a string that would be substituted in for NAME."
-
- ;; Create the symbol hash table
- (let ((semantic-lex-spp-macro-symbol-obarray (obarray-make 13))
- spec)
- ;; fill it with stuff
- (while specs
- (setq spec (car specs)
- specs (cdr specs))
- (semantic-lex-spp-symbol-set
- (car spec)
- (cdr spec)
- semantic-lex-spp-macro-symbol-obarray))
- semantic-lex-spp-macro-symbol-obarray))
-
-(defun semantic-lex-spp-save-table ()
- "Return a list of spp macros and values.
-The return list is meant to be saved in a semanticdb table."
- (let (macros)
- (when (obarrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
- (mapatoms
- (lambda (symbol)
- (setq macros (cons (cons (symbol-name symbol)
- (symbol-value symbol))
- macros)))
- semantic-lex-spp-dynamic-macro-symbol-obarray))
- macros))
-
-(defun semantic-lex-spp-macros ()
- "Return a list of spp macros as Lisp symbols.
-The value of each symbol is the replacement stream."
- (let (macros)
- (when (obarrayp semantic-lex-spp-macro-symbol-obarray)
- (mapatoms
- (lambda (symbol)
- (setq macros (cons symbol macros)))
- semantic-lex-spp-macro-symbol-obarray))
- (when (obarrayp semantic-lex-spp-project-macro-symbol-obarray)
- (mapatoms
- (lambda (symbol)
- (setq macros (cons symbol macros)))
- semantic-lex-spp-project-macro-symbol-obarray))
- (when (obarrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
- (mapatoms
- (lambda (symbol)
- (setq macros (cons symbol macros)))
- semantic-lex-spp-dynamic-macro-symbol-obarray))
- macros))
-
-(defun semantic-lex-spp-set-dynamic-table (new-entries)
- "Set the dynamic symbol table to NEW-ENTRIES.
-For use with semanticdb restoration of state."
- (dolist (e new-entries)
- ;; Default obarray for below is the dynamic map.
- (semantic-lex-spp-symbol-set (car e) (cdr e))))
-
-(defun semantic-lex-spp-reset-hook (start _end)
- "Reset anything needed by SPP for parsing.
-In this case, reset the dynamic macro symbol table if
-START is (point-min).
-END is not used."
- (when (= start (point-min))
- (setq semantic-lex-spp-dynamic-macro-symbol-obarray nil
- semantic-lex-spp-dynamic-macro-symbol-obarray-stack nil
- ;; This shouldn't not be nil, but reset just in case.
- semantic-lex-spp-expanded-macro-stack nil)
- ))
-
-;;; MACRO EXPANSION: Simple cases
-;;
-;; If a user fills in the table with simple strings, we can
-;; support that by converting them into tokens with the
-;; various analyzers that are available.
-
-(defun semantic-lex-spp-extract-regex-and-compare (analyzer value)
- "Extract a regexp from an ANALYZER and use to match VALUE.
-Return non-nil if it matches"
- (let* ((condition (car analyzer))
- (regex (cond ((eq (car condition) 'looking-at)
- (nth 1 condition))
- (t
- nil))))
- (when regex
- (string-match regex value))
- ))
-
-(defun semantic-lex-spp-simple-macro-to-macro-stream (val beg end _argvalues)
- "Convert lexical macro contents VAL into a macro expansion stream.
-These are for simple macro expansions that a user may have typed in directly.
-As such, we need to analyze the input text, to figure out what kind of real
-lexical token we should be inserting in its place.
-
-Argument VAL is the value of some macro to be converted into a stream.
-BEG and END are the token bounds of the macro to be expanded
-that will somehow gain a much longer token stream.
-ARGVALUES are values for any arg list, or nil."
- (cond
- ;; We perform a replacement. Technically, this should
- ;; be a full lexical step over the "val" string, but take
- ;; a guess that its just a keyword or existing symbol.
- ;;
- ;; Probably a really bad idea. See how it goes.
- ((semantic-lex-spp-extract-regex-and-compare
- semantic-lex-symbol-or-keyword val)
- (semantic-lex-push-token
- (semantic-lex-token (or (semantic-lex-keyword-p val) 'symbol)
- beg end
- val)))
-
- ;; Ok, the rest of these are various types of syntax.
- ;; Conveniences for users that type in their symbol table.
- ((semantic-lex-spp-extract-regex-and-compare
- semantic-lex-punctuation val)
- (semantic-lex-token 'punctuation beg end val))
- ((semantic-lex-spp-extract-regex-and-compare
- semantic-lex-number val)
- (semantic-lex-token 'number beg end val))
- ((semantic-lex-spp-extract-regex-and-compare
- semantic-lex-paren-or-list val)
- (semantic-lex-token 'semantic-list beg end val))
- ((semantic-lex-spp-extract-regex-and-compare
- semantic-lex-string val)
- (semantic-lex-token 'string beg end val))
- (t nil)
- ))
-
-;;; MACRO EXPANSION : Lexical token replacement
-;;
-;; When substituting in a macro from a token stream of formatted
-;; semantic lex tokens, things can be much more complicated.
-;;
-;; Some macros have arguments that get set into the dynamic macro
-;; table during replacement.
-;;
-;; In general, the macro tokens are substituted into the regular
-;; token stream, but placed under the characters of the original
-;; macro symbol.
-;;
-;; Argument lists are saved as a lexical token at the beginning
-;; of a replacement value.
-
-(defun semantic-lex-spp-one-token-to-txt (tok &optional blocktok)
- "Convert the token TOK into a string.
-If TOK is made of multiple tokens, convert those to text. This
-conversion is needed if a macro has a merge symbol in it that
-combines the text of two previously distinct symbols. For
-example, in c:
-
-#define (a,b) a ## b;
-
-If optional string BLOCKTOK matches the expanded value, then do not
-continue processing recursively."
- (let ((txt (semantic-lex-token-text tok))
- (sym nil)
- )
- (cond
- ;; Recursion prevention
- ((and (stringp blocktok) (string= txt blocktok))
- blocktok)
- ;; A complex symbol
- ((and (eq (car tok) 'symbol)
- (setq sym (semantic-lex-spp-symbol txt))
- (not (semantic-lex-spp-macro-with-args (symbol-value sym)))
- )
- ;; Now that we have a symbol,
- (let ((val (symbol-value sym)))
- (cond
- ;; This is another lexical token.
- ((and (consp val)
- (symbolp (car val)))
- (semantic-lex-spp-one-token-to-txt val txt))
- ;; This is a list of tokens.
- ((and (consp val)
- (consp (car val))
- (symbolp (car (car val))))
- (mapconcat (lambda (subtok)
- (semantic-lex-spp-one-token-to-txt subtok))
- val))
- ;; If val is nil, that's probably wrong.
- ;; Found a system header case where this was true.
- ((null val) "")
- ;; Debug weird stuff.
- (t (debug)))
- ))
- ((stringp txt)
- txt)
- (t nil))
- ))
-
-(defun semantic-lex-spp-macro-with-args (val)
- "If the macro value VAL has an argument list, return the arglist."
- (when (and val (consp val) (consp (car val))
- (eq 'spp-arg-list (car (car val))))
- (car (cdr (car val)))))
-
-(defun semantic-lex-spp-token-macro-to-macro-stream (val beg end argvalues)
- "Convert lexical macro contents VAL into a macro expansion stream.
-Argument VAL is the value of some macro to be converted into a stream.
-BEG and END are the token bounds of the macro to be expanded
-that will somehow gain a much longer token stream.
-ARGVALUES are values for any arg list, or nil.
-See comments in code for information about how token streams are processed
-and what valid VAL values are."
-
- ;; A typical VAL value might be either a stream of tokens.
- ;; Tokens saved into a macro stream always includes the text from the
- ;; buffer, since the locations specified probably don't represent
- ;; that text anymore, or even the same buffer.
- ;;
- ;; CASE 1: Simple token stream
- ;;
- ;; #define SUPER mysuper::
- ;; ==>
- ;;((symbol "mysuper" 480 . 487)
- ;; (punctuation ":" 487 . 488)
- ;; (punctuation ":" 488 . 489))
- ;;
- ;; CASE 2: Token stream with argument list
- ;;
- ;; #define INT_FCN(name) int name (int in)
- ;; ==>
- ;; ((spp-arg-list ("name") 558 . 564)
- ;; (INT "int" 565 . 568)
- ;; (symbol "name" 569 . 573)
- ;; (semantic-list "(int in)" 574 . 582))
- ;;
- ;; In the second case, a macro with an argument list as the args as the
- ;; first entry.
- ;;
- ;; CASE 3: Symbol text merge
- ;;
- ;; #define TMP(a) foo_ ## a
- ;; ==>
- ;; ((spp-arg-list ("a") 20 . 23)
- ;; (spp-symbol-merge ((symbol "foo_" 24 . 28) (symbol "a" 32 . 33))
- ;; 24 . 33))
- ;;
- ;; Usually in conjunction with a macro with an argument, merging symbol
- ;; parts is a way of fabricating new symbols from pieces inside the macro.
- ;; These macros use `spp-symbol-merge' tokens whose TEXT part is another
- ;; token stream. This sub-stream ought to consist of only 2 SYMBOL pieces,
- ;; though I suppose keywords might be ok. The end result of this example
- ;; merge symbol would be (symbol "foo_A" 24 . 33) where A is the symbol
- ;; passed in from the arg list "a".
- ;;
- ;; CASE 4: Nested token streams
- ;;
- ;; #define FOO(f) f
- ;; #define BLA bla FOO(foo)
- ;; ==>
- ;; ((INT "int" 82 . 85)
- ;; (symbol "FOO" 86 . 89)
- ;; (semantic-list "(foo)" 89 . 94))
- ;;
- ;; Nested token FOO shows up in the table of macros, and gets replace
- ;; inline. This is the same as case 2.
- ;;
- ;; CASE 5: Macros which open a scope without closing it
- ;;
- ;; #define __NAMESPACE_STD namespace std {
- ;; #define __NAMESPACE_END }
- ;; ==>
- ;; ((NAMESPACE "namespace" 140 . 149)
- ;; (symbol "std" 150 . 153)
- ;; (open-paren "{" 154 . 155))
- ;;
- ;; Note that we get a single 'open-paren' instead of a
- ;; 'semantic-list', which is because we use
- ;; 'semantic-lex-spp-paren-or-list' instead of
- ;; 'semantic-lex-paren-or-list' in our spp-lexer. To keep things
- ;; reasonably simple, we assume that such an open scope will always
- ;; be closed by another macro (see
- ;; `semantic-lex-spp-find-closing-macro'). We generate a
- ;; 'semantic-list' to this closing macro, and we leave an overlay
- ;; which contains information how far we got into the macro's
- ;; stream (since it might open several scopes).
-
- (let* ((arglist (semantic-lex-spp-macro-with-args val))
- (argalist nil)
- (val-tmp nil)
- (v nil)
- (sppov (semantic-lex-spp-get-overlay beg))
- (sppinfo (when sppov (overlay-get sppov 'semantic-spp))))
-
- ;; First, check if we were already here and left information
- (when sppinfo
- ;; Advance in the tokens as far as we got last time
- (when (numberp (car sppinfo))
- (while (and val
- (>= (car sppinfo) (car (last (car val)))))
- (setq val (cdr val))))
- ;; And push an open paren
- (semantic-lex-push-token
- (semantic-lex-token 'open-paren beg (1+ beg) "{"))
- (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
- (unless val
- ;; We reached the end of this macro, so delete overlay
- (delete-overlay sppov)))
-
- ;; CASE 2: Dealing with the arg list.
- (when (and val arglist)
- ;; Skip the arg list.
- (when (eq (caar val) 'spp-arg-list)
- (setq val (cdr val)))
-
- ;; Push args into the replacement list.
- (let ((AV argvalues))
- (dolist (A arglist)
- (let* ((argval (car AV)))
-
- (semantic-lex-spp-symbol-push A argval)
- (setq argalist (cons (cons A argval) argalist))
- (setq AV (cdr AV)))))
- )
-
- ;; Set val-tmp after stripping arguments.
- (setq val-tmp val)
-
- ;; CASE 1: Push everything else onto the list.
- ;; Once the arg list is stripped off, CASE 2 is the same
- ;; as CASE 1.
- (while val-tmp
- (setq v (car val-tmp))
- (setq val-tmp (cdr val-tmp))
-
- (let* (;; The text of the current lexical token.
- (txt (car (cdr v)))
- ;; Try to convert txt into a macro declaration. If it is
- ;; not a macro, use nil.
- (txt-macro-or-nil (semantic-lex-spp-symbol txt))
- ;; If our current token is a macro, then pull off the argument
- ;; list.
- (macro-and-args
- (when txt-macro-or-nil
- (semantic-lex-spp-macro-with-args (symbol-value txt-macro-or-nil)))
- )
- ;; We need to peek at the next token when testing for
- ;; used macros with arg lists.
- (next-tok-class (semantic-lex-token-class (car val-tmp)))
- )
-
- (cond
- ;; CASE 3: Merge symbols together.
- ((eq (semantic-lex-token-class v) 'spp-symbol-merge)
- (let ((newsym (semantic-lex-spp-symbol-merge txt)))
- (semantic-lex-push-token
- (semantic-lex-token 'symbol beg end newsym))
- ))
-
- ;; CASE 2: Argument replacement. If a discovered symbol is in
- ;; the active list of arguments, then we need to substitute
- ;; in the new value.
- ((and (eq (semantic-lex-token-class v) 'symbol) txt-macro-or-nil
- (or (and macro-and-args (eq next-tok-class 'semantic-list))
- (not macro-and-args))
- )
- (let ((AV nil))
- (when macro-and-args
- (setq AV
- (semantic-lex-spp-stream-for-arglist (car val-tmp)))
- ;; We used up these args. Pull from the stream.
- (setq val-tmp (cdr val-tmp))
- )
-
- (semantic-lex-with-macro-used txt
- ;; Don't recurse directly into this same fcn, because it is
- ;; convenient to have plain string replacements too.
- (semantic-lex-spp-macro-to-macro-stream
- (symbol-value txt-macro-or-nil)
- beg end AV))
- ))
-
- ;; This is a HACK for the C parser. The 'macros text
- ;; property is some storage so that the parser can do
- ;; some C specific text manipulations.
- ((eq (semantic-lex-token-class v) 'semantic-list)
- ;; Push our arg list onto the semantic list.
- (when argalist
- (setq txt (concat txt)) ; Copy the text.
- (put-text-property 0 1 'macros argalist txt))
- (semantic-lex-push-token
- (semantic-lex-token (semantic-lex-token-class v) beg end txt))
- )
- ;; CASE 5: Macro which opens a scope
- ((eq (semantic-lex-token-class v) 'open-paren)
- ;; We assume that the scope will be closed by another macro.
- ;; (Everything else would be a terrible idea anyway.)
- (let* ((endpoint (semantic-lex-spp-find-closing-macro))
- (ov (when endpoint
- (or sppov
- (make-overlay beg end)))))
- (when ov
- ;; Generate a semantic-list which spans to the end of
- ;; the closing macro
- (semantic-lex-push-token
- (semantic-lex-token 'semantic-list beg endpoint))
- ;; The rest of the current macro's stream will be parsed
- ;; next time.
- (setq val-tmp nil)
- ;; Store our current state were we are in the macro and
- ;; the endpoint.
- (overlay-put ov 'semantic-spp
- (cons (car (last v)) endpoint)))))
- ((eq (semantic-lex-token-class v) 'close-paren)
- ;; Macro which closes a scope
- ;; Just push the close paren, but also decrease depth
- (semantic-lex-push-token
- (semantic-lex-token 'close-paren beg end txt))
- (setq semantic-lex-current-depth (1- semantic-lex-current-depth)))
- ;; CASE 1: Just another token in the stream.
- (t
- ;; Nothing new.
- (semantic-lex-push-token
- (semantic-lex-token (semantic-lex-token-class v) beg end txt))
- )
- )))
-
- ;; CASE 2: The arg list we pushed onto the symbol table
- ;; must now be removed.
- (dolist (A arglist)
- (semantic-lex-spp-symbol-pop A))
- ))
-
-(defun semantic-lex-spp-symbol-merge (txt)
- "Merge the tokens listed in TXT.
-TXT might contain further `spp-symbol-merge', which will
-be merged recursively."
- ;; We need to merge the tokens in the 'text segment together,
- ;; and produce a single symbol from it.
- (mapconcat (lambda (tok)
- (cond
- ((eq (car tok) 'symbol)
- (semantic-lex-spp-one-token-to-txt tok))
- ((eq (car tok) 'spp-symbol-merge)
- ;; Call recursively for multiple merges, like
- ;; #define FOO(a) foo##a##bar
- (semantic-lex-spp-symbol-merge (cadr tok)))
- (t
- (message "Invalid merge macro encountered; \
-will return empty string instead.")
- "")))
- txt))
-
-(defun semantic-lex-spp-find-closing-macro ()
- "Find next macro which closes a scope through a close-paren.
-Returns position with the end of that macro."
- (let ((macros (semantic-lex-spp-macros))
- (cmacro-regexp "\\(")
- (case-fold-search nil))
- ;; Build a regexp which search for all macros with a closing
- ;; paren, and search for it.
- (dolist (cur macros)
- (let ((stream (symbol-value cur)))
- (when (and (listp stream) (listp (car stream)))
- (while stream
- (if (and (eq (caar stream) 'close-paren)
- (string= (nth 1 (car stream)) "}"))
- (setq cmacro-regexp (concat cmacro-regexp (symbol-name cur) "\\|")
- stream nil)
- (setq stream (cdr-safe stream)))))))
- (when cmacro-regexp
- (save-excursion
- (when (re-search-forward
- (concat (substring cmacro-regexp 0 -2) "\\)[^0-9a-zA-Z_]") nil t)
- (point))))))
-
-(defun semantic-lex-spp-get-overlay (&optional point)
- "Return first overlay which has a `semantic-spp' property."
- (let ((overlays (overlays-at (or point (point)))))
- (while (and overlays
- (null (overlay-get (car overlays) 'semantic-spp)))
- (setq overlays (cdr overlays)))
- (car-safe overlays)))
-
-;;; Macro Merging
-;;
-;; Used when token streams from different macros include each other.
-;; Merged macro streams perform in place replacements.
-
-(defun semantic-lex-spp-merge-streams (raw-stream)
- "Merge elements from the RAW-STREAM together.
-Handle spp-concat symbol concatenation.
-Handle Nested macro replacements.
-Return the cooked stream."
- (let ((cooked-stream nil))
- ;; Merge the stream
- (while raw-stream
- (cond ((eq (semantic-lex-token-class (car raw-stream)) 'spp-concat)
- ;; handle hashhash, by skipping it.
- (setq raw-stream (cdr raw-stream))
- ;; Now merge the symbols.
- (let ((prev-tok (car cooked-stream))
- (next-tok (car raw-stream)))
- (setq cooked-stream (cdr cooked-stream))
- (push (semantic-lex-token
- 'spp-symbol-merge
- (semantic-lex-token-start prev-tok)
- (semantic-lex-token-end next-tok)
- (list prev-tok next-tok))
- cooked-stream)
- ))
- (t
- (push (car raw-stream) cooked-stream))
- )
- (setq raw-stream (cdr raw-stream))
- )
-
- (nreverse cooked-stream))
- )
-
-;;; MACRO EXPANSION
-;;
-;; There are two types of expansion.
-;;
-;; 1. Expansion using a value made up of lexical tokens.
-;; 2. User input replacement from a plain string.
-
-(defun semantic-lex-spp-macro-to-macro-stream (val beg end argvalues)
- "Convert lexical macro contents VAL into a macro expansion stream.
-Argument VAL is the value of some macro to be converted into a stream.
-BEG and END are the token bounds of the macro to be expanded
-that will somehow gain a much longer token stream.
-ARGVALUES are values for any arg list, or nil."
- (cond
- ;; If val is nil, then just skip it.
- ((null val) t)
- ;; If it is a token, then return that token rebuilt.
- ((and (consp val) (car val) (symbolp (car val)))
- (semantic-lex-push-token
- (semantic-lex-token (car val) beg end (semantic-lex-token-text val))))
- ;; Test for a token list.
- ((and (consp val) (consp (car val)) (car (car val))
- (symbolp (car (car val))))
- (semantic-lex-spp-token-macro-to-macro-stream val beg end argvalues))
- ;; Test for miscellaneous strings.
- ((stringp val)
- (semantic-lex-spp-simple-macro-to-macro-stream val beg end argvalues))
- ))
-
-;;; --------------------------------------------------------
-;;;
-;;; ANALYZERS:
-;;;
-
-;;; Symbol Is Macro
-;;
-;; An analyzer that will push tokens from a macro in place
-;; of the macro symbol.
-;;
-(defun semantic-lex-spp-analyzer-do-replace (_sym val beg end)
- "Do the lexical replacement for SYM with VAL.
-Argument BEG and END specify the bounds of SYM in the buffer."
- (if (not val)
- (setq semantic-lex-end-point end)
- (let ((arg-in nil)
- (arg-parsed nil)
- (arg-split nil)
- )
-
- ;; Check for arguments.
- (setq arg-in (semantic-lex-spp-macro-with-args val))
-
- (when arg-in
- (save-excursion
- (goto-char end)
- (setq arg-parsed
- (semantic-lex-spp-one-token-and-move-for-macro
- ;; NOTE: This used to be (line-end-position), but
- ;; that was too close for multi-line arguments
- ;; to a macro. Point max may be too far if there
- ;; is a typo in the buffer.
- ;;
- ;; Look here for performance issues while a user is typing
- ;; incomplete code.
- (point-max)))
- (setq end (semantic-lex-token-end arg-parsed))
-
- (when (and (listp arg-parsed) (eq (car arg-parsed) 'semantic-list))
- (setq arg-split
- ;; Use lex to split up the contents of the argument list.
- (semantic-lex-spp-stream-for-arglist arg-parsed)
- ))
- ))
-
- ;; if we have something to sub in, then do it.
- (semantic-lex-spp-macro-to-macro-stream val beg end arg-split)
- (setq semantic-lex-end-point end)
- )
- ))
-(define-obsolete-function-alias
- 'semantic-lex-spp-anlyzer-do-replace
- #'semantic-lex-spp-analyzer-do-replace "25.1")
-
-(defvar semantic-lex-spp-replacements-enabled t
- "Non-nil means do replacements when finding keywords.
-Disable this only to prevent recursive expansion issues.")
-
-(defun semantic-lex-spp-analyzer-push-tokens-for-symbol (str beg end)
- "Push lexical tokens for the symbol or keyword STR.
-STR occurs in the current buffer between BEG and END."
- (let (sym val count)
- (cond
- ;;
- ;; It is a macro. Prepare for a replacement.
- ((and semantic-lex-spp-replacements-enabled
- (semantic-lex-spp-symbol-p str))
- (setq sym (semantic-lex-spp-symbol str)
- val (symbol-value sym)
- count 0)
-
- (let ((semantic-lex-spp-expanded-macro-stack
- semantic-lex-spp-expanded-macro-stack))
-
- (semantic-lex-with-macro-used str
- ;; Do direct replacements of single value macros of macros.
- ;; This solves issues with a macro containing one symbol that
- ;; is another macro, and get arg lists passed around.
- (while (and val (consp val)
- (semantic-lex-token-p (car val))
- (eq (length val) 1)
- (eq (semantic-lex-token-class (car val)) 'symbol)
- (semantic-lex-spp-symbol-p (semantic-lex-token-text (car val)))
- (< count 10)
- )
- (setq str (semantic-lex-token-text (car val)))
- (setq sym (semantic-lex-spp-symbol str)
- val (symbol-value sym))
- ;; Prevent recursion
- (setq count (1+ count))
- ;; This prevents a different kind of recursion.
- (push str semantic-lex-spp-expanded-macro-stack)
- )
-
- (semantic-lex-spp-analyzer-do-replace sym val beg end))
-
- ))
- ;; Anything else.
- (t
- ;; A regular keyword.
- (semantic-lex-push-token
- (semantic-lex-token (or (semantic-lex-keyword-p str) 'symbol)
- beg end))))
- ))
-
-(define-lex-regex-analyzer semantic-lex-spp-replace-or-symbol-or-keyword
- "Like `semantic-lex-symbol-or-keyword' plus preprocessor macro replacement."
- "\\(\\sw\\|\\s_\\)+"
- (let ((str (match-string 0))
- (beg (match-beginning 0))
- (end (match-end 0))
- sppov)
- (semantic-lex-spp-analyzer-push-tokens-for-symbol str beg end)
- (when (setq sppov (semantic-lex-spp-get-overlay beg))
- (setq semantic-lex-end-point (cdr (overlay-get sppov 'semantic-spp))))))
-
-(define-lex-regex-analyzer semantic-lex-spp-paren-or-list
- "Detect open parenthesis.
-Contrary to `semantic-lex-paren-or-list', this will push a single
-open-paren onto the stream if no closing paren can be found.
-This is important for macros which open a scope which is closed
-by another macro."
- "\\s("
- (if (or (not semantic-lex-maximum-depth)
- (< semantic-lex-current-depth semantic-lex-maximum-depth))
- (progn
- (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
- (semantic-lex-push-token
- (semantic-lex-token
- 'open-paren (match-beginning 0) (match-end 0))))
- (save-excursion
- (let ((start (match-beginning 0))
- (end (match-end 0))
- (peom (save-excursion (c-end-of-macro) (point))))
- (condition-case nil
- (progn
- ;; This will throw an error if no closing paren can be found.
- (forward-list 1)
- (when (> (point) peom)
- ;; If we have left the macro, this is the wrong closing
- ;; paren, so error out as well.
- (error ""))
- (semantic-lex-push-token
- (semantic-lex-token
- 'semantic-list start (point))))
- (error
- ;; Only push a single open-paren.
- (semantic-lex-push-token
- (semantic-lex-token
- 'open-paren start end))))))))
-
-;;; ANALYZERS FOR NEW MACROS
-;;
-;; These utilities and analyzer declaration function are for
-;; creating an analyzer which produces new macros in the macro table.
-;;
-;; There are two analyzers. One for new macros, and one for removing
-;; a macro.
-
-(defun semantic-lex-spp-first-token-arg-list (token)
- "If TOKEN is a semantic-list, turn it into an SPP ARG LIST."
- (when (and (consp token)
- (symbolp (car token))
- (eq 'semantic-list (car token)))
- ;; Convert TOKEN in place.
- (let ((argsplit (split-string (semantic-lex-token-text token)
- "[(), ]" t)))
- (setcar token 'spp-arg-list)
- (setcar (nthcdr 1 token) argsplit))
- ))
-
-(defun semantic-lex-spp-one-token-and-move-for-macro (max)
- "Lex up one token, and move to end of that token.
-Don't go past MAX."
- (let ((ans (semantic-lex (point) max 0 0)))
- (if (not ans)
- (progn (goto-char max)
- nil)
- (when (> (semantic-lex-token-end (car ans)) max)
- (let ((bounds (semantic-lex-token-bounds (car ans))))
- (setcdr bounds max)))
- (goto-char (semantic-lex-token-end (car ans)))
- (car ans))
- ))
-
-(defun semantic-lex-spp-stream-for-arglist (token)
- "Lex up the contents of the arglist TOKEN.
-Parsing starts inside the parens, and ends at the end of TOKEN."
- (let ((end (semantic-lex-token-end token))
- (fresh-toks nil)
- (toks nil))
- (save-excursion
-
- (if (stringp (nth 1 token))
- ;; If the 2nd part of the token is a string, then we have
- ;; a token specifically extracted from a buffer. Possibly
- ;; a different buffer. This means we need to do something
- ;; nice to parse its contents.
- (let ((txt (semantic-lex-token-text token)))
- (semantic-lex-spp-lex-text-string
- (substring txt 1 (1- (length txt)))))
-
- ;; This part is like the original
- (goto-char (semantic-lex-token-start token))
- ;; A cheat for going into the semantic list.
- (forward-char 1)
- (setq fresh-toks (semantic-lex-spp-stream-for-macro (1- end)))
- (dolist (tok fresh-toks)
- ;; march 2011: This is too restrictive! For example "void"
- ;; can't get through. What elements was I trying to expunge
- ;; to put this in here in the first place? If I comment it
- ;; out, does anything new break?
- ;(when (memq (semantic-lex-token-class tok) '(symbol semantic-list))
- ;; It appears the commas need to be dumped. perhaps this is better,
- ;; but will it cause more problems later?
- (unless (eq (semantic-lex-token-class tok) 'punctuation)
- (setq toks (cons tok toks))))
-
- (nreverse toks)))))
-
-(defvar semantic-lex-spp-hack-depth 0
- "Current depth of recursive calls to `semantic-lex-spp-lex-text-string'.")
-
-(defun semantic-lex-spp-lex-text-string (text)
- "Lex the text string TEXT using the current buffer's state.
-Use this to parse text extracted from a macro as if it came from
-the current buffer. Since the lexer is designed to only work in
-a buffer, we need to create a new buffer, and populate it with rules
-and variable state from the current buffer."
- (let* ((semantic-lex-spp-hack-depth (1+ semantic-lex-spp-hack-depth))
- (buf (get-buffer-create (format " *SPP parse hack %d*"
- semantic-lex-spp-hack-depth)))
- (mode major-mode)
- (fresh-toks nil)
- (toks nil)
- (origbuff (current-buffer))
- ;; (analyzer semantic-lex-analyzer)
- (important-vars '(semantic-lex-spp-macro-symbol-obarray
- semantic-lex-spp-project-macro-symbol-obarray
- semantic-lex-spp-dynamic-macro-symbol-obarray
- semantic-lex-spp-dynamic-macro-symbol-obarray-stack
- semantic-lex-spp-expanded-macro-stack
- ))
- )
- (if (> semantic-lex-spp-hack-depth 5)
- nil
- (with-current-buffer buf
- (erase-buffer)
- ;; Below is a painful hack to make sure everything is setup correctly.
- (when (not (eq major-mode mode))
- (save-match-data
-
- ;; Protect against user-hooks that throw errors.
- (condition-case nil
- (funcall mode)
- (error nil))
-
- ;; Hack in mode-local
- (mode-local--activate-bindings)
-
- ;; Call the major mode's setup function
- (let ((entry (assq major-mode semantic-new-buffer-setup-functions)))
- (when entry
- (funcall (cdr entry))))
-
- ;; 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-functions
- #'semantic-lex-spp-reset-hook t)
- ))
-
- ;; Second Cheat: copy key variables regarding macro state from the
- ;; originating buffer we are parsing. We need to do this every time
- ;; since the state changes.
- (dolist (V important-vars)
- (set V (buffer-local-value V origbuff)))
- (insert text)
- (goto-char (point-min))
-
- (setq fresh-toks (semantic-lex-spp-stream-for-macro (point-max))))
-
- (dolist (tok fresh-toks)
- (when (memq (semantic-lex-token-class tok) '(symbol semantic-list))
- (setq toks (cons tok toks)))))
-
- (nreverse toks)))
-
-;;;; FIRST DRAFT
-;; This is the fist version of semantic-lex-spp-stream-for-arglist
-;; that worked pretty well. It doesn't work if the TOKEN was derived
-;; from some other buffer, in which case it can get the wrong answer
-;; or throw an error if the token location in the originating buffer is
-;; larger than the current buffer.
-;;(defun semantic-lex-spp-stream-for-arglist-orig (token)
-;; "Lex up the contents of the arglist TOKEN.
-;; Parsing starts inside the parens, and ends at the end of TOKEN."
-;; (save-excursion
-;; (let ((end (semantic-lex-token-end token))
-;; (fresh-toks nil)
-;; (toks nil))
-;; (goto-char (semantic-lex-token-start token))
-;; ;; A cheat for going into the semantic list.
-;; (forward-char 1)
-;; (setq fresh-toks (semantic-lex-spp-stream-for-macro (1- end)))
-;; (dolist (tok fresh-toks)
-;; (when (memq (semantic-lex-token-class tok) '(symbol semantic-list))
-;; (setq toks (cons tok toks))))
-;; (nreverse toks))
-;; ))
-
-;;;; USING SPLIT
-;; This doesn't work, because some arguments passed into a macro
-;; might contain non-simple symbol words, which this doesn't handle.
-;;
-;; Thus, you need a full lex to occur.
-;; (defun semantic-lex-spp-stream-for-arglist-split (token)
-;; "Lex up the contents of the arglist TOKEN.
-;; Parsing starts inside the parens, and ends at the end of TOKEN."
-;; (let* ((txt (semantic-lex-token-text token))
-;; (split (split-string (substring txt 1 (1- (length txt)))
-;; "(), " t))
-;; ;; Hack for lexing.
-;; (semantic-lex-spp-analyzer-push-tokens-for-symbol nil))
-;; (dolist (S split)
-;; (semantic-lex-spp-analyzer-push-tokens-for-symbol S 0 1))
-;; (reverse semantic-lex-spp-analyzer-push-tokens-for-symbol)))
-
-
-(defun semantic-lex-spp-stream-for-macro (eos)
- "Lex up a stream of tokens for a #define statement.
-Parsing starts at the current point location.
-EOS is the end of the stream to lex for this macro."
- (let ((stream nil))
- (while (< (point) eos)
- (let* ((tok (semantic-lex-spp-one-token-and-move-for-macro eos))
- (str (when tok
- (semantic-lex-token-text tok)))
- )
- (if str
- (push (semantic-lex-token (semantic-lex-token-class tok)
- (semantic-lex-token-start tok)
- (semantic-lex-token-end tok)
- str)
- stream)
- ;; Nothing to push.
- nil)))
- (goto-char eos)
- ;; Fix the order
- (nreverse stream)
- ))
-
-(defmacro define-lex-spp-macro-declaration-analyzer (name doc regexp tokidx
- &rest valform)
- "Define a lexical analyzer for defining new MACROS.
-NAME is the name of the analyzer.
-DOC is the documentation for the analyzer.
-REGEXP is a regular expression for the analyzer to match.
-See `define-lex-regex-analyzer' for more on regexp.
-TOKIDX is an index into REGEXP for which a new lexical token
-of type `spp-macro-def' is to be created.
-VALFORM are forms that return the value to be saved for this macro, or nil.
-When implementing a macro, you can use `semantic-lex-spp-stream-for-macro'
-to convert text into a lexical stream for storage in the macro."
- (declare (debug (&define name stringp stringp form def-body))
- (indent 1))
- (let ((start (make-symbol "start"))
- (end (make-symbol "end"))
- (val (make-symbol "val"))
- (startpnt (make-symbol "startpnt"))
- (endpnt (make-symbol "endpnt")))
- `(define-lex-regex-analyzer ,name
- ,doc
- ,regexp
- (let ((,start (match-beginning ,tokidx))
- (,end (match-end ,tokidx))
- (,startpnt semantic-lex-end-point)
- (,val (save-match-data ,@valform))
- (,endpnt semantic-lex-end-point))
- (semantic-lex-spp-symbol-set
- (buffer-substring-no-properties ,start ,end)
- ,val)
- (semantic-lex-push-token
- (semantic-lex-token 'spp-macro-def
- ,start ,end))
- ;; Preserve setting of the end point from the calling macro.
- (when (and (/= ,startpnt ,endpnt)
- (/= ,endpnt semantic-lex-end-point))
- (setq semantic-lex-end-point ,endpnt))
- ))))
-
-(defmacro define-lex-spp-macro-undeclaration-analyzer (name doc regexp tokidx)
- "Undefine a lexical analyzer for defining new MACROS.
-NAME is the name of the analyzer.
-DOC is the documentation for the analyzer.
-REGEXP is a regular expression for the analyzer to match.
-See `define-lex-regex-analyzer' for more on regexp.
-TOKIDX is an index into REGEXP for which a new lexical token
-of type `spp-macro-undef' is to be created."
- (declare (debug (&define name stringp stringp form))
- (indent 1))
- (let ((start (make-symbol "start"))
- (end (make-symbol "end")))
- `(define-lex-regex-analyzer ,name
- ,doc
- ,regexp
- (let ((,start (match-beginning ,tokidx))
- (,end (match-end ,tokidx))
- )
- (semantic-lex-spp-symbol-remove
- (buffer-substring-no-properties ,start ,end))
- (semantic-lex-push-token
- (semantic-lex-token 'spp-macro-undef
- ,start ,end))
- ))))
-
-;;; INCLUDES
-;;
-;; These analyzers help a language define how include files
-;; are identified. These are ONLY for languages that perform
-;; an actual textual inclusion, and not for imports.
-;;
-;; This section is supposed to allow the macros from the headers to be
-;; added to the local dynamic macro table, but that hasn't been
-;; written yet.
-;;
-(defcustom semantic-lex-spp-use-headers-flag nil
- "Non-nil means to pre-parse headers as we go.
-For languages that use the Semantic pre-processor, this can
-improve the accuracy of parsed files where include files
-can change the state of what's parsed in the current file.
-
-Note: Not implemented yet."
- :group 'semantic
- :type 'boolean)
-
-(defun semantic-lex-spp-merge-header (_name)
- "Extract and merge any macros from the header with NAME.
-Finds the header file belonging to NAME, gets the macros
-from that file, and then merge the macros with our current
-symbol table."
- (when semantic-lex-spp-use-headers-flag
- nil ; @todo - do this someday, ok?
- ))
-
-(defmacro define-lex-spp-include-analyzer (name doc regexp tokidx
- &rest valform)
- "Define a lexical analyzer for defining a new INCLUDE lexical token.
-Macros defined in the found include will be added to our running table
-at the time the include statement is found.
-NAME is the name of the analyzer.
-DOC is the documentation for the analyzer.
-REGEXP is a regular expression for the analyzer to match.
-See `define-lex-regex-analyzer' for more on regexp.
-TOKIDX is an index into REGEXP for which a new lexical token
-of type `spp-system-include' is to be created.
-VALFORM are forms that return the name of the thing being included, and the
-type of include. The return value should be of the form:
- (NAME . TYPE)
-where NAME is the name of the include, and TYPE is the type of the include,
-where a valid symbol is `system', or nil."
- (declare (debug (&define name stringp stringp form def-body))
- (indent 1))
- (let ((start (make-symbol "start"))
- (end (make-symbol "end"))
- (val (make-symbol "val"))
- (startpnt (make-symbol "startpnt"))
- (endpnt (make-symbol "endpnt")))
- `(define-lex-regex-analyzer ,name
- ,doc
- ,regexp
- (let ((,start (match-beginning ,tokidx))
- (,end (match-end ,tokidx))
- (,startpnt semantic-lex-end-point)
- (,val (save-match-data ,@valform))
- (,endpnt semantic-lex-end-point))
- ;;(message "(car ,val) -> %S" (car ,val))
- (semantic-lex-spp-merge-header (car ,val))
- (semantic-lex-push-token
- (semantic-lex-token (if (eq (cdr ,val) 'system)
- 'spp-system-include
- 'spp-include)
- ,start ,end
- (car ,val)))
- ;; Preserve setting of the end point from the calling macro.
- (when (and (/= ,startpnt ,endpnt)
- (/= ,endpnt semantic-lex-end-point))
- (setq semantic-lex-end-point ,endpnt))
- ))))
-
-;;; EIEIO USAGE
-;;
-;; Semanticdb can save off macro tables for quick lookup later.
-;;
-;; These routines are for saving macro lists into an EIEIO persistent
-;; file.
-(defcustom semantic-lex-spp-macro-max-length-to-save 200
- "Maximum length of an SPP macro before we opt to not save it."
- :type 'integer
- :group 'semantic)
-
-;;;###autoload
-(defun semantic-lex-spp-table-write-slot-value (value)
- "Write out the VALUE of a slot for EIEIO.
-The VALUE is a spp lexical table."
- (if (not value)
- (princ "nil")
- (princ "\n '(")
- ;(princ value)
- (dolist (sym value)
- (princ "(")
- (prin1 (car sym))
- (let* ((first (car (cdr sym)))
- (rest (cdr sym)))
- (if (not (listp first))
- (insert "nil ;; bogus macro found.\n")
- (when (eq (car first) 'spp-arg-list)
- (princ " ")
- (prin1 first)
- (setq rest (cdr rest)))
-
- (when rest
- (princ " . ")
- (let ((len (length (cdr rest))))
- (cond ((< len 2)
- (condition-case nil
- (prin1 rest)
- (error
- (princ "nil ;; Error writing macro\n"))))
- ((< len semantic-lex-spp-macro-max-length-to-save)
- (princ "\n ")
- (condition-case nil
- (prin1 rest)
- (error
- (princ "nil ;; Error writing macro\n "))))
- (t ;; Too Long!
- (princ "nil ;; Too Long!\n ")))))))
- (princ ")\n "))
- (princ ")\n")))
-
-;;; MACRO TABLE DEBUG
-;;
-(defun semantic-lex-spp-describe (&optional buffer)
- "Describe the current list of spp macros for BUFFER.
-If BUFFER is not provided, use the current buffer."
- (interactive)
- (let ((syms (save-excursion
- (if buffer (set-buffer buffer))
- (semantic-lex-spp-macros)))
- (sym nil))
- (with-output-to-temp-buffer "*SPP MACROS*"
- (princ "Macro\t\tValue\n")
- (while syms
- (setq sym (car syms)
- syms (cdr syms))
- (princ (symbol-name sym))
- (princ "\t")
- (if (< (length (symbol-name sym)) 8)
- (princ "\t"))
- (prin1 (symbol-value sym))
- (princ "\n")
- ))))
-
-(provide 'semantic/lex-spp)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/lex-spp"
-;; End:
-
-;;; semantic/lex-spp.el ends here
+++ /dev/null
-;;; semantic/lex.el --- Lexical Analyzer builder -*- lexical-binding:t -*-
-
-;; Copyright (C) 1999-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This file handles the creation of lexical analyzers for different
-;; languages in Emacs Lisp. The purpose of a lexical analyzer is to
-;; convert a buffer into a list of lexical tokens. Each token
-;; contains the token class (such as 'number, 'symbol, 'IF, etc) and
-;; the location in the buffer it was found. Optionally, a token also
-;; contains a string representing what is at the designated buffer
-;; location.
-;;
-;; Tokens are pushed onto a token stream, which is basically a list of
-;; all the lexical tokens from the analyzed region. The token stream
-;; is then handed to the grammar which parsers the file.
-;;
-;;; How it works
-;;
-;; Each analyzer specifies a condition and forms. These conditions
-;; and forms are assembled into a function by `define-lex' that does
-;; the lexical analysis.
-;;
-;; In the lexical analyzer created with `define-lex', each condition
-;; is tested for a given point. When the condition is true, the forms
-;; run.
-;;
-;; The forms can push a lexical token onto the token stream. The
-;; analyzer forms also must move the current analyzer point. If the
-;; analyzer point is moved without pushing a token, then the matched
-;; syntax is effectively ignored, or skipped.
-;;
-;; Thus, starting at the beginning of a region to be analyzed, each
-;; condition is tested. One will match, and a lexical token might be
-;; pushed, and the point is moved to the end of the lexical token
-;; identified. At the new position, the process occurs again until
-;; the end of the specified region is reached.
-;;
-;;; How to use semantic-lex
-;;
-;; To create a lexer for a language, use the `define-lex' macro.
-;;
-;; The `define-lex' macro accepts a list of lexical analyzers. Each
-;; analyzer is created with `define-lex-analyzer', or one of the
-;; derivative macros. A single analyzer defines a regular expression
-;; to match text in a buffer, and a short segment of code to create
-;; one lexical token.
-;;
-;; Each analyzer has a NAME, DOC, a CONDITION, and possibly some
-;; FORMS. The NAME is the name used in `define-lex'. The DOC
-;; describes what the analyzer should do.
-;;
-;; The CONDITION evaluates the text at the current point in the
-;; current buffer. If CONDITION is true, then the FORMS will be
-;; executed.
-;;
-;; The purpose of the FORMS is to push new lexical tokens onto the
-;; list of tokens for the current buffer, and to move point after the
-;; matched text.
-;;
-;; Some macros for creating one analyzer are:
-;;
-;; define-lex-analyzer - A generic analyzer associating any style of
-;; condition to forms.
-;; define-lex-regex-analyzer - Matches a regular expression.
-;; define-lex-simple-regex-analyzer - Matches a regular expressions,
-;; and pushes the match.
-;; define-lex-block-analyzer - Matches list syntax, and defines
-;; handles open/close delimiters.
-;;
-;; These macros are used by the grammar compiler when lexical
-;; information is specified in a grammar:
-;; define-lex- * -type-analyzer - Matches syntax specified in
-;; a grammar, and pushes one token for it. The * would
-;; be `sexp' for things like lists or strings, and
-;; `string' for things that need to match some special
-;; string, such as "\\." where a literal match is needed.
-;;
-;;; Lexical Tables
-;;
-;; There are tables of different symbols managed in semantic-lex.el.
-;; They are:
-;;
-;; Lexical keyword table - A Table of symbols declared in a grammar
-;; file with the %keyword declaration.
-;; Keywords are used by `semantic-lex-symbol-or-keyword'
-;; to create lexical tokens based on the keyword.
-;;
-;; Lexical type table - A table of symbols declared in a grammar
-;; file with the %type declaration.
-;; The grammar compiler uses the type table to create new
-;; lexical analyzers. These analyzers are then used to when
-;; a new lexical analyzer is made for a language.
-;;
-;;; Lexical Types
-;;
-;; A lexical type defines a kind of lexical analyzer that will be
-;; automatically generated from a grammar file based on some
-;; predetermined attributes. For now these two attributes are
-;; recognized :
-;;
-;; * matchdatatype : define the kind of lexical analyzer. That is :
-;;
-;; - regexp : define a regexp analyzer (see
-;; `define-lex-regex-type-analyzer')
-;;
-;; - string : define a string analyzer (see
-;; `define-lex-string-type-analyzer')
-;;
-;; - block : define a block type analyzer (see
-;; `define-lex-block-type-analyzer')
-;;
-;; - sexp : define a sexp analyzer (see
-;; `define-lex-sexp-type-analyzer')
-;;
-;; - keyword : define a keyword analyzer (see
-;; `define-lex-keyword-type-analyzer')
-;;
-;; * syntax : define the syntax that matches a syntactic
-;; expression. When syntax is matched the corresponding type
-;; analyzer is entered and the resulting match data will be
-;; interpreted based on the kind of analyzer (see matchdatatype
-;; above).
-;;
-;; The following lexical types are predefined :
-;;
-;; +-------------+---------------+--------------------------------+
-;; | type | matchdatatype | syntax |
-;; +-------------+---------------+--------------------------------+
-;; | punctuation | string | "\\(\\s.\\|\\s$\\|\\s'\\)+" |
-;; | keyword | keyword | "\\(\\sw\\|\\s_\\)+" |
-;; | symbol | regexp | "\\(\\sw\\|\\s_\\)+" |
-;; | string | sexp | "\\s\"" |
-;; | number | regexp | semantic-lex-number-expression |
-;; | block | block | "\\s(\\|\\s)" |
-;; +-------------+---------------+--------------------------------+
-;;
-;; In a grammar you must use a %type expression to automatically generate
-;; the corresponding analyzers of that type.
-;;
-;; Here is an example to auto-generate punctuation analyzers
-;; with 'matchdatatype and 'syntax predefined (see table above)
-;;
-;; %type <punctuation> ;; will auto-generate this kind of analyzers
-;;
-;; It is equivalent to write :
-;;
-;; %type <punctuation> syntax "\\(\\s.\\|\\s$\\|\\s'\\)+" matchdatatype string
-;;
-;; ;; Some punctuation based on the type defines above
-;;
-;; %token <punctuation> NOT "!"
-;; %token <punctuation> NOTEQ "!="
-;; %token <punctuation> MOD "%"
-;; %token <punctuation> MODEQ "%="
-;;
-
-;;; On the Semantic 1.x lexer
-;;
-;; In semantic 1.x, the lexical analyzer was an all purpose routine.
-;; To boost efficiency, the analyzer is now a series of routines that
-;; are constructed at build time into a single routine. This will
-;; eliminate unneeded if statements to speed the lexer.
-
-(require 'semantic/fw)
-
-;;; Code:
-
-;;; Semantic 2.x lexical analysis
-;;
-(defun semantic-lex-map-symbols (fun table &optional property)
- "Call function FUN on every symbol in TABLE.
-If optional PROPERTY is non-nil, call FUN only on every symbol which
-as a PROPERTY value. FUN receives a symbol as argument."
- (if (obarrayp table)
- (mapatoms
- (lambda (symbol)
- (if (or (null property) (get symbol property))
- (funcall fun symbol)))
- table)))
-
-;;; Lexical keyword table handling.
-;;
-;; These keywords are keywords defined for using in a grammar with the
-;; %keyword declaration, and are not keywords used in Emacs Lisp.
-
-(defvar-local semantic-flex-keywords-obarray nil
- "Buffer local keyword obarray for the lexical analyzer.
-These keywords are matched explicitly, and converted into special symbols.")
-
-(defmacro semantic-lex-keyword-invalid (name)
- "Signal that NAME is an invalid keyword name."
- `(signal 'wrong-type-argument '(semantic-lex-keyword-p ,name)))
-
-(defsubst semantic-lex-keyword-symbol (name)
- "Return keyword symbol with NAME or nil if not found."
- (and (obarrayp semantic-flex-keywords-obarray)
- (stringp name)
- (intern-soft name semantic-flex-keywords-obarray)))
-
-(defsubst semantic-lex-keyword-p (name)
- "Return non-nil if a keyword with NAME exists in the keyword table.
-Return nil otherwise."
- (and (setq name (semantic-lex-keyword-symbol name))
- (symbol-value name)))
-
-(defsubst semantic-lex-keyword-set (name value)
- "Set value of keyword with NAME to VALUE and return VALUE."
- (set (intern name semantic-flex-keywords-obarray) value))
-
-(defsubst semantic-lex-keyword-value (name)
- "Return value of keyword with NAME.
-Signal an error if a keyword with NAME does not exist."
- (let ((keyword (semantic-lex-keyword-symbol name)))
- (if keyword
- (symbol-value keyword)
- (semantic-lex-keyword-invalid name))))
-
-(defsubst semantic-lex-keyword-put (name property value)
- "For keyword with NAME, set its PROPERTY to VALUE."
- (let ((keyword (semantic-lex-keyword-symbol name)))
- (if keyword
- (put keyword property value)
- (semantic-lex-keyword-invalid name))))
-
-(defsubst semantic-lex-keyword-get (name property)
- "For keyword with NAME, return its PROPERTY value."
- (let ((keyword (semantic-lex-keyword-symbol name)))
- (if keyword
- (get keyword property)
- (semantic-lex-keyword-invalid name))))
-
-(defun semantic-lex-make-keyword-table (specs &optional propspecs)
- "Convert keyword SPECS into an obarray and return it.
-SPECS must be a list of (NAME . TOKSYM) elements, where:
-
- NAME is the name of the keyword symbol to define.
- TOKSYM is the lexical token symbol of that keyword.
-
-If optional argument PROPSPECS is non-nil, then interpret it, and
-apply those properties.
-PROPSPECS must be a list of (NAME PROPERTY VALUE) elements."
- ;; Create the symbol hash table
- (let ((semantic-flex-keywords-obarray (obarray-make 13))
- spec)
- ;; fill it with stuff
- (while specs
- (setq spec (car specs)
- specs (cdr specs))
- (semantic-lex-keyword-set (car spec) (cdr spec)))
- ;; Apply all properties
- (while propspecs
- (setq spec (car propspecs)
- propspecs (cdr propspecs))
- (semantic-lex-keyword-put (car spec) (nth 1 spec) (nth 2 spec)))
- semantic-flex-keywords-obarray))
-
-(defsubst semantic-lex-map-keywords (fun &optional property)
- "Call function FUN on every lexical keyword.
-If optional PROPERTY is non-nil, call FUN only on every keyword which
-as a PROPERTY value. FUN receives a lexical keyword as argument."
- (semantic-lex-map-symbols
- fun semantic-flex-keywords-obarray property))
-
-(defun semantic-lex-keywords (&optional property)
- "Return a list of lexical keywords.
-If optional PROPERTY is non-nil, return only keywords which have a
-PROPERTY set."
- (let (keywords)
- (semantic-lex-map-keywords
- (lambda (symbol) (setq keywords (cons symbol keywords)))
- property)
- keywords))
-
-;;; Inline functions:
-
-(defvar semantic-lex-unterminated-syntax-end-function)
-(defvar semantic-lex-analysis-bounds)
-(defvar semantic-lex-end-point)
-
-(defsubst semantic-lex-token-bounds (token)
- "Fetch the start and end locations of the lexical token TOKEN.
-Return a pair (START . END)."
- (if (not (numberp (car (cdr token))))
- (cdr (cdr token))
- (cdr token)))
-
-(defsubst semantic-lex-token-start (token)
- "Fetch the start position of the lexical token TOKEN.
-See also the function `semantic-lex-token'."
- (car (semantic-lex-token-bounds token)))
-
-(defsubst semantic-lex-token-end (token)
- "Fetch the end position of the lexical token TOKEN.
-See also the function `semantic-lex-token'."
- (cdr (semantic-lex-token-bounds token)))
-
-(defsubst semantic-lex-unterminated-syntax-detected (syntax)
- "Inside a lexical analyzer, use this when unterminated syntax was found.
-Argument SYNTAX indicates the type of syntax that is unterminated.
-The job of this function is to move (point) to a new logical location
-so that analysis can continue, if possible."
- (goto-char
- (funcall semantic-lex-unterminated-syntax-end-function
- syntax
- (car semantic-lex-analysis-bounds)
- (cdr semantic-lex-analysis-bounds)
- ))
- (setq semantic-lex-end-point (point)))
-\f
-;;; Type table handling.
-;;
-;; The lexical type table manages types that occur in a grammar file
-;; with the %type declaration. Types represent different syntaxes.
-;; See code for `semantic-lex-preset-default-types' for the classic
-;; types of syntax.
-(defvar-local semantic-lex-types-obarray nil
- "Buffer local types obarray for the lexical analyzer.")
-
-(defun semantic-lex-type-invalid (type)
- "Signal that TYPE is an invalid lexical type name."
- (signal 'wrong-type-argument `(semantic-lex-type-p ,type)))
-
-(defsubst semantic-lex-type-symbol (type)
- "Return symbol with TYPE or nil if not found."
- (and (obarrayp semantic-lex-types-obarray)
- (stringp type)
- (intern-soft type semantic-lex-types-obarray)))
-
-(defsubst semantic-lex-type-p (type)
- "Return non-nil if a symbol with TYPE name exists."
- (and (setq type (semantic-lex-type-symbol type))
- (symbol-value type)))
-
-(defsubst semantic-lex-type-set (type value)
- "Set value of symbol with TYPE name to VALUE and return VALUE."
- (set (intern type semantic-lex-types-obarray) value))
-
-(defsubst semantic-lex-type-value (type &optional noerror)
- "Return value of symbol with TYPE name.
-If optional argument NOERROR is non-nil return nil if a symbol with
-TYPE name does not exist. Otherwise signal an error."
- (let ((sym (semantic-lex-type-symbol type)))
- (if sym
- (symbol-value sym)
- (unless noerror
- (semantic-lex-type-invalid type)))))
-
-(defsubst semantic-lex-type-put (type property value &optional add)
- "For symbol with TYPE name, set its PROPERTY to VALUE.
-If optional argument ADD is non-nil, create a new symbol with TYPE
-name if it does not already exist. Otherwise signal an error."
- (let ((sym (semantic-lex-type-symbol type)))
- (unless sym
- (or add (semantic-lex-type-invalid type))
- (semantic-lex-type-set type nil)
- (setq sym (semantic-lex-type-symbol type)))
- (put sym property value)))
-
-(defsubst semantic-lex-type-get (type property &optional noerror)
- "For symbol with TYPE name, return its PROPERTY value.
-If optional argument NOERROR is non-nil return nil if a symbol with
-TYPE name does not exist. Otherwise signal an error."
- (let ((sym (semantic-lex-type-symbol type)))
- (if sym
- (get sym property)
- (unless noerror
- (semantic-lex-type-invalid type)))))
-
-(defun semantic-lex-preset-default-types ()
- "Install useful default properties for well known types."
- (semantic-lex-type-put "punctuation" 'matchdatatype 'string t)
- (semantic-lex-type-put "punctuation" 'syntax "\\(\\s.\\|\\s$\\|\\s'\\)+")
- (semantic-lex-type-put "keyword" 'matchdatatype 'keyword t)
- (semantic-lex-type-put "keyword" 'syntax "\\(\\sw\\|\\s_\\)+")
- (semantic-lex-type-put "symbol" 'matchdatatype 'regexp t)
- (semantic-lex-type-put "symbol" 'syntax "\\(\\sw\\|\\s_\\)+")
- (semantic-lex-type-put "string" 'matchdatatype 'sexp t)
- (semantic-lex-type-put "string" 'syntax "\\s\"")
- (semantic-lex-type-put "number" 'matchdatatype 'regexp t)
- (semantic-lex-type-put "number" 'syntax 'semantic-lex-number-expression)
- (semantic-lex-type-put "block" 'matchdatatype 'block t)
- (semantic-lex-type-put "block" 'syntax "\\s(\\|\\s)")
- )
-
-(defun semantic-lex-make-type-table (specs &optional propspecs)
- "Convert type SPECS into an obarray and return it.
-SPECS must be a list of (TYPE . TOKENS) elements, where:
-
- TYPE is the name of the type symbol to define.
- TOKENS is a list of (TOKSYM . MATCHER) elements, where:
-
- TOKSYM is any lexical token symbol.
- MATCHER is a string or regexp a text must match to be a such
- lexical token.
-
-If optional argument PROPSPECS is non-nil, then interpret it, and
-apply those properties.
-PROPSPECS must be a list of (TYPE PROPERTY VALUE)."
- ;; Create the symbol hash table
- (let* ((semantic-lex-types-obarray (obarray-make 13))
- spec type tokens token alist default)
- ;; fill it with stuff
- (while specs
- (setq spec (car specs)
- specs (cdr specs)
- type (car spec)
- tokens (cdr spec)
- default nil
- alist nil)
- (while tokens
- (setq token (car tokens)
- tokens (cdr tokens))
- (if (cdr token)
- (setq alist (cons token alist))
- (setq token (car token))
- (if default
- (message
- "*Warning* default value of <%s> tokens changed to %S, was %S"
- type token default))
- (setq default token)))
- ;; Ensure the default matching spec is the first one.
- (semantic-lex-type-set type (cons default (nreverse alist))))
- ;; Install useful default types & properties
- (semantic-lex-preset-default-types)
- ;; Apply all properties
- (while propspecs
- (setq spec (car propspecs)
- propspecs (cdr propspecs))
- ;; Create the type if necessary.
- (semantic-lex-type-put (car spec) (nth 1 spec) (nth 2 spec) t))
- semantic-lex-types-obarray))
-
-(defsubst semantic-lex-map-types (fun &optional property)
- "Call function FUN on every lexical type.
-If optional PROPERTY is non-nil, call FUN only on every type symbol
-which has a PROPERTY value. FUN receives a type symbol as argument."
- (semantic-lex-map-symbols
- fun semantic-lex-types-obarray property))
-
-(defun semantic-lex-types (&optional property)
- "Return a list of lexical type symbols.
-If optional PROPERTY is non-nil, return only type symbols which have
-PROPERTY set."
- (let (types)
- (semantic-lex-map-types
- (lambda (symbol) (setq types (cons symbol types)))
- property)
- types))
-\f
-;;; Lexical Analyzer framework settings
-;;
-
-(defvar-local semantic-lex-analyzer #'semantic-lex
- "The lexical analyzer used for a given buffer.
-See `semantic-lex' for documentation.")
-
-(defvar semantic-lex-tokens
- '(
- (bol)
- (charquote)
- (close-paren)
- (comment)
- (newline)
- (open-paren)
- (punctuation)
- (semantic-list)
- (string)
- (symbol)
- (whitespace)
- )
- "An alist of semantic token types.
-As of December 2001 (semantic 1.4beta13), this variable is not used in
-any code. The only use is to refer to the doc-string from elsewhere.
-
-The key to this alist is the symbol representing token type that
-\\[semantic-flex] returns. These are
-
- - bol: Empty string matching a beginning of line.
- This token is produced with
- `semantic-lex-beginning-of-line'.
-
- - charquote: String sequences that match `\\s\\+' regexp.
- This token is produced with `semantic-lex-charquote'.
-
- - close-paren: Characters that match `\\s)' regexp.
- These are typically `)', `}', `]', etc.
- This token is produced with
- `semantic-lex-close-paren'.
-
- - comment: A comment chunk. These token types are not
- produced by default.
- This token is produced with `semantic-lex-comments'.
- Comments are ignored with `semantic-lex-ignore-comments'.
- Comments are treated as whitespace with
- `semantic-lex-comments-as-whitespace'.
-
- - newline Characters matching `\\s-*\\(\n\\|\\s>\\)' regexp.
- This token is produced with `semantic-lex-newline'.
-
- - open-paren: Characters that match `\\s(' regexp.
- These are typically `(', `{', `[', etc.
- If `semantic-lex-paren-or-list' is used,
- then `open-paren' is not usually generated unless
- the `depth' argument to \\[semantic-lex] is
- greater than 0.
- This token is always produced if the analyzer
- `semantic-lex-open-paren' is used.
-
- - punctuation: Characters matching `{\\(\\s.\\|\\s$\\|\\s'\\)'
- regexp.
- This token is produced with `semantic-lex-punctuation'.
- Always specify this analyzer after the comment
- analyzer.
-
- - semantic-list: String delimited by matching parenthesis, braces,
- etc. that the lexer skipped over, because the
- `depth' parameter to \\[semantic-flex] was not high
- enough.
- This token is produced with `semantic-lex-paren-or-list'.
-
- - string: Quoted strings, i.e., string sequences that start
- and end with characters matching `\\s\"'
- regexp. The lexer relies on @code{forward-sexp} to
- find the matching end.
- This token is produced with `semantic-lex-string'.
-
- - symbol: String sequences that match `\\(\\sw\\|\\s_\\)+'
- regexp.
- This token is produced with
- `semantic-lex-symbol-or-keyword'. Always add this analyzer
- after `semantic-lex-number', or other analyzers that
- match its regular expression.
-
- - whitespace: Characters that match `\\s-+' regexp.
- This token is produced with `semantic-lex-whitespace'.")
-
-(defvar-local semantic-lex-syntax-modifications nil
- "Changes to the syntax table for this buffer.
-These changes are active only while the buffer is being flexed.
-This is a list where each element has the form:
- (CHAR CLASS)
-CHAR is the char passed to `modify-syntax-entry',
-and CLASS is the string also passed to `modify-syntax-entry' to define
-what syntax class CHAR has.")
-
-(defvar-local semantic-lex-syntax-table nil
- "Syntax table used by lexical analysis.
-See also `semantic-lex-syntax-modifications'.")
-
-(defvar-local semantic-lex-comment-regex nil
- "Regular expression for identifying comment start during lexical analysis.
-This may be automatically set when semantic initializes in a mode, but
-may need to be overridden for some special languages.")
-
-(defvar-local semantic-lex-number-expression
- ;; This expression was written by David Ponce for Java, and copied
- ;; here for C and any other similar language.
- (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][[:xdigit:]]+[lL]?\\>"
- "\\|"
- "\\<[0-9]+[lLfFdD]?\\>"
- "\\)"
- )
- "Regular expression for matching a number.
-If this value is nil, no number extraction is done during lex.
-This expression tries to match C and Java like numbers.
-
-DECIMAL_LITERAL:
- [1-9][0-9]*
- ;
-HEX_LITERAL:
- 0[xX][[:xdigit:]]+
- ;
-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]
- ;")
-
-(defvar-local semantic-lex-depth 0
- "Default lexing depth.
-This specifies how many lists to create tokens in.")
-
-(defvar semantic-lex-unterminated-syntax-end-function
- (lambda (_syntax _syntax-start lex-end) lex-end)
- "Function called when unterminated syntax is encountered.
-This should be set to one function. That function should take three
-parameters. The SYNTAX, or type of syntax which is unterminated.
-SYNTAX-START where the broken syntax begins.
-LEX-END is where the lexical analysis was asked to end.
-This function can be used for languages that can intelligently fix up
-broken syntax, or the exit lexical analysis via `throw' or `signal'
-when finding unterminated syntax.")
-
-;;; Interactive testing commands
-
-(declare-function semantic-elapsed-time "semantic")
-
-(defun semantic-lex-test (arg)
- "Test the semantic lexer in the current buffer.
-If universal argument ARG, then try the whole buffer."
- (interactive "P")
- (require 'semantic)
- (let* ((start (current-time))
- (result (semantic-lex
- (if arg (point-min) (point))
- (point-max))))
- (message "Elapsed Time: %.2f seconds."
- (semantic-elapsed-time start nil))
- (pop-to-buffer "*Lexer Output*")
- (require 'pp)
- (erase-buffer)
- (insert (pp-to-string result))
- (goto-char (point-min))
- ))
-
-(defvar semantic-lex-debug nil
- "When non-nil, debug the local lexical analyzer.")
-
-(defun semantic-lex-debug (arg)
- "Debug the semantic lexer in the current buffer.
-Argument ARG specifies of the analyze the whole buffer, or start at point.
-While engaged, each token identified by the lexer will be highlighted
-in the target buffer A description of the current token will be
-displayed in the minibuffer. Press SPC to move to the next lexical token."
- (interactive "P")
- (require 'semantic/debug)
- (let ((semantic-lex-debug t))
- (semantic-lex-test arg)))
-
-(defun semantic-lex-highlight-token (token)
- "Highlight the lexical TOKEN.
-TOKEN is a lexical token with a START And END position.
-Return the overlay."
- (let ((o (make-overlay (semantic-lex-token-start token)
- (semantic-lex-token-end token))))
- (overlay-put o 'face 'highlight)
- o))
-
-;;; Lexical analyzer creation
-;;
-;; Code for creating a lex function from lists of analyzers.
-;;
-;; A lexical analyzer is created from a list of individual analyzers.
-;; Each individual analyzer specifies a single match, and code that
-;; goes with it.
-;;
-;; Creation of an analyzer assembles these analyzers into a new function
-;; with the behaviors of all the individual analyzers.
-;;
-(defmacro semantic-lex-one-token (analyzers)
- "Calculate one token from the current buffer at point.
-Uses locally bound variables from `define-lex'.
-Argument ANALYZERS is the list of analyzers being used."
- (cons 'cond (mapcar #'symbol-value analyzers)))
-
-(defvar semantic-lex-end-point nil
- "The end point as tracked through lexical functions.")
-
-(defvar semantic-lex-current-depth nil
- "The current depth as tracked through lexical functions.")
-
-(defvar semantic-lex-maximum-depth nil
- "The maximum depth of parenthesis as tracked through lexical functions.")
-
-(defvar semantic-lex-token-stream nil
- "The current token stream we are collecting.")
-
-(defvar semantic-lex-analysis-bounds nil
- "The bounds of the current analysis.")
-
-(defvar semantic-lex-block-streams nil
- "Streams of tokens inside collapsed blocks.
-This is an alist of (ANCHOR . STREAM) elements where ANCHOR is the
-start position of the block, and STREAM is the list of tokens in that
-block.")
-
-(defvar semantic-lex-reset-functions nil
- "Abnormal hook used by major-modes to reset lexical analyzers.
-Hook functions are called with START and END values for the
-current lexical pass. Should be set with `add-hook', specifying
-a LOCAL option.")
-
-;; Stack of nested blocks.
-(defvar semantic-lex-block-stack nil)
-;;(defcustom semantic-lex-timeout 5
-;; "Number of sections of lexing before giving up."
-;; :type 'integer
-;; :group 'semantic)
-
-(defsubst semantic-lex-debug-break (token)
- "Break during lexical analysis at TOKEN."
- (when semantic-lex-debug
- (let ((o nil))
- (unwind-protect
- (progn
- (when token
- (setq o (semantic-lex-highlight-token token)))
- (read-event
- (format "%S :: Depth: %d :: SPC - continue" token semantic-lex-current-depth))
- )
- (when o
- (delete-overlay o))))))
-
-(defmacro define-lex (name doc &rest analyzers)
- "Create a new lexical analyzer with NAME.
-DOC is a documentation string describing this analyzer.
-ANALYZERS are small code snippets of analyzers to use when
-building the new NAMED analyzer. Only use analyzers which
-are written to be used in `define-lex'.
-Each analyzer should be an analyzer created with `define-lex-analyzer'.
-Note: The order in which analyzers are listed is important.
-If two analyzers can match the same text, it is important to order the
-analyzers so that the one you want to match first occurs first. For
-example, it is good to put a number analyzer in front of a symbol
-analyzer which might mistake a number for a symbol."
- (declare (debug (&define name stringp (&rest symbolp))) (indent 1))
- `(defun ,name (start end &optional depth length)
- ,(concat doc "\nSee `semantic-lex' for more information.")
- ;; Make sure the state of block parsing starts over.
- (setq semantic-lex-block-streams nil)
- ;; Allow specialty reset items.
- (run-hook-with-args 'semantic-lex-reset-functions start end)
- ;; Lexing state.
- (let* (;(starttime (current-time))
- (starting-position (point))
- (semantic-lex-token-stream nil)
- (semantic-lex-block-stack nil)
- (tmp-start start)
- (semantic-lex-end-point start)
- (semantic-lex-current-depth 0)
- ;; Use the default depth when not specified.
- (semantic-lex-maximum-depth
- (or depth semantic-lex-depth))
- ;; Bounds needed for unterminated syntax
- (semantic-lex-analysis-bounds (cons start end))
- ;; This entry prevents text properties from
- ;; confusing our lexical analysis. See Emacs 22 (CVS)
- ;; version of C++ mode with template hack text properties.
- (parse-sexp-lookup-properties nil)
- )
- ;; Maybe REMOVE THIS LATER.
- ;; Trying to find incremental parser bug.
- (when (> end (point-max))
- (error ,(format "%s: end (%%d) > point-max (%%d)" name)
- end (point-max)))
- (with-syntax-table semantic-lex-syntax-table
- (goto-char start)
- (while (and (< (point) end)
- (or (not length)
- (<= (length semantic-lex-token-stream) length)))
- (semantic-lex-one-token ,analyzers)
- (when (eq semantic-lex-end-point tmp-start)
- (error ,(format "%s: endless loop at %%d, after %%S" name)
- tmp-start (car semantic-lex-token-stream)))
- (setq tmp-start semantic-lex-end-point)
- (goto-char semantic-lex-end-point)
- ;;(when (> (semantic-elapsed-time starttime nil)
- ;; semantic-lex-timeout)
- ;; (error "Timeout during lex at char %d" (point)))
- (semantic-throw-on-input 'lex)
- (semantic-lex-debug-break (car semantic-lex-token-stream))
- ))
- ;; Check that there is no unterminated block.
- (when semantic-lex-block-stack
- (let* ((last (pop semantic-lex-block-stack))
- (blk last))
- (while blk
- (message
- ,(format "%s: `%%s' block from %%S is unterminated" name)
- (car blk) (cadr blk))
- (setq blk (pop semantic-lex-block-stack)))
- (semantic-lex-unterminated-syntax-detected (car last))))
- ;; Return to where we started.
- ;; Do not wrap in protective stuff so that if there is an error
- ;; thrown, the user knows where.
- (goto-char starting-position)
- ;; Return the token stream
- (nreverse semantic-lex-token-stream))))
-\f
-;;; Lexical token API
-;;
-;; Functions for accessing parts of a token. Use these functions
-;; instead of accessing the list structure directly because the
-;; contents of the lexical may change.
-;;
-(defmacro semantic-lex-token (symbol start end &optional str)
- "Create a lexical token.
-SYMBOL is a symbol representing the class of syntax found.
-START and END define the bounds of the token in the current buffer.
-Optional STR is the string for the token only if the bounds in
-the buffer do not cover the string they represent. (As from
-macro expansion.)"
- ;; This if statement checks the existence of a STR argument at
- ;; compile time, where STR is some symbol or constant. If the
- ;; variable STr (runtime) is nil, this will make an incorrect decision.
- ;;
- ;; It is like this to maintain the original speed of the compiled
- ;; code.
- (if str
- `(cons ,symbol (cons ,str (cons ,start ,end)))
- `(cons ,symbol (cons ,start ,end))))
-
-(defun semantic-lex-token-p (thing)
- "Return non-nil if THING is a semantic lex token.
-This is an exhaustively robust check."
- (and (consp thing)
- (symbolp (car thing))
- (or (and (numberp (nth 1 thing))
- (numberp (nthcdr 2 thing)))
- (and (stringp (nth 1 thing))
- (numberp (nth 2 thing))
- (numberp (nthcdr 3 thing)))
- ))
- )
-
-(defun semantic-lex-token-with-text-p (thing)
- "Return non-nil if THING is a semantic lex token.
-This is an exhaustively robust check."
- (and (consp thing)
- (symbolp (car thing))
- (= (length thing) 4)
- (stringp (nth 1 thing))
- (numberp (nth 2 thing))
- (numberp (nth 3 thing)))
- )
-
-(defun semantic-lex-token-without-text-p (thing)
- "Return non-nil if THING is a semantic lex token.
-This is an exhaustively robust check."
- (and (consp thing)
- (symbolp (car thing))
- (= (length thing) 3)
- (numberp (nth 1 thing))
- (numberp (nth 2 thing)))
- )
-
-(eval-and-compile
-
-(defun semantic-lex-expand-block-specs (specs)
- "Expand block specifications SPECS into a Lisp form.
-SPECS is a list of (BLOCK BEGIN END) elements where BLOCK, BEGIN, and
-END are token class symbols that indicate to produce one collapsed
-BLOCK token from tokens found between BEGIN and END ones.
-BLOCK must be a non-nil symbol, and at least one of the BEGIN or END
-symbols must be non-nil too.
-When BEGIN is non-nil, generate a call to `semantic-lex-start-block'
-when a BEGIN token class is encountered.
-When END is non-nil, generate a call to `semantic-lex-end-block' when
-an END token class is encountered."
- (let ((class (make-symbol "class"))
- (form nil))
- (dolist (spec specs)
- (when (car spec)
- (when (nth 1 spec)
- (push `((eq ',(nth 1 spec) ,class)
- (semantic-lex-start-block ',(car spec)))
- form))
- (when (nth 2 spec)
- (push `((eq ',(nth 2 spec) ,class)
- (semantic-lex-end-block ',(car spec)))
- form))))
- (when form
- `((let ((,class (semantic-lex-token-class
- (car semantic-lex-token-stream))))
- (cond ,@(nreverse form))))
- )))
-)
-
-(defmacro semantic-lex-push-token (token &rest blockspecs)
- "Push TOKEN in the lexical analyzer token stream.
-Return the lexical analysis current end point.
-If optional arguments BLOCKSPECS is non-nil, it specifies to process
-collapsed block tokens. See `semantic-lex-expand-block-specs' for
-more details.
-This macro should only be called within the bounds of
-`define-lex-analyzer'. It changes the values of the lexical analyzer
-variables `token-stream' and `semantic-lex-end-point'. If you need to
-move `semantic-lex-end-point' somewhere else, just modify this
-variable after calling `semantic-lex-push-token'."
- `(progn
- (push ,token semantic-lex-token-stream)
- ,@(semantic-lex-expand-block-specs blockspecs)
- (setq semantic-lex-end-point
- (semantic-lex-token-end (car semantic-lex-token-stream)))
- ))
-
-(defsubst semantic-lex-token-class (token)
- "Fetch the class of the lexical token TOKEN.
-See also the function `semantic-lex-token'."
- (car token))
-
-(defsubst semantic-lex-token-text (token)
- "Fetch the text associated with the lexical token TOKEN.
-See also the function `semantic-lex-token'."
- (if (stringp (car (cdr token)))
- (car (cdr token))
- (buffer-substring-no-properties
- (semantic-lex-token-start token)
- (semantic-lex-token-end token))))
-
-(defun semantic-lex-init ()
- "Initialize any lexical state for this buffer."
- (unless semantic-lex-comment-regex
- (setq semantic-lex-comment-regex
- (if comment-start-skip
- (concat "\\(\\s<\\|" comment-start-skip "\\)")
- "\\(\\s<\\)")))
- ;; Setup the lexer syntax-table
- (setq semantic-lex-syntax-table (copy-syntax-table (syntax-table)))
- (dolist (mod semantic-lex-syntax-modifications)
- (modify-syntax-entry
- (car mod) (nth 1 mod) semantic-lex-syntax-table)))
-
-;;;###autoload
-(define-overloadable-function semantic-lex (start end &optional depth length)
- "Lexically analyze text in the current buffer between START and END.
-Optional argument DEPTH indicates at what level to scan over entire
-lists. The last argument, LENGTH specifies that `semantic-lex'
-should only return LENGTH tokens. The return value is a token stream.
-Each element is a list, such of the form
- (symbol start-expression . end-expression)
-where SYMBOL denotes the token type.
-See `semantic-lex-tokens' variable for details on token types. END
-does not mark the end of the text scanned, only the end of the
-beginning of text scanned. Thus, if a string extends past END, the
-end of the return token will be larger than END. To truly restrict
-scanning, use `narrow-to-region'."
- (funcall semantic-lex-analyzer start end depth length))
-
-(defsubst semantic-lex-buffer (&optional depth)
- "Lex the current buffer.
-Optional argument DEPTH is the depth to scan into lists."
- (semantic-lex (point-min) (point-max) depth))
-
-(defsubst semantic-lex-list (semlist depth)
- "Lex the body of SEMLIST to DEPTH."
- (semantic-lex (semantic-lex-token-start semlist)
- (semantic-lex-token-end semlist)
- depth))
-\f
-;;; Collapsed block tokens delimited by any tokens.
-;;
-(defun semantic-lex-start-block (syntax)
- "Mark the last read token as the beginning of a SYNTAX block."
- (if (or (not semantic-lex-maximum-depth)
- (< semantic-lex-current-depth semantic-lex-maximum-depth))
- (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
- (push (list syntax (car semantic-lex-token-stream))
- semantic-lex-block-stack)))
-
-(defun semantic-lex-end-block (syntax)
- "Process the end of a previously marked SYNTAX block.
-That is, collapse the tokens inside that block, including the
-beginning and end of block tokens, into a high level block token of
-class SYNTAX.
-The token at beginning of block is the one marked by a previous call
-to `semantic-lex-start-block'. The current token is the end of block.
-The collapsed tokens are saved in `semantic-lex-block-streams'."
- (if (null semantic-lex-block-stack)
- (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
- (let* ((stream semantic-lex-token-stream)
- (blk (pop semantic-lex-block-stack))
- (bstream (cdr blk))
- (first (car bstream))
- (last (pop stream)) ;; The current token mark the EOBLK
- tok)
- (if (not (eq (car blk) syntax))
- ;; SYNTAX doesn't match the syntax of the current block in
- ;; the stack. So we encountered the end of the SYNTAX block
- ;; before the end of the current one in the stack which is
- ;; signaled unterminated.
- (semantic-lex-unterminated-syntax-detected (car blk))
- ;; Move tokens found inside the block from the main stream
- ;; into a separate block stream.
- (while (and stream (not (eq (setq tok (pop stream)) first)))
- (push tok bstream))
- ;; The token marked as beginning of block was not encountered.
- ;; This should not happen!
- (or (eq tok first)
- (error "Token %S not found at beginning of block `%s'"
- first syntax))
- ;; Save the block stream for future reuse, to avoid to redo
- ;; the lexical analysis of the block content!
- ;; Anchor the block stream with its start position, so we can
- ;; use: (cdr (assq start semantic-lex-block-streams)) to
- ;; quickly retrieve the lexical stream associated to a block.
- (setcar blk (semantic-lex-token-start first))
- (setcdr blk (nreverse bstream))
- (push blk semantic-lex-block-streams)
- ;; In the main stream, replace the tokens inside the block by
- ;; a high level block token of class SYNTAX.
- (setq semantic-lex-token-stream stream)
- (semantic-lex-push-token
- (semantic-lex-token
- syntax (car blk) (semantic-lex-token-end last)))
- ))))
-\f
-;;; Analyzer creation macros
-;;
-;; An individual analyzer is a condition and code that goes with it.
-;;
-;; Created analyzers become variables with the code associated with them
-;; as the symbol value. These analyzers are assembled into a lexer
-;; to create new lexical analyzers.
-
-(defcustom semantic-lex-debug-analyzers nil
- "Non-nil means to debug analyzers with syntax protection.
-Only in effect if `debug-on-error' is also non-nil."
- :group 'semantic
- :type 'boolean)
-
-(defmacro semantic-lex-unterminated-syntax-protection (syntax &rest forms)
- "For SYNTAX, execute FORMS with protection for unterminated syntax.
-If FORMS throws an error, treat this as a syntax problem, and
-execute the unterminated syntax code. FORMS should return a position.
-Regardless of an error, the cursor should be moved to the end of
-the desired syntax, and a position returned.
-If `debug-on-error' is set, errors are not caught, so that you can
-debug them.
-Avoid using a large FORMS since it is duplicated."
- (declare (indent 1) (debug t))
- `(if (and debug-on-error semantic-lex-debug-analyzers)
- (progn ,@forms)
- (condition-case nil
- (progn ,@forms)
- (error
- (semantic-lex-unterminated-syntax-detected ,syntax)))))
-
-(defmacro define-lex-analyzer (name doc condition &rest forms)
- "Create a single lexical analyzer NAME with DOC.
-When an analyzer is called, the current buffer and point are
-positioned in a buffer at the location to be analyzed.
-CONDITION is an expression which returns t if FORMS should be run.
-Within the bounds of CONDITION and FORMS, the use of backquote
-can be used to evaluate expressions at compile time.
-While forms are running, the following variables will be locally bound:
- `semantic-lex-analysis-bounds' - The bounds of the current analysis.
- of the form (START . END)
- `semantic-lex-maximum-depth' - The maximum depth of semantic-list
- for the current analysis.
- `semantic-lex-current-depth' - The current depth of `semantic-list' that has
- been descended.
- `semantic-lex-end-point' - End Point after match.
- Analyzers should set this to a buffer location if their
- match string does not represent the end of the matched text.
- `semantic-lex-token-stream' - The token list being collected.
- Add new lexical tokens to this list.
-Proper action in FORMS is to move the value of `semantic-lex-end-point' to
-after the location of the analyzed entry, and to add any discovered tokens
-at the beginning of `semantic-lex-token-stream'.
-This can be done by using `semantic-lex-push-token'."
- (declare (debug (&define name stringp form def-body)) (indent 1))
- `(eval-and-compile
- ;; This is the real info used by `define-lex' (via semantic-lex-one-token).
- (defconst ,name '(,condition ,@forms) ,doc)
- ;; Build a single lexical analyzer function, so the doc for
- ;; function help is automatically provided, and perhaps the
- ;; function could be useful for testing and debugging one
- ;; analyzer.
- (defun ,name ()
- ,doc
- (let ((semantic-lex-token-stream nil)
- (semantic-lex-end-point (point))
- (semantic-lex-analysis-bounds (cons (point) (point-max)))
- (semantic-lex-current-depth 0)
- (semantic-lex-maximum-depth semantic-lex-depth))
- (when ,condition nil ,@forms) ; `nil' avoids an empty-body warning.
- semantic-lex-token-stream))))
-
-(defmacro define-lex-regex-analyzer (name doc regexp &rest forms)
- "Create a lexical analyzer with NAME and DOC that will match REGEXP.
-FORMS are evaluated upon a successful match.
-See `define-lex-analyzer' for more about analyzers."
- (declare (debug (&define name stringp form def-body)) (indent 1))
- `(define-lex-analyzer ,name
- ,doc
- (looking-at ,regexp)
- ,@forms
- ))
-
-(defmacro define-lex-simple-regex-analyzer (name doc regexp toksym
- &optional index
- &rest forms)
- "Create a lexical analyzer with NAME and DOC that match REGEXP.
-TOKSYM is the symbol to use when creating a semantic lexical token.
-INDEX is the index into the match that defines the bounds of the token.
-Index should be a plain integer, and not specified in the macro as an
-expression.
-FORMS are evaluated upon a successful match BEFORE the new token is
-created. It is valid to ignore FORMS.
-See `define-lex-analyzer' for more about analyzers."
- (declare (debug
- (&define name stringp form symbolp [ &optional form ] def-body))
- (indent 1))
- `(define-lex-analyzer ,name
- ,doc
- (looking-at ,regexp)
- ,@forms
- (semantic-lex-push-token
- (semantic-lex-token ,toksym
- (match-beginning ,(or index 0))
- (match-end ,(or index 0))))
- ))
-
-(defmacro define-lex-block-analyzer (name doc spec1 &rest specs)
- "Create a lexical analyzer NAME for paired delimiters blocks.
-It detects a paired delimiters block or the corresponding open or
-close delimiter depending on the value of the variable
-`semantic-lex-current-depth'. DOC is the documentation string of the lexical
-analyzer. SPEC1 and SPECS specify the token symbols and open, close
-delimiters used. Each SPEC has the form:
-
-\(BLOCK-SYM (OPEN-DELIM OPEN-SYM) (CLOSE-DELIM CLOSE-SYM))
-
-where BLOCK-SYM is the symbol returned in a block token. OPEN-DELIM
-and CLOSE-DELIM are respectively the open and close delimiters
-identifying a block. OPEN-SYM and CLOSE-SYM are respectively the
-symbols returned in open and close tokens."
- (declare (debug (&define name stringp form (&rest form)))
- (indent 1))
- (let ((specs (cons spec1 specs))
- spec open olist clist)
- (while specs
- (setq spec (car specs)
- specs (cdr specs)
- open (nth 1 spec)
- ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...)
- olist (cons (list (car open) (cadr open) (car spec)) olist)
- ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...)
- clist (cons (nth 2 spec) clist)))
- `(define-lex-analyzer ,name
- ,doc
- (and
- (looking-at "\\(\\s(\\|\\s)\\)")
- (let ((text (match-string 0)) match)
- (cond
- ((setq match (assoc text ',olist))
- (if (or (not semantic-lex-maximum-depth)
- (< semantic-lex-current-depth semantic-lex-maximum-depth))
- (progn
- (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
- (semantic-lex-push-token
- (semantic-lex-token
- (nth 1 match)
- (match-beginning 0) (match-end 0))))
- (semantic-lex-push-token
- (semantic-lex-token
- (nth 2 match)
- (match-beginning 0)
- (save-excursion
- (semantic-lex-unterminated-syntax-protection (nth 2 match)
- (forward-list 1)
- (point)))
- ))
- ))
- ((setq match (assoc text ',clist))
- (if (> semantic-lex-current-depth 0)
- (progn
- (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
- (semantic-lex-push-token
- (semantic-lex-token
- (nth 1 match)
- (match-beginning 0) (match-end 0)))))))))
- )))
-\f
-;;; Analyzers
-;;
-;; Pre-defined common analyzers.
-;;
-(define-lex-analyzer semantic-lex-default-action
- "The default action when no other lexical actions match text.
-This action will just throw an error."
- t
- (error "Unmatched Text during Lexical Analysis"))
-
-(define-lex-analyzer semantic-lex-beginning-of-line
- "Detect and create a beginning of line token (BOL)."
- (and (bolp)
- ;; Just insert a (bol N . N) token in the token stream,
- ;; without moving the point. N is the point at the
- ;; beginning of line.
- (semantic-lex-push-token (semantic-lex-token 'bol (point) (point)))
- nil) ;; CONTINUE
- ;; We identify and add the BOL token onto the stream, but since
- ;; semantic-lex-end-point doesn't move, we always fail CONDITION, and have no
- ;; FORMS body.
- nil)
-
-(define-lex-simple-regex-analyzer semantic-lex-newline
- "Detect and create newline tokens."
- "\\s-*\\(\n\\|\\s>\\)" 'newline 1)
-
-(define-lex-regex-analyzer semantic-lex-newline-as-whitespace
- "Detect and create newline tokens.
-Use this ONLY if newlines are not whitespace characters (such as when
-they are comment end characters) AND when you want whitespace tokens."
- "\\s-*\\(\n\\|\\s>\\)"
- ;; Language wants whitespaces. Create a token for it.
- (if (eq (semantic-lex-token-class (car semantic-lex-token-stream))
- 'whitespace)
- ;; Merge whitespace tokens together if they are adjacent. Two
- ;; whitespace tokens may be separated by a comment which is not in
- ;; the token stream.
- (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
- (match-end 0))
- (semantic-lex-push-token
- (semantic-lex-token
- 'whitespace (match-beginning 0) (match-end 0)))))
-
-(define-lex-regex-analyzer semantic-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)."
- "\\s-*\\(\n\\|\\s>\\)"
- (setq semantic-lex-end-point (match-end 0)))
-
-(define-lex-regex-analyzer semantic-lex-whitespace
- "Detect and create whitespace tokens."
- ;; catch whitespace when needed
- "\\s-+"
- ;; Language wants whitespaces. Create a token for it.
- (if (eq (semantic-lex-token-class (car semantic-lex-token-stream))
- 'whitespace)
- ;; Merge whitespace tokens together if they are adjacent. Two
- ;; whitespace tokens may be separated by a comment which is not in
- ;; the token stream.
- (progn
- (setq semantic-lex-end-point (match-end 0))
- (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
- semantic-lex-end-point))
- (semantic-lex-push-token
- (semantic-lex-token
- 'whitespace (match-beginning 0) (match-end 0)))))
-
-(define-lex-regex-analyzer semantic-lex-ignore-whitespace
- "Detect and skip over whitespace tokens."
- ;; catch whitespace when needed
- "\\s-+"
- ;; Skip over the detected whitespace, do not create a token for it.
- (setq semantic-lex-end-point (match-end 0)))
-
-(define-lex-simple-regex-analyzer semantic-lex-number
- "Detect and create number tokens.
-See `semantic-lex-number-expression' for details on matching numbers,
-and number formats."
- semantic-lex-number-expression 'number)
-
-(define-lex-regex-analyzer semantic-lex-symbol-or-keyword
- "Detect and create symbol and keyword tokens."
- "\\(\\sw\\|\\s_\\)+"
- (semantic-lex-push-token
- (semantic-lex-token
- (or (semantic-lex-keyword-p (match-string 0)) 'symbol)
- (match-beginning 0) (match-end 0))))
-
-(define-lex-simple-regex-analyzer semantic-lex-charquote
- "Detect and create charquote tokens."
- ;; Character quoting characters (ie, \n as newline)
- "\\s\\+" 'charquote)
-
-(define-lex-simple-regex-analyzer semantic-lex-punctuation
- "Detect and create punctuation tokens."
- "\\(\\s.\\|\\s$\\|\\s'\\)" 'punctuation)
-
-(define-lex-analyzer semantic-lex-punctuation-type
- "Detect and create a punctuation type token.
-Recognized punctuation is defined in the current table of lexical
-types, as the value of the `punctuation' token type."
- (and (looking-at "\\(\\s.\\|\\s$\\|\\s'\\)+")
- (let* ((key (match-string 0))
- (pos (match-beginning 0))
- (end (match-end 0))
- (len (- end pos))
- (lst (semantic-lex-type-value "punctuation" t))
- (def (car lst)) ;; default lexical symbol or nil
- (lst (cdr lst)) ;; alist of (LEX-SYM . PUNCT-STRING)
- (elt nil))
- (if lst
- ;; Starting with the longest one, search if the
- ;; punctuation string is defined for this language.
- (while (and (> len 0) (not (setq elt (rassoc key lst))))
- (setq len (1- len)
- key (substring key 0 len))))
- (if elt ;; Return the punctuation token found
- (semantic-lex-push-token
- (semantic-lex-token (car elt) pos (+ pos len)))
- (if def ;; Return a default generic token
- (semantic-lex-push-token
- (semantic-lex-token def pos end))
- ;; Nothing match
- )))))
-
-(define-lex-regex-analyzer semantic-lex-paren-or-list
- "Detect open parenthesis.
-Return either a paren token or a semantic list token depending on
-`semantic-lex-current-depth'."
- "\\s("
- (if (or (not semantic-lex-maximum-depth)
- (< semantic-lex-current-depth semantic-lex-maximum-depth))
- (progn
- (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
- (semantic-lex-push-token
- (semantic-lex-token
- 'open-paren (match-beginning 0) (match-end 0))))
- (semantic-lex-push-token
- (semantic-lex-token
- 'semantic-list (match-beginning 0)
- (save-excursion
- (semantic-lex-unterminated-syntax-protection 'semantic-list
- (forward-list 1)
- (point))
- )))
- ))
-
-(define-lex-simple-regex-analyzer semantic-lex-open-paren
- "Detect and create an open parenthesis token."
- "\\s(" 'open-paren 0 (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)))
-
-(define-lex-simple-regex-analyzer semantic-lex-close-paren
- "Detect and create a close parenthesis token."
- "\\s)" 'close-paren 0 (setq semantic-lex-current-depth (1- semantic-lex-current-depth)))
-
-(define-lex-regex-analyzer semantic-lex-string
- "Detect and create a string token."
- "\\s\""
- ;; Zing to the end of this string.
- (semantic-lex-push-token
- (semantic-lex-token
- 'string (point)
- (save-excursion
- (semantic-lex-unterminated-syntax-protection 'string
- (forward-sexp 1)
- (point))
- ))))
-
-(define-lex-regex-analyzer semantic-lex-comments
- "Detect and create a comment token."
- semantic-lex-comment-regex
- (save-excursion
- (forward-comment 1)
- ;; Generate newline token if enabled
- (if (bolp) (backward-char 1))
- (setq semantic-lex-end-point (point))
- ;; Language wants comments or want them as whitespaces,
- ;; link them together.
- (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) 'comment)
- (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
- semantic-lex-end-point)
- (semantic-lex-push-token
- (semantic-lex-token
- 'comment (match-beginning 0) semantic-lex-end-point)))))
-
-(define-lex-regex-analyzer semantic-lex-comments-as-whitespace
- "Detect comments and create a whitespace token."
- semantic-lex-comment-regex
- (save-excursion
- (forward-comment 1)
- ;; Generate newline token if enabled
- (if (bolp) (backward-char 1))
- (setq semantic-lex-end-point (point))
- ;; Language wants comments or want them as whitespaces,
- ;; link them together.
- (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) 'whitespace)
- (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
- semantic-lex-end-point)
- (semantic-lex-push-token
- (semantic-lex-token
- 'whitespace (match-beginning 0) semantic-lex-end-point)))))
-
-(define-lex-regex-analyzer semantic-lex-ignore-comments
- "Detect and create a comment token."
- semantic-lex-comment-regex
- (let ((comment-start-point (point)))
- (forward-comment 1)
- (if (eq (point) comment-start-point)
- ;; In this case our start-skip string failed
- ;; to work properly. Lets try and move over
- ;; whatever white space we matched to begin
- ;; with.
- (skip-syntax-forward "-.'" (line-end-position))
- ;; We may need to back up so newlines or whitespace is generated.
- (if (bolp)
- (backward-char 1)))
- (if (eq (point) comment-start-point)
- (error "Strange comment syntax prevents lexical analysis"))
- (setq semantic-lex-end-point (point))))
-\f
-;;; Comment lexer
-;;
-;; Predefined lexers that could be used instead of creating new
-;; analyzers.
-
-(define-lex semantic-comment-lexer
- "A simple lexical analyzer that handles comments.
-This lexer will only return comment tokens. It is the default
-lexer used by `semantic-doc-snarf-comment-for-tag' to snarf up
-the comment at point."
- semantic-lex-ignore-whitespace
- semantic-lex-ignore-newline
- semantic-lex-comments
- semantic-lex-default-action)
-
-;;; Test Lexer
-;;
-(define-lex semantic-simple-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-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
-;;; Analyzers generated from grammar.
-;;
-;; Some analyzers are hand written. Analyzers created with these
-;; functions are generated from the grammar files.
-
-(defmacro define-lex-keyword-type-analyzer (name doc syntax)
- "Define a keyword type analyzer NAME with DOC string.
-SYNTAX is the regexp that matches a keyword syntactic expression."
- (declare (indent 1))
- (let ((key (make-symbol "key")))
- `(define-lex-analyzer ,name
- ,doc
- (and (looking-at ,syntax)
- (let ((,key (semantic-lex-keyword-p (match-string 0))))
- (when ,key
- (semantic-lex-push-token
- (semantic-lex-token
- ,key (match-beginning 0) (match-end 0)))))))
- ))
-
-(defmacro define-lex-sexp-type-analyzer (name doc syntax token)
- "Define a sexp type analyzer NAME with DOC string.
-SYNTAX is the regexp that matches the beginning of the s-expression.
-TOKEN is the lexical token returned when SYNTAX matches."
- (declare (indent 1))
- `(define-lex-regex-analyzer ,name
- ,doc
- ,syntax
- (semantic-lex-push-token
- (semantic-lex-token
- ,token (point)
- (save-excursion
- (semantic-lex-unterminated-syntax-protection ,token
- (forward-sexp 1)
- (point))))))
- )
-
-(defmacro define-lex-regex-type-analyzer (name doc syntax matches default)
- "Define a regexp type analyzer NAME with DOC string.
-SYNTAX is the regexp that matches a syntactic expression.
-MATCHES is an alist of lexical elements used to refine the syntactic
-expression.
-DEFAULT is the default lexical token returned when no MATCHES."
- (declare (indent 1))
- (if matches
- (let* ((val (make-symbol "val"))
- (lst (make-symbol "lst"))
- (elt (make-symbol "elt"))
- (pos (make-symbol "pos"))
- (end (make-symbol "end")))
- `(define-lex-analyzer ,name
- ,doc
- (and (looking-at ,syntax)
- (let* ((,val (match-string 0))
- (,pos (match-beginning 0))
- (,end (match-end 0))
- (,lst ,matches)
- ,elt)
- (while (and ,lst (not ,elt))
- (if (string-match (cdar ,lst) ,val)
- (setq ,elt (caar ,lst))
- (setq ,lst (cdr ,lst))))
- (semantic-lex-push-token
- (semantic-lex-token (or ,elt ,default) ,pos ,end))))
- ))
- `(define-lex-simple-regex-analyzer ,name
- ,doc
- ,syntax ,default)
- ))
-
-(defmacro define-lex-string-type-analyzer (name doc syntax matches default)
- "Define a string type analyzer NAME with DOC string.
-SYNTAX is the regexp that matches a syntactic expression.
-MATCHES is an alist of lexical elements used to refine the syntactic
-expression.
-DEFAULT is the default lexical token returned when no MATCHES."
- (declare (indent 1))
- (if matches
- (let* ((val (make-symbol "val"))
- (lst (make-symbol "lst"))
- (elt (make-symbol "elt"))
- (pos (make-symbol "pos"))
- (end (make-symbol "end"))
- (len (make-symbol "len")))
- `(define-lex-analyzer ,name
- ,doc
- (and (looking-at ,syntax)
- (let* ((,val (match-string 0))
- (,pos (match-beginning 0))
- (,end (match-end 0))
- (,len (- ,end ,pos))
- (,lst ,matches)
- ,elt)
- ;; Starting with the longest one, search if a lexical
- ;; value match a token defined for this language.
- (while (and (> ,len 0) (not (setq ,elt (rassoc ,val ,lst))))
- (setq ,len (1- ,len)
- ,val (substring ,val 0 ,len)))
- (when ,elt ;; Adjust token end position.
- (setq ,elt (car ,elt)
- ,end (+ ,pos ,len)))
- (semantic-lex-push-token
- (semantic-lex-token (or ,elt ,default) ,pos ,end))))
- ))
- `(define-lex-simple-regex-analyzer ,name
- ,doc
- ,syntax ,default)
- ))
-
-(defmacro define-lex-block-type-analyzer (name doc syntax matches)
- "Define a block type analyzer NAME with DOC string.
-
-SYNTAX is the regexp that matches block delimiters, typically the
-open (`\\\\s(') and close (`\\\\s)') parenthesis syntax classes.
-
-MATCHES is a pair (OPEN-SPECS . CLOSE-SPECS) that defines blocks.
-
- OPEN-SPECS is a list of (OPEN-DELIM OPEN-TOKEN BLOCK-TOKEN) elements
- where:
-
- OPEN-DELIM is a string: the block open delimiter character.
-
- OPEN-TOKEN is the lexical token class associated to the OPEN-DELIM
- delimiter.
-
- BLOCK-TOKEN is the lexical token class associated to the block
- that starts at the OPEN-DELIM delimiter.
-
- CLOSE-SPECS is a list of (CLOSE-DELIM CLOSE-TOKEN) elements where:
-
- CLOSE-DELIM is a string: the block end delimiter character.
-
- CLOSE-TOKEN is the lexical token class associated to the
- CLOSE-DELIM delimiter.
-
-Each element in OPEN-SPECS must have a corresponding element in
-CLOSE-SPECS.
-
-The lexer will return a BLOCK-TOKEN token when the value of
-`semantic-lex-current-depth' is greater than or equal to the maximum
-depth of parenthesis tracking (see also the function `semantic-lex').
-Otherwise it will return OPEN-TOKEN and CLOSE-TOKEN tokens.
-
-TO DO: Put the following in the developer's guide and just put a
-reference here.
-
-In the grammar:
-
-The value of a block token must be a string that contains a readable
-sexp of the form:
-
- \"(OPEN-TOKEN CLOSE-TOKEN)\"
-
-OPEN-TOKEN and CLOSE-TOKEN represent the block delimiters, and must be
-lexical tokens of respectively `open-paren' and `close-paren' types.
-Their value is the corresponding delimiter character as a string.
-
-Here is a small example to analyze a parenthesis block:
-
- %token <block> PAREN_BLOCK \"(LPAREN RPAREN)\"
- %token <open-paren> LPAREN \"(\"
- %token <close-paren> RPAREN \")\"
-
-When the lexer encounters the open-paren delimiter \"(\":
-
- - If the maximum depth of parenthesis tracking is not reached (that
- is, current depth < max depth), it returns a (LPAREN start . end)
- token, then continue analysis inside the block. Later, when the
- corresponding close-paren delimiter \")\" will be encountered, it
- will return a (RPAREN start . end) token.
-
- - If the maximum depth of parenthesis tracking is reached (current
- depth >= max depth), it returns the whole parenthesis block as
- a (PAREN_BLOCK start . end) token."
- (declare (indent 1))
- (let* ((val (make-symbol "val"))
- (lst (make-symbol "lst"))
- (elt (make-symbol "elt")))
- `(define-lex-analyzer ,name
- ,doc
- (and
- (looking-at ,syntax) ;; "\\(\\s(\\|\\s)\\)"
- (let ((,val (match-string 0))
- (,lst ,matches)
- ,elt)
- (cond
- ((setq ,elt (assoc ,val (car ,lst)))
- (if (or (not semantic-lex-maximum-depth)
- (< semantic-lex-current-depth semantic-lex-maximum-depth))
- (progn
- (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
- (semantic-lex-push-token
- (semantic-lex-token
- (nth 1 ,elt)
- (match-beginning 0) (match-end 0))))
- (semantic-lex-push-token
- (semantic-lex-token
- (nth 2 ,elt)
- (match-beginning 0)
- (save-excursion
- (semantic-lex-unterminated-syntax-protection (nth 2 ,elt)
- (forward-list 1)
- (point)))))))
- ((setq ,elt (assoc ,val (cdr ,lst)))
- (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
- (semantic-lex-push-token
- (semantic-lex-token
- (nth 1 ,elt)
- (match-beginning 0) (match-end 0))))
- ))))
- ))
-\f
-;;; Lexical Safety
-;;
-;; The semantic lexers, unlike other lexers, can throw errors on
-;; unbalanced syntax. Since editing is all about changing text
-;; we need to provide a convenient way to protect against syntactic
-;; inequalities.
-
-(defmacro semantic-lex-catch-errors (symbol &rest forms)
- "Using SYMBOL, execute FORMS catching lexical errors.
-If FORMS results in a call to the parser that throws a lexical error,
-the error will be caught here without the buffer's cache being thrown
-out of date.
-If there is an error, the syntax that failed is returned.
-If there is no error, then the last value of FORMS is returned."
- (declare (indent 1) (debug (symbolp def-body)))
- (let ((ret (make-symbol "ret"))
- (syntax (make-symbol "syntax"))
- (start (make-symbol "start"))
- (end (make-symbol "end")))
- `(let* ((semantic-lex-unterminated-syntax-end-function
- (lambda (,syntax ,start ,end)
- (throw ',symbol ,syntax)))
- (,ret (catch ',symbol
- (save-excursion
- ,@forms
- nil))))
- ;; Great Sadness. Assume that FORMS execute within the
- ;; confines of the current buffer only! Mark this thing
- ;; unparsable iff the special symbol was thrown. This
- ;; will prevent future calls from parsing, but will allow
- ;; then to still return the cache.
- (when ,ret
- ;; Leave this message off. If an APP using this fcn wants
- ;; a message, they can do it themselves. This cleans up
- ;; problems with the idle scheduler obscuring useful data.
- ;;(message "Buffer not currently parsable (%S)." ,ret)
- (semantic-parse-tree-unparseable))
- ,ret)))
-
-\f
-;;; Compatibility with Semantic 1.x lexical analysis
-
-(defvar semantic-flex-tokens semantic-lex-tokens
- "An alist of semantic token types.
-See variable `semantic-lex-tokens'.")
-(make-obsolete-variable 'semantic-flex-tokens
- 'semantic-lex-tokens "28.1")
-
-(defvar semantic-flex-unterminated-syntax-end-function
- (lambda (_syntax _syntax-start flex-end) flex-end)
- "Function called when unterminated syntax is encountered.
-This should be set to one function. That function should take three
-parameters. The SYNTAX, or type of syntax which is unterminated.
-SYNTAX-START where the broken syntax begins.
-FLEX-END is where the lexical analysis was asked to end.
-This function can be used for languages that can intelligently fix up
-broken syntax, or the exit lexical analysis via `throw' or `signal'
-when finding unterminated syntax.")
-(make-obsolete-variable 'semantic-flex-unterminated-syntax-end-function
- nil "28.1")
-
-(defvar-local semantic-flex-extensions nil
- "Buffer local extensions to the lexical analyzer.
-This should contain an alist with a key of a regex and a data element of
-a function. The function should both move point, and return a lexical
-token of the form:
- ( TYPE START . END)
-nil is also a valid return value.
-TYPE can be any type of symbol, as long as it doesn't occur as a
-nonterminal in the language definition.")
-(make-obsolete-variable 'semantic-flex-extensions nil "28.1")
-
-(defvar-local semantic-flex-syntax-modifications nil
- "Changes to the syntax table for this buffer.
-These changes are active only while the buffer is being flexed.
-This is a list where each element has the form:
- (CHAR CLASS)
-CHAR is the char passed to `modify-syntax-entry',
-and CLASS is the string also passed to `modify-syntax-entry' to define
-what syntax class CHAR has.")
-(make-obsolete-variable 'semantic-flex-syntax-modifications nil "28.1")
-
-(defvar-local semantic-ignore-comments t
- "Default comment handling.
-The value t means to strip comments when flexing; nil means
-to keep comments as part of the token stream.")
-(make-obsolete-variable 'semantic-ignore-comments nil "28.1")
-
-(defvar-local semantic-flex-enable-newlines nil
- "When flexing, report newlines as syntactic elements.
-Useful for languages where the newline is a special case terminator.
-Only set this on a per mode basis, not globally.")
-(make-obsolete-variable 'semantic-flex-enable-newlines nil "28.1")
-
-(defvar-local semantic-flex-enable-whitespace nil
- "When flexing, report whitespace as syntactic elements.
-Useful for languages where the syntax is whitespace dependent.
-Only set this on a per mode basis, not globally.")
-(make-obsolete-variable 'semantic-flex-enable-whitespace nil "28.1")
-
-(defvar-local semantic-flex-enable-bol nil
- "When flexing, report beginning of lines as syntactic elements.
-Useful for languages like python which are indentation sensitive.
-Only set this on a per mode basis, not globally.")
-(make-obsolete-variable 'semantic-flex-enable-bol nil "28.1")
-
-(defvar-local semantic-number-expression semantic-lex-number-expression
- "See variable `semantic-lex-number-expression'.")
-(make-obsolete-variable 'semantic-number-expression
- 'semantic-lex-number-expression "28.1")
-
-(defvar-local semantic-flex-depth 0
- "Default flexing depth.
-This specifies how many lists to create tokens in.")
-(make-obsolete-variable 'semantic-flex-depth nil "28.1")
-
-(provide 'semantic/lex)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/lex"
-;; End:
-
-;;; semantic/lex.el ends here
+++ /dev/null
-;;; semantic/mru-bookmark.el --- Automatic bookmark tracking -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Using editing hooks, track the most recently visited or poked tags,
-;; and keep a list of them, with the current point in from, and sorted
-;; by most recently used.
-;;
-;; I envision this would be used in place of switch-buffers once
-;; someone got the hang of it.
-;;
-;; I'd also like to see this used to provide some nice defaults for
-;; other programs where logical destinations or targets are the tags
-;; that have been recently edited.
-;;
-;; Quick Start:
-;;
-;; M-x global-semantic-mru-bookmark-mode RET
-;;
-;; < edit some code >
-;;
-;; C-x B <select a tag name> RET
-;;
-;; In the above, the history is pre-filled with the tags you recently
-;; edited in the order you edited them.
-
-;;; Code:
-
-(require 'semantic)
-(require 'eieio-base)
-(require 'ring)
-
-(declare-function data-debug-new-buffer "data-debug")
-(declare-function data-debug-insert-object-slots "eieio-datadebug")
-(declare-function semantic-momentary-highlight-tag "semantic/decorate")
-(declare-function semantic-tag-similar-p "semantic/tag-ls")
-
-;;; TRACKING CORE
-;;
-;; Data structure for tracking MRU tag locations
-
-(defclass semantic-bookmark (eieio-named)
- ((tag :initarg :tag
- :type semantic-tag
- :documentation "The TAG this bookmark belongs to.")
- (parent :type (or semantic-tag null)
- :documentation "The tag that is the parent of :tag.")
- (offset :type number
- :documentation "The offset from `tag' start that is
-somehow interesting.")
- (filename :type string
- :documentation "String the tag belongs to.
-Set this when the tag gets unlinked from the buffer it belongs to.")
- (frequency :type number
- :initform 0
- :documentation "Track the frequency this tag is visited.")
- (reason :type symbol
- :initform t
- :documentation
- "The reason this tag is interesting.
-Nice values include the following:
- edit - created because the tag text was edited.
- read - created because point lingered in tag text.
- jump - jumped to another tag from this tag.
- mark - created a regular mark in this tag.")
- )
- "A single bookmark.")
-
-(cl-defmethod initialize-instance :after ((sbm semantic-bookmark) &rest _fields)
- "Initialize the bookmark SBM with details about :tag."
- (condition-case nil
- (save-excursion
- (oset sbm filename (semantic-tag-file-name (oref sbm tag)))
- (semantic-go-to-tag (oref sbm tag))
- (oset sbm parent (semantic-current-tag-parent)))
- (error (message "Error bookmarking tag.")))
- )
-
-(cl-defmethod semantic-mrub-visit ((sbm semantic-bookmark))
- "Visit the semantic tag bookmark SBM.
-Uses `semantic-go-to-tag' and highlighting."
- (require 'semantic/decorate)
- (with-slots (tag filename) sbm
- ;; Go to the tag
- (when (not (semantic-tag-in-buffer-p tag))
- (let ((fn (or (semantic-tag-file-name tag)
- filename)))
- (set-buffer (find-file-noselect fn))))
- (semantic-go-to-tag (oref sbm tag) (oref sbm parent))
- ;; Go back to the offset.
- (condition-case nil
- (let ((o (oref sbm offset)))
- (forward-char o))
- (error nil))
- ;; make it visible
- (pop-to-buffer-same-window (current-buffer))
- (semantic-momentary-highlight-tag tag)
- ))
-
-(cl-defmethod semantic-mrub-update ((sbm semantic-bookmark) point reason)
- "Update the existing bookmark SBM.
-POINT is some important location.
-REASON is a symbol. See slot `reason' on `semantic-bookmark'."
- (condition-case nil
- (progn
- (with-slots (tag offset frequency) sbm
- (setq offset (- point (semantic-tag-start tag)))
- (setq frequency (1+ frequency))
- )
- (oset sbm reason reason))
- ;; This can fail on XEmacs at miscellaneous times.
- (error nil))
- )
-
-(cl-defmethod semantic-mrub-preflush ((sbm semantic-bookmark))
- "Method called on a tag before the current buffer list of tags is flushed.
-If there is a buffer match, unlink the tag."
- (let ((tag (oref sbm tag))
- (parent (when (slot-boundp sbm 'parent)
- (oref sbm parent))))
- (let ((b (semantic-tag-in-buffer-p tag)))
- (when (and b (eq b (current-buffer)))
- (semantic--tag-unlink-from-buffer tag)))
-
- (when parent
- (let ((b (semantic-tag-in-buffer-p parent)))
- (when (and b (eq b (current-buffer)))
- (semantic--tag-unlink-from-buffer parent))))))
-
-(defclass semantic-bookmark-ring ()
- ((ring :initarg :ring
- :type ring
- :documentation
- "List of `semantic-bookmark' objects.
-This list is maintained as a list with the first item
-being the current location, and the rest being a list of
-items that were recently visited.")
- (current-index :initform 0
- :type number
- :documentation
- "The current index into RING for some operation.
-User commands use this to move through the ring, or reset.")
- )
- "Track the current MRU stack of bookmarks.
-We can't use the built-in ring data structure because we need
-to delete some items from the ring when we don't have the data.")
-
-(defvar semantic-mru-bookmark-ring (semantic-bookmark-ring
- :ring (make-ring 20))
- "The MRU bookmark ring.
-This ring tracks the most recent active tags of interest.")
-
-(defun semantic-mrub-find-nearby-tag (point)
- "Find a nearby tag to be pushed for this current location.
-Argument POINT is where to find the tag near."
- ;; I thought this was a good idea, but it is not!
- ;;(semantic-fetch-tags) ;; Make sure everything is up-to-date.
- (let ((tag (semantic-current-tag)))
- (when (or (not tag) (semantic-tag-of-class-p tag 'type))
- (let ((nearby (or (semantic-find-tag-by-overlay-next point)
- (semantic-find-tag-by-overlay-prev point))))
- (when nearby (setq tag nearby))))
- tag))
-
-(cl-defmethod semantic-mrub-push ((sbr semantic-bookmark-ring) point
- &optional reason)
- "Add a bookmark to the ring SBR from POINT.
-REASON is why it is being pushed. See doc for `semantic-bookmark'
-for possible reasons.
-The resulting bookmark is then sorted within the ring."
- (let* ((ring (oref sbr ring))
- (tag (semantic-mrub-find-nearby-tag (point)))
- (idx 0))
- (when tag
- (while (and (not (ring-empty-p ring)) (< idx (ring-size ring)))
- (if (semantic-tag-similar-p (oref (ring-ref ring idx) tag)
- tag)
- (ring-remove ring idx))
- (setq idx (1+ idx)))
- ;; Create a new mark
- (let ((sbm (semantic-bookmark (semantic-tag-name tag)
- :tag tag)))
- ;; Take the mark, and update it for the current state.
- (ring-insert ring sbm)
- (semantic-mrub-update sbm point reason))
- )))
-
-(defun semantic-mrub-cache-flush-fcn ()
- "Function called in the `semantic-before-toplevel-cache-flush-hook'.
-Cause tags in the ring to become unlinked."
- (let* ((ring (oref semantic-mru-bookmark-ring ring))
- (len (ring-length ring))
- (idx 0)
- )
- (while (< idx len)
- (semantic-mrub-preflush (ring-ref ring idx))
- (setq idx (1+ idx)))))
-
-(add-hook 'semantic-before-toplevel-cache-flush-hook
- #'semantic-mrub-cache-flush-fcn)
-
-;;; EDIT tracker
-;;
-(defvar semantic-mrub-last-overlay nil
- "The last overlay bumped by `semantic-mru-bookmark-change-hook-fcn'.")
-
-(defun semantic-mru-bookmark-change-hook-fcn (overlay)
- "Function set into `semantic-edits-new/move-change-hook's.
-Argument OVERLAY is the overlay created to mark the change.
-This function pushes tags onto the tag ring."
- ;; Dup?
- (when (not (eq overlay semantic-mrub-last-overlay))
- (setq semantic-mrub-last-overlay overlay)
- (semantic-mrub-push semantic-mru-bookmark-ring
- (point)
- 'edit)))
-
-;;; MINOR MODE
-;;
-;; Tracking minor mode.
-
-(defcustom global-semantic-mru-bookmark-mode nil
- "If non-nil, enable `semantic-mru-bookmark-mode' globally.
-When this mode is enabled, Emacs keeps track of which tags have
-been edited, and you can re-visit them with \\[semantic-mrub-switch-tags]."
- :group 'semantic
- :group 'semantic-modes
- :type 'boolean
- :require 'semantic/util-modes
- :initialize #'custom-initialize-default
- :set (lambda (_sym val)
- (global-semantic-mru-bookmark-mode (if val 1 -1))))
-
-;;;###autoload
-(define-minor-mode global-semantic-mru-bookmark-mode
- "Toggle global use of option `semantic-mru-bookmark-mode'."
- :global t :group 'semantic :group 'semantic-modes
- ;; Not needed because it's autoloaded instead.
- ;; :require 'semantic-util-modes
- (semantic-toggle-minor-mode-globally
- 'semantic-mru-bookmark-mode (if global-semantic-mru-bookmark-mode 1 -1)))
-
-(defcustom semantic-mru-bookmark-mode-hook nil
- "Hook run at the end of function `semantic-mru-bookmark-mode'."
- :group 'semantic
- :type 'hook)
-
-(defvar-keymap semantic-mru-bookmark-mode-map
- :doc "Keymap for mru-bookmark minor mode."
- "C-x B" #'semantic-mrub-switch-tags)
-
-(define-minor-mode semantic-mru-bookmark-mode
- "Minor mode for tracking tag-based bookmarks automatically.
-When this mode is enabled, Emacs keeps track of which tags have
-been edited, and you can re-visit them with \\[semantic-mrub-switch-tags].
-
-\\{semantic-mru-bookmark-mode-map}
-
-The minor mode can be turned on only if semantic feature is
-available and the current buffer was set up for parsing. Return
-non-nil if the minor mode is enabled."
- :keymap semantic-mru-bookmark-mode-map
- (if semantic-mru-bookmark-mode
- (if (not (and (featurep 'semantic) (semantic-active-p)))
- (progn
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-mru-bookmark-mode nil)
- (error "Buffer %s was not set up for parsing"
- (buffer-name)))
- (add-hook 'semantic-edits-new-change-functions
- #'semantic-mru-bookmark-change-hook-fcn nil t)
- (add-hook 'semantic-edits-move-change-hooks
- #'semantic-mru-bookmark-change-hook-fcn nil t))
- ;; Remove hooks
- (remove-hook 'semantic-edits-new-change-functions
- #'semantic-mru-bookmark-change-hook-fcn t)
- (remove-hook 'semantic-edits-move-change-hooks
- #'semantic-mru-bookmark-change-hook-fcn t)))
-
-(semantic-add-minor-mode 'semantic-mru-bookmark-mode
- "k")
-
-;;; COMPLETING READ
-;;
-;; Ask the user for a tag in MRU order.
-(defun semantic-mrub-read-history nil
- "History of `semantic-mrub-completing-read'.")
-
-(defun semantic-mrub-ring-to-assoc-list (ring)
- "Convert RING into an association list for completion."
- (let ((idx 0)
- (len (ring-length ring))
- (al nil))
- (while (< idx len)
- (let ((r (ring-ref ring idx)))
- (setq al (cons (cons (oref r object-name) r)
- al)))
- (setq idx (1+ idx)))
- (nreverse al)))
-
-(defun semantic-mrub-completing-read (prompt)
- "Do a `completing-read' on elements from the mru bookmark ring.
-Argument PROMPT is the prompt to use when reading."
- (if (ring-empty-p (oref semantic-mru-bookmark-ring ring))
- (error "Semantic Bookmark ring is currently empty"))
- (let* ((ring (oref semantic-mru-bookmark-ring ring))
- (ans nil)
- (alist (semantic-mrub-ring-to-assoc-list ring))
- (first (cdr (car alist)))
- (semantic-mrub-read-history nil)
- )
- ;; Don't include the current tag.. only those that come after.
- (if (semantic-equivalent-tag-p (oref first tag)
- (semantic-current-tag))
- (setq first (cdr (car (cdr alist)))))
- ;; Create a fake history list so we don't have to bind
- ;; M-p and M-n to our special cause.
- (let ((elts (reverse alist)))
- (while elts
- (setq semantic-mrub-read-history
- (cons (car (car elts)) semantic-mrub-read-history))
- (setq elts (cdr elts))))
- (setq semantic-mrub-read-history (nreverse semantic-mrub-read-history))
-
- ;; Do the read/prompt
- (let ((prompt (if first (format "%s (%s): " prompt
- (semantic-format-tag-name
- (oref first tag) t)
- )
- (concat prompt ": ")))
- )
- (setq ans
- (completing-read prompt alist nil nil nil 'semantic-mrub-read-history)))
- ;; Calculate the return tag.
- (if (string= ans "")
- (setq ans first)
- ;; Return the bookmark object.
- (setq ans (assoc ans alist))
- (if ans
- (cdr ans)
- ;; no match. Custom word. Look it up somewhere?
- nil)
- )))
-
-(defun semantic-mrub-switch-tags (tagmark)
- "Switch tags to TAGMARK.
-Selects a new tag via prompt through the mru tag ring.
-Jumps to the tag and highlights it briefly."
- (interactive (list (semantic-mrub-completing-read "Switch to tag")))
- (if (not (semantic-bookmark-p tagmark))
- (signal 'wrong-type-argument tagmark))
-
- (semantic-mrub-push semantic-mru-bookmark-ring
- (point)
- 'jump)
- (semantic-mrub-visit tagmark)
- )
-
-;;; Debugging
-;;
-(defun semantic-adebug-mrub ()
- "Display a list of items in the MRU bookmarks list.
-Useful for debugging mrub problems."
- (interactive)
- (require 'eieio-datadebug)
- (let* ((out semantic-mru-bookmark-ring))
- (data-debug-new-buffer "*TAG RING ADEBUG*")
- (data-debug-insert-object-slots out "]")
- ))
-
-
-(provide 'semantic/mru-bookmark)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/mru-bookmark"
-;; End:
-
-;;; semantic/mru-bookmark.el ends here
+++ /dev/null
-;;; semantic/sb.el --- Semantic tag display for speedbar -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Convert a tag table into speedbar buttons.
-
-;;; TODO:
-
-;; Use semanticdb to find which semanticdb-table is being used for each
-;; file/tag. Replace `semantic-sb-with-tag-buffer' to instead call
-;; children with the new `with-mode-local' instead.
-
-(require 'semantic)
-(require 'semantic/format)
-(require 'semantic/sort)
-(require 'semantic/util)
-(require 'speedbar)
-(declare-function semanticdb-file-stream "semantic/db")
-
-(defcustom semantic-sb-autoexpand-length 1
- "Length of a semantic bucket to autoexpand in place.
-This will replace the named bucket that would have usually occurred here."
- :group 'speedbar
- :type 'integer)
-
-(defvar semantic-sb-filter-tags-of-class '(code)
- "Tags classes to not display in speedbar.
-Make this buffer local for modes that have different types of tags
-that should be ignored.")
-
-(defcustom semantic-sb-button-format-tag-function 'semantic-format-tag-abbreviate
- "Function called to create the text for a but from a token."
- :group 'speedbar
- :type semantic-format-tag-custom-list)
-
-(defcustom semantic-sb-info-format-tag-function 'semantic-format-tag-summarize
- "Function called to create the text for info display from a token."
- :group 'speedbar
- :type semantic-format-tag-custom-list)
-
-;;; Code:
-;;
-
-;;; Buffer setting for correct mode manipulation.
-(defun semantic-sb-tag-set-buffer (tag)
- "Set the current buffer to something associated with TAG.
-use the `speedbar-line-file' to get this info if needed."
- (if (semantic-tag-buffer tag)
- (set-buffer (semantic-tag-buffer tag))
- (let ((f (speedbar-line-file)))
- (set-buffer (find-file-noselect f)))))
-
-(defmacro semantic-sb-with-tag-buffer (tag &rest forms)
- "Set the current buffer to the origin of TAG and execute FORMS.
-Restore the old current buffer when completed."
- (declare (indent 1) (debug t))
- `(save-excursion
- (semantic-sb-tag-set-buffer ,tag)
- ,@forms))
-
-;;; Button Generation
-;;
-;; Here are some button groups:
-;;
-;; +> Function ()
-;; @ return_type
-;; +( arg1
-;; +| arg2
-;; +) arg3
-;;
-;; +> Variable[1] =
-;; @ type
-;; = default value
-;;
-;; +> keyword Type
-;; +> type part
-;;
-;; +> -> click to see additional information
-
-(define-overloadable-function semantic-sb-tag-children-to-expand (tag)
- "For TAG, return a list of children that TAG expands to.
-If this returns a value, then a +> icon is created.
-If it returns nil, then a => icon is created.")
-
-(defun semantic-sb-tag-children-to-expand-default (tag)
- "For TAG, the children for type, variable, and function classes."
- (semantic-sb-with-tag-buffer tag
- (semantic-tag-components tag)))
-
-(defun semantic-sb-one-button (tag depth &optional prefix)
- "Insert TAG as a speedbar button at DEPTH.
-Optional PREFIX is used to specify special marker characters."
- (let* ((class (semantic-tag-class tag))
- (edata (semantic-sb-tag-children-to-expand tag))
- (type (semantic-tag-type tag))
- (abbrev (semantic-sb-with-tag-buffer tag
- (funcall semantic-sb-button-format-tag-function tag)))
- (start (point))
- (end (progn
- (insert (int-to-string depth) ":")
- (point))))
- (insert-char ? (1- depth) nil)
- (put-text-property end (point) 'invisible nil)
- ;; take care of edata = (nil) -- a yucky but hard to clean case
- (if (and edata (listp edata) (and (<= (length edata) 1) (not (car edata))))
- (setq edata nil))
- (if (and (not edata)
- (member class '(variable function))
- type)
- (setq edata t))
- ;; types are a bit unique. Variable types can have special meaning.
- (if edata
- (speedbar-insert-button (if prefix (concat " +" prefix) " +>")
- 'speedbar-button-face
- 'speedbar-highlight-face
- 'semantic-sb-show-extra
- tag t)
- (speedbar-insert-button (if prefix (concat " " prefix) " =>")
- nil nil nil nil t))
- (speedbar-insert-button abbrev
- 'speedbar-tag-face
- 'speedbar-highlight-face
- 'semantic-sb-token-jump
- tag t)
- ;; This is very bizarre. When this was just after the insertion
- ;; of the depth: text, the : would get erased, but only for the
- ;; auto-expanded short- buckets. Move back for a later version
- ;; version of Emacs 21 CVS
- (put-text-property start end 'invisible t)
- ))
-
-(defun semantic-sb-speedbar-data-line (depth button text &optional
- text-fun text-data)
- "Insert a semantic token data element.
-DEPTH is the current depth. BUTTON is the text for the button.
-TEXT is the actual info with TEXT-FUN to occur when it happens.
-Argument TEXT-DATA is the token data to pass to TEXT-FUN."
- (let ((start (point))
- (end (progn
- (insert (int-to-string depth) ":")
- (point))))
- (put-text-property start end 'invisible t)
- (insert-char ? depth nil)
- (put-text-property end (point) 'invisible nil)
- (speedbar-insert-button button nil nil nil nil t)
- (speedbar-insert-button text
- 'speedbar-tag-face
- (if text-fun 'speedbar-highlight-face)
- text-fun text-data t)
- ))
-
-(defun semantic-sb-maybe-token-to-button (obj indent &optional
- prefix modifiers)
- "Convert OBJ, which was returned from the semantic parser, into a button.
-This OBJ might be a plain string (simple type or untyped variable)
-or a complete tag.
-Argument INDENT is the indentation used when making the button.
-Optional PREFIX is the character to use when marking the line.
-Optional MODIFIERS is additional text needed for variables."
- (let ((myprefix (or prefix ">")))
- (if (stringp obj)
- (semantic-sb-speedbar-data-line indent myprefix obj)
- (if (listp obj)
- (progn
- (if (and (stringp (car obj))
- (= (length obj) 1))
- (semantic-sb-speedbar-data-line indent myprefix
- (concat
- (car obj)
- (or modifiers "")))
- (semantic-sb-one-button obj indent prefix)))))))
-
-(defun semantic-sb-insert-details (tag indent)
- "Insert details about TAG at level INDENT."
- (let ((tt (semantic-tag-class tag))
- (type (semantic-tag-type tag)))
- (cond ((eq tt 'type)
- (let ((parts (semantic-tag-type-members tag))
- (newparts nil))
- ;; Lets expect PARTS to be a list of either strings,
- ;; or variable tokens.
- (when (semantic-tag-p (car parts))
- ;; Bucketize into groups
- (semantic-sb-with-tag-buffer (car parts)
- (setq newparts (semantic-bucketize parts)))
- (when (> (length newparts) semantic-sb-autoexpand-length)
- ;; More than one bucket, insert inline
- (semantic-sb-insert-tag-table (1- indent) newparts)
- (setq parts nil))
- ;; Dump the strings in.
- (while parts
- (semantic-sb-maybe-token-to-button (car parts) indent)
- (setq parts (cdr parts))))))
- ((eq tt 'variable)
- (if type
- (semantic-sb-maybe-token-to-button type indent "@"))
- (let ((default (semantic-tag-variable-default tag)))
- (if default
- (semantic-sb-maybe-token-to-button default indent "=")))
- )
- ((eq tt 'function)
- (if type
- (semantic-sb-speedbar-data-line
- indent "@"
- (if (stringp type) type
- (semantic-tag-name type))))
- ;; Arguments to the function
- (let ((args (semantic-tag-function-arguments tag)))
- (if (and args (car args))
- (progn
- (semantic-sb-maybe-token-to-button (car args) indent "(")
- (setq args (cdr args))
- (while (> (length args) 1)
- (semantic-sb-maybe-token-to-button (car args)
- indent
- "|")
- (setq args (cdr args)))
- (if args
- (semantic-sb-maybe-token-to-button
- (car args) indent ")"))
- ))))
- (t
- (let ((components
- (save-excursion
- (when (and (semantic-tag-overlay tag)
- (semantic-tag-buffer tag))
- (set-buffer (semantic-tag-buffer tag)))
- (semantic-sb-tag-children-to-expand tag))))
- ;; Well, it wasn't one of the many things we expect.
- ;; Lets just insert them in with no decoration.
- (while components
- (semantic-sb-one-button (car components) indent)
- (setq components (cdr components)))
- ))
- )
- ))
-
-(defun semantic-sb-detail-parent ()
- "Return the first parent token of the current line that includes a location."
- (save-excursion
- (beginning-of-line)
- (let ((dep (if (looking-at "[0-9]+:")
- (1- (string-to-number (match-string 0)))
- 0)))
- (re-search-backward (concat "^"
- (int-to-string dep)
- ":")
- nil t))
- (beginning-of-line)
- (if (looking-at "[0-9]+: +[-+][>()@|] \\([^\n]+\\)$")
- (let ((prop nil))
- (goto-char (match-beginning 1))
- (setq prop (get-text-property (point) 'speedbar-token))
- (if (semantic-tag-with-position-p prop)
- prop
- (semantic-sb-detail-parent)))
- nil)))
-
-(defun semantic-sb-show-extra (text token indent)
- "Display additional information about the token as an expansion.
-TEXT TOKEN and INDENT are the details."
- (cond ((string-search "+" text) ;we have to expand this file
- (speedbar-change-expand-button-char ?-)
- (speedbar-with-writable
- (save-excursion
- (end-of-line) (forward-char 1)
- (save-restriction
- (narrow-to-region (point) (point))
- ;; Add in stuff specific to this type of token.
- (semantic-sb-insert-details token (1+ indent))))))
- ((string-search "-" text) ;we have to contract this node
- (speedbar-change-expand-button-char ?+)
- (speedbar-delete-subblock indent))
- (t (error "Ooops... not sure what to do")))
- (speedbar-center-buffer-smartly))
-
-(defun semantic-sb-token-jump (_text token indent)
- "Jump to the location specified in token.
-TEXT TOKEN and INDENT are the details."
- (let ((file
- (or (speedbar-line-directory indent)
- ;; If speedbar cannot figure this out, extract the filename from
- ;; the token. True for Analysis mode.
- (semantic-tag-file-name token)))
- (parent (semantic-sb-detail-parent)))
- (let ((f (selected-frame)))
- (dframe-select-attached-frame speedbar-frame)
- (run-hooks 'speedbar-before-visiting-tag-hook)
- (select-frame f))
- ;; Sometimes FILE may be nil here. If you are debugging a problem
- ;; when this happens, go back and figure out why FILE is nil and try
- ;; and fix the source.
- (speedbar-find-file-in-frame file)
- (save-excursion (speedbar-stealthy-updates))
- (semantic-go-to-tag token parent)
- (switch-to-buffer (current-buffer))
- ;; Reset the timer with a new timeout when clicking a file
- ;; in case the user was navigating directories, we can cancel
- ;; that other timer.
- ;; (speedbar-set-timer dframe-update-speed)
- ;;(recenter)
- (dframe-maybee-jump-to-attached-frame)
- (run-hooks 'speedbar-visiting-tag-hook)))
-
-(defun semantic-sb-expand-group (text token indent)
- "Expand a group which has semantic tokens.
-TEXT TOKEN and INDENT are the details."
- (cond ((string-search "+" text) ;we have to expand this file
- (speedbar-change-expand-button-char ?-)
- (speedbar-with-writable
- (save-excursion
- (end-of-line) (forward-char 1)
- (save-restriction
- (narrow-to-region (point-min) (point))
- (semantic-sb-buttons-plain (1+ indent) token)))))
- ((string-search "-" text) ;we have to contract this node
- (speedbar-change-expand-button-char ?+)
- (speedbar-delete-subblock indent))
- (t (error "Ooops... not sure what to do")))
- (speedbar-center-buffer-smartly))
-
-(defun semantic-sb-buttons-plain (level tokens)
- "Create buttons at LEVEL using TOKENS."
- (let ((sordid (speedbar-create-tag-hierarchy tokens)))
- (while sordid
- (cond ((null (car-safe sordid)) nil)
- ((consp (car-safe (cdr-safe (car-safe sordid))))
- ;; A group!
- (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group
- (cdr (car sordid))
- (car (car sordid))
- nil nil 'speedbar-tag-face
- level))
- (t ;; Assume that this is a token.
- (semantic-sb-one-button (car sordid) level)))
- (setq sordid (cdr sordid)))))
-
-(defun semantic-sb-insert-tag-table (level table)
- "At LEVEL, insert the tag table TABLE.
-Use arcane knowledge about the semantic tokens in the tagged elements
-to create much wiser decisions about how to sort and group these items."
- (semantic-sb-buttons level table))
-
-(defun semantic-sb-buttons (level lst)
- "Create buttons at LEVEL using LST sorting into type buckets."
- (save-restriction
- (narrow-to-region (point-min) (point))
- (let (tmp)
- (while lst
- (setq tmp (car lst))
- (if (cdr tmp)
- (if (<= (length (cdr tmp)) semantic-sb-autoexpand-length)
- (semantic-sb-buttons-plain (1+ level) (cdr tmp))
- (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group
- (cdr tmp)
- (car (car lst))
- nil nil 'speedbar-tag-face
- (1+ level))))
- (setq lst (cdr lst))))))
-
-(defun semantic-sb-fetch-tag-table (file)
- "Load FILE into a buffer, and generate tags using the Semantic parser.
-Returns the tag list, or t for an error."
- (let ((out nil))
- (if (and (featurep 'semantic/db)
- (semanticdb-minor-mode-p)
- (not speedbar-power-click)
- ;; If the database is loaded and running, try to get
- ;; tokens from it.
- (setq out (semanticdb-file-stream file)))
- ;; Successful DB query.
- nil
- ;; No database, do it the old way.
- (with-current-buffer (find-file-noselect file)
- (if (or (not (featurep 'semantic))
- (not semantic--parse-table))
- (setq out t)
- (if speedbar-power-click (semantic-clear-toplevel-cache))
- (setq out (semantic-fetch-tags)))))
- (if (listp out)
- (condition-case nil
- (progn
- ;; This brings externally defined methods into
- ;; their classes, and creates meta classes for
- ;; orphans.
- (setq out (semantic-adopt-external-members out))
- ;; Dump all the tokens into buckets.
- (semantic-sb-with-tag-buffer (car out)
- (semantic-bucketize out nil
- (lambda (tagsin)
- ;; Remove all boring tags.
- (semantic-filter-tags-by-class
- semantic-sb-filter-tags-of-class
- tagsin)))))
- (error t))
- t)))
-
-;; Link ourselves into the tagging process.
-(add-to-list 'speedbar-dynamic-tags-function-list
- '(semantic-sb-fetch-tag-table . semantic-sb-insert-tag-table))
-
-(provide 'semantic/sb)
-
-;; Local variables:
-;; generated-autoload-load-name: "semantic/sb"
-;; End:
-
-;;; semantic/sb.el ends here
+++ /dev/null
-;;; semantic/scope.el --- Analyzer Scope Calculations -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Calculate information about the current scope.
-;;
-;; Manages the current scope as a structure that can be cached on a
-;; per-file basis and recycled between different occurrences of
-;; analysis on different parts of a file.
-;;
-;; Pattern for Scope Calculation
-;;
-;; Step 1: Calculate DataTypes in Scope:
-;;
-;; a) What is in scope via using statements or local namespaces
-;; b) Lineage of current context. Some names drawn from step 1.
-;;
-;; Step 2: Convert type names into lists of concrete tags
-;;
-;; a) Convert each datatype into the real datatype tag
-;; b) Convert namespaces into the list of contents of the namespace.
-;; c) Merge all existing scopes together into one search list.
-;;
-;; Step 3: Local variables
-;;
-;; a) Local variables are in the master search list.
-;;
-
-(require 'semantic/db)
-(require 'semantic/analyze/fcn)
-(require 'semantic/ctxt)
-
-(eval-when-compile (require 'semantic/find))
-
-(declare-function data-debug-show "eieio-datadebug")
-(declare-function semantic-analyze-find-tag "semantic/analyze")
-(declare-function semantic-analyze-princ-sequence "semantic/analyze")
-(declare-function semanticdb-typecache-merge-streams "semantic/db-typecache")
-(declare-function semanticdb-typecache-add-dependant "semantic/db-typecache")
-(declare-function semantic-tag-similar-p "semantic/tag-ls")
-
-;;; Code:
-
-(defclass semantic-scope-cache (semanticdb-abstract-cache)
- ((tag :initform nil
- :documentation
- "The tag this scope was calculated for.")
- (scopetypes :initform nil
- :documentation
- "The list of types currently in scope.
-For C++, this would contain anonymous namespaces known, and
-anything labeled by a `using' statement.")
- (parents :initform nil
- :documentation
- "List of parents in scope w/in the body of this function.
-Presumably, the members of these parent classes are available for access
-based on private:, or public: style statements.")
- (parentinheritance :initform nil
- :documentation "Alist of parents by inheritance.
-Each entry is ( PARENT . PROTECTION ), where PARENT is a type, and
-PROTECTION is a symbol representing the level of inheritance, such as 'private, or 'protected.")
- (scope :initform nil
- :documentation
- "Items in scope due to the scopetypes or parents.")
- (fullscope :initform nil
- :documentation
- "All the other stuff on one master list you can search.")
- (localargs :initform nil
- :documentation
- "The arguments to the function tag.")
- (localvar :initform nil
- :documentation
- "The local variables.")
- (typescope :initform nil
- :documentation
- "Slot to save intermediate scope while metatypes are dereferenced.")
- )
- "Cache used for storage of the current scope by the Semantic Analyzer.
-Saves scoping information between runs of the analyzer.")
-
-;;; METHODS
-;;
-;; Methods for basic management of the structure in semanticdb.
-;;
-(cl-defmethod semantic-reset ((obj semantic-scope-cache))
- "Reset OBJ back to it's empty settings."
- (oset obj tag nil)
- (oset obj scopetypes nil)
- (oset obj parents nil)
- (oset obj parentinheritance nil)
- (oset obj scope nil)
- (oset obj fullscope nil)
- (oset obj localargs nil)
- (oset obj localvar nil)
- (oset obj typescope nil)
- )
-
-(cl-defmethod semanticdb-synchronize ((cache semantic-scope-cache)
- _new-tags)
- "Synchronize a CACHE with some NEW-TAGS."
- (semantic-reset cache))
-
-
-(cl-defmethod semanticdb-partial-synchronize ((cache semantic-scope-cache)
- new-tags)
- "Synchronize a CACHE with some changed NEW-TAGS."
- ;; If there are any includes or datatypes changed, then clear.
- (if (or (semantic-find-tags-by-class 'include new-tags)
- (semantic-find-tags-by-class 'type new-tags)
- (semantic-find-tags-by-class 'using new-tags))
- (semantic-reset cache))
- )
-
-(defun semantic-scope-reset-cache ()
- "Get the current cached scope, and reset it."
- (when semanticdb-current-table
- (let ((co (semanticdb-cache-get semanticdb-current-table
- 'semantic-scope-cache)))
- (semantic-reset co))))
-
-(cl-defmethod semantic-scope-set-typecache ((cache semantic-scope-cache)
- types-in-scope)
- "Set the :typescope property on CACHE to some types.
-TYPES-IN-SCOPE is a list of type tags whose members are
-currently in scope. For each type in TYPES-IN-SCOPE,
-add those members to the types list.
-If nil, then the typescope is reset."
- (let ((newts nil)) ;; New Type Scope
- (dolist (onetype types-in-scope)
- (setq newts (append (semantic-tag-type-members onetype)
- newts))
- )
- (oset cache typescope newts)))
-
-;;; TAG SCOPES
-;;
-;; These fcns should be used by search routines that return a single
-;; tag which, in turn, may have come from a deep scope. The scope
-;; will be attached to the tag. Thus, in future scope based calls, a
-;; tag can be passed in and a scope derived from it.
-
-(defun semantic-scope-tag-clone-with-scope (tag scopetags)
- "Clone TAG, and return it. Add SCOPETAGS as a tag-local scope.
-Stores the SCOPETAGS as a set of tag properties on the cloned tag."
- (let ((clone (semantic-tag-clone tag))
- )
- (semantic--tag-put-property clone 'scope scopetags)
- ))
-
-(defun semantic-scope-tag-get-scope (tag)
- "Get from TAG the list of tags comprising the scope from TAG."
- (semantic--tag-get-property tag 'scope))
-
-;;; SCOPE UTILITIES
-;;
-;; Functions that do the main scope calculations
-
-
-(define-overloadable-function semantic-analyze-scoped-types (position)
- "Return a list of types currently in scope at POSITION.
-This is based on what tags exist at POSITION, and any associated
-types available.")
-
-(defun semantic-analyze-scoped-types-default (position)
- "Return a list of types currently in scope at POSITION.
-Use `semantic-ctxt-scoped-types' to find types."
- (require 'semantic/db-typecache)
- (save-excursion
- (goto-char position)
- (let ((code-scoped-types nil))
- ;; Let's ask if any types are currently scoped. Scoped
- ;; classes and types provide their public methods and types
- ;; in source code, but are unrelated hierarchically.
- (let ((sp (semantic-ctxt-scoped-types)))
- (while sp
- ;; Get this thing as a tag
- (let ((tmp (cond
- ((stringp (car sp))
- (or (semanticdb-typecache-find (car sp))
- ;; If we did not find it in the typecache,
- ;; look in the tags we found so far
- (car (semantic-deep-find-tags-by-name
- (car sp)
- code-scoped-types))))
- ((semantic-tag-p (car sp))
- (if (semantic-tag-prototype-p (car sp))
- (or (semanticdb-typecache-find (semantic-tag-name (car sp)))
- (car (semantic-deep-find-tags-by-name
- (semantic-tag-name (car sp))
- code-scoped-types)))
- (car sp)))
- (t nil))))
- (when tmp
- (setq code-scoped-types
- (cons tmp code-scoped-types))))
- (setq sp (cdr sp))))
- (setq code-scoped-types (nreverse code-scoped-types))
-
- (when code-scoped-types
- (semanticdb-typecache-merge-streams code-scoped-types nil))
-
- )))
-
-;;------------------------------------------------------------
-(define-overloadable-function semantic-analyze-scope-nested-tags (position scopedtypes)
- "Return a list of types in order of nesting for the context of POSITION.
-If POSITION is in a method with a named parent, find that parent, and
-identify it's scope via overlay instead.
-Optional SCOPETYPES are additional scoped entities in which our parent might
-be found.")
-
-(defun semantic-analyze-scope-nested-tags-default (position scopetypes)
- "Return a list of types in order of nesting for the context of POSITION.
-If POSITION is in a method with a named parent, find that parent, and
-identify it's scope via overlay instead.
-Optional SCOPETYPES are additional scoped entities in which our parent might
-be found.
-This only finds ONE immediate parent by name. All other parents returned
-are from nesting data types."
- (require 'semantic/analyze)
- (save-excursion
- (if position (goto-char position))
- (let* ((stack (reverse (semantic-find-tag-by-overlay (point))))
- (tag (car stack))
- (pparent (car (cdr stack)))
- (returnlist nil)
- )
- ;; In case of arg lists or some-such, throw out non-types.
- (while (and stack (not (semantic-tag-of-class-p pparent 'type)))
- (setq stack (cdr stack) pparent (car (cdr stack))))
-
- ;; Remove duplicates
- (while (member pparent scopetypes)
- (setq stack (cdr stack) pparent (car (cdr stack))))
-
- ;; Step 1:
- ;; Analyze the stack of tags we are nested in as parents.
- ;;
-
- ;; If we have a pparent tag, let's go there
- ;; an analyze that stack of tags.
- (when (and pparent (semantic-tag-with-position-p pparent))
- (semantic-go-to-tag pparent)
- (setq stack (semantic-find-tag-by-overlay (point)))
- ;; Step one, find the merged version of stack in the typecache.
- (let* ((stacknames (reverse (mapcar #'semantic-tag-name stack)))
- (tc nil)
- )
- ;; @todo - can we use the typecache ability to
- ;; put a scope into a tag to do this?
- (while (and stacknames
- (setq tc (semanticdb-typecache-find
- (reverse stacknames))))
- (setq returnlist (cons tc returnlist)
- stacknames (cdr stacknames)))
- (when (not returnlist)
- ;; When there was nothing from the typecache, then just
- ;; use what's right here.
- (setq stack (reverse stack))
- ;; Add things to STACK until we cease finding tags of class type.
- (while (and stack (eq (semantic-tag-class (car stack)) 'type))
- ;; Otherwise, just add this to the returnlist, but make
- ;; sure we didn't already have that tag in scopetypes
- (unless (member (car stack) scopetypes)
- (setq returnlist (cons (car stack) returnlist)))
- (setq stack (cdr stack)))
-
- (setq returnlist (nreverse returnlist))
- ))
- )
-
- ;; Only do this level of analysis for functions.
- (when (eq (semantic-tag-class tag) 'function)
- ;; Step 2:
- ;; If the function tag itself has a "parent" by name, then that
- ;; parent will exist in the scope we just calculated, so look it
- ;; up now.
- ;;
- (let ((p (semantic-tag-function-parent tag)))
- (when p
- ;; We have a parent, search for it.
- (let* ((searchnameraw (cond ((stringp p) p)
- ((semantic-tag-p p)
- (semantic-tag-name p))
- ((and (listp p) (stringp (car p)))
- (car p))))
- (searchname (semantic-analyze-split-name searchnameraw))
- (snlist (if (consp searchname)
- searchname
- (list searchname)))
- (fullsearchname nil)
-
- (miniscope (semantic-scope-cache))
- ptag)
-
- ;; Find the next entry in the referenced type for
- ;; our function, and append to return list till our
- ;; returnlist is empty.
- (while snlist
- (setq fullsearchname
- (append (mapcar #'semantic-tag-name returnlist)
- (list (car snlist)))) ;; Next one
- (setq ptag
- (semanticdb-typecache-find fullsearchname))
-
- (when (or (not ptag)
- (not (semantic-tag-of-class-p ptag 'type)))
- (let ((rawscope
- (apply #'append
- (mapcar #'semantic-tag-type-members
- (cons (car returnlist) scopetypes)
- )))
- )
- (oset miniscope parents returnlist) ;; Not really accurate, but close
- (oset miniscope scope rawscope)
- (oset miniscope fullscope rawscope)
- (setq ptag
- (semantic-analyze-find-tag searchnameraw
- 'type
- miniscope
- ))
- ))
-
- (when ptag
- (when (and (not (semantic-tag-p ptag))
- (semantic-tag-p (car ptag)))
- (setq ptag (car ptag)))
- (setq returnlist (append returnlist (list ptag)))
- )
-
- (setq snlist (cdr snlist)))
- (setq returnlist returnlist)
- )))
- )
- returnlist
- )))
-
-(define-overloadable-function semantic-analyze-scope-lineage-tags (parents scopedtypes)
- "Return the full lineage of tags from PARENTS.
-The return list is of the form ( TAG . PROTECTION ), where TAG is a tag,
-and PROTECTION is the level of protection offered by the relationship.
-Optional SCOPETYPES are additional scoped entities in which our parent might
-be found.")
-
-(defun semantic-analyze-scope-lineage-tags-default (parents scopetypes)
- "Return the full lineage of tags from PARENTS.
-The return list is of the form ( TAG . PROTECTION ), where TAG is a tag,
-and PROTECTION is the level of protection offered by the relationship.
-Optional SCOPETYPES are additional scoped entities in which our parent might
-be found."
- (let ((lineage nil)
- (miniscope (semantic-scope-cache))
- )
- (oset miniscope parents parents)
- (oset miniscope scope scopetypes)
- (oset miniscope fullscope scopetypes)
-
- (dolist (slp parents)
- (semantic-analyze-scoped-inherited-tag-map
- slp (lambda (newparent)
- (let* ((pname (semantic-tag-name newparent))
- (prot (semantic-tag-type-superclass-protection slp pname))
- (effectiveprot (cond ((eq prot 'public)
- ;; doesn't provide access to private slots?
- 'protected)
- (t prot))))
- (push (cons newparent effectiveprot) lineage)
- ))
- miniscope))
-
- lineage))
-
-
-;;------------------------------------------------------------
-
-(define-overloadable-function semantic-analyze-scoped-tags (typelist parentlist)
- "Return accessible tags when TYPELIST and PARENTLIST is in scope.
-Tags returned are not in the global name space, but are instead
-scoped inside a class or namespace. Such items can be referenced
-without use of \"object.function()\" style syntax due to an
-implicit \"object\".")
-
-(defun semantic-analyze-scoped-tags-default (typelist halfscope)
- "Return accessible tags when TYPELIST and HALFSCOPE is in scope.
-HALFSCOPE is the current scope partially initialized.
-Tags returned are not in the global name space, but are instead
-scoped inside a class or namespace. Such items can be referenced
-without use of \"object.function()\" style syntax due to an
-implicit \"object\"."
- (let ((typelist2 nil)
- (currentscope nil)
- (parentlist (oref halfscope parents))
- (miniscope halfscope)
- )
- ;; Loop over typelist, and find and merge all namespaces matching
- ;; the names in typelist.
- (while typelist
- (let ((tt (semantic-tag-type (car typelist))))
- (when (and (stringp tt) (string= tt "namespace"))
- ;; By using the typecache, our namespaces are pre-merged.
- (setq typelist2 (cons (car typelist) typelist2))
- ))
- (setq typelist (cdr typelist)))
-
- ;; Loop over the types (which should be sorted by position)
- ;; adding to the scopelist as we go, and using the scopelist
- ;; for additional searching!
- (while typelist2
- (oset miniscope scope currentscope)
- (oset miniscope fullscope currentscope)
- (setq currentscope (append
- (semantic-analyze-scoped-type-parts (car typelist2)
- miniscope)
- currentscope))
- (setq typelist2 (cdr typelist2)))
-
- ;; Collect all the types (class, etc) that are in our heritage.
- ;; These are types that we can extract members from, not those
- ;; declared in using statements, or the like.
- ;; Get the PARENTS including nesting scope for this location.
- (while parentlist
- (oset miniscope scope currentscope)
- (oset miniscope fullscope currentscope)
- (setq currentscope (append
- (semantic-analyze-scoped-type-parts (car parentlist)
- miniscope)
- currentscope))
- (setq parentlist (cdr parentlist)))
-
- ;; Loop over all the items, and collect any type constants.
- (let ((constants nil))
- (dolist (T currentscope)
- (setq constants (append constants
- (semantic-analyze-type-constants T)))
- )
-
- (setq currentscope (append currentscope constants)))
-
- currentscope))
-
-;;------------------------------------------------------------
-(define-overloadable-function semantic-analyze-scope-calculate-access (type scope)
- "Calculate the access class for TYPE as defined by the current SCOPE.
-Access is related to the :parents in SCOPE. If type is a member of SCOPE
-then access would be `private'. If TYPE is inherited by a member of SCOPE,
-the access would be `protected'. Otherwise, access is `public'.")
-
-(defun semantic-analyze-scope-calculate-access-default (type scope)
- "Calculate the access class for TYPE as defined by the current SCOPE."
- (cond ((semantic-scope-cache-p scope)
- (let ((parents (oref scope parents))
- (parentsi (oref scope parentinheritance))
- )
- (catch 'moose
- ;; Investigate the parent, and see how it relates to type.
- ;; If these tags are basically the same, then we have full access.
- (dolist (p parents)
- (when (semantic-tag-similar-p type p)
- (throw 'moose 'private))
- )
- ;; Look to see if type is in our list of inherited parents.
- (dolist (pi parentsi)
- ;; pi is a cons cell ( PARENT . protection)
- (let ((pip (car pi))
- (piprot (cdr pi)))
- (when (semantic-tag-similar-p type pip)
- (throw 'moose
- ;; protection via inheritance means to pull out different
- ;; bits based on protection labels in an opposite way.
- (cdr (assoc piprot
- '((public . private)
- (protected . protected)
- (private . public))))
- )))
- )
- ;; Not in our parentage. Is type a FRIEND?
- (let ((friends (semantic-find-tags-by-class 'friend (semantic-tag-type-members type))))
- (dolist (F friends)
- (dolist (pi parents)
- (if (string= (semantic-tag-name F) (semantic-tag-name pi))
- (throw 'moose 'private))
- )))
- ;; Found nothing, return public
- 'public)
- ))
- (t 'public)))
-
-(defun semantic-completable-tags-from-type (type)
- "Return a list of slots that are valid completions from the list of SLOTS.
-If a tag in SLOTS has a named parent, then that implies that the
-tag is not something you can complete from within TYPE."
- (let ((allslots (semantic-tag-components type))
- (leftover nil)
- )
- (dolist (S allslots)
- ;; We have to specially deal with 'using' tags here, since those
- ;; pull in namespaces or classes into the current scope.
- ;; (Should this go into c.el? If so, into which override?)
- (if (semantic-tag-of-class-p S 'using)
- (let* ((fullname (semantic-analyze-unsplit-name
- (list (semantic-tag-name type)
- (semantic-tag-name S))))
- ;; Search the typecache, first for the unqualified name
- (usingtype (or
- (semanticdb-typecache-find (semantic-tag-name S))
- ;; If that didn't return anything, use
- ;; fully qualified name
- (semanticdb-typecache-find fullname)))
- (filename (when usingtype (semantic-tag-file-name usingtype))))
- (when usingtype
- ;; Use recursion to examine that namespace or class
- (let ((tags (semantic-completable-tags-from-type usingtype)))
- (if filename
- ;; If we have a filename, copy the tags with it
- (dolist (cur tags)
- (setq leftover (cons (semantic-tag-copy cur nil filename)
- leftover)))
- ;; Otherwise just run with it
- (setq leftover (append tags leftover))))))
- (when (or (not (semantic-tag-of-class-p S 'function))
- (not (semantic-tag-function-parent S)))
- (setq leftover (cons S leftover)))))
- (nreverse leftover)))
-
-(defun semantic-analyze-scoped-type-parts (type &optional scope noinherit _protection)
- "Return all parts of TYPE, a tag representing a TYPE declaration.
-SCOPE is the scope object.
-NOINHERIT turns off searching of inherited tags.
-PROTECTION specifies the type of access requested,
-such as `public' or `private'."
- (if (not type)
- nil
- (let* ((access (semantic-analyze-scope-calculate-access type scope))
- ;; SLOTS are the slots directly a part of TYPE.
- (allslots (semantic-completable-tags-from-type type))
- (slots (semantic-find-tags-by-scope-protection
- access
- type allslots))
- (fname (semantic-tag-file-name type))
- ;; EXTMETH are externally defined methods that are still
- ;; a part of this class.
-
- ;; @TODO - is this line needed?? Try w/out for a while
- ;; @note - I think C++ says no. elisp might, but methods
- ;; look like defuns, so it makes no difference.
- ;;(extmeth nil) ; (semantic-tag-external-member-children type t))
-
- ;; INHERITED are tags found in classes that our TYPE tag
- ;; inherits from. Do not do this if it was not requested.
- (inherited (when (not noinherit)
- (semantic-analyze-scoped-inherited-tags type scope
- access)))
- )
- (when (not (semantic-tag-in-buffer-p type))
- (let ((copyslots nil))
- (dolist (TAG slots)
- ;;(semantic--tag-put-property TAG :filename fname)
- (if (semantic-tag-file-name TAG)
- ;; If it has a filename, just go with it...
- (setq copyslots (cons TAG copyslots))
- ;; Otherwise, copy the tag with the guessed filename.
- (setq copyslots (cons (semantic-tag-copy TAG nil fname)
- copyslots)))
- )
- (setq slots (nreverse copyslots))
- ))
- ;; Flatten the database output.
- (append slots nil inherited) ;; extmeth
- )))
-
-(defun semantic-analyze-scoped-inherited-tags (type scope access)
- "Return all tags that TYPE inherits from.
-Argument SCOPE specify additional tags that are in scope
-whose tags can be searched when needed, OR it may be a scope object.
-ACCESS is the level of access we filter on child supplied tags.
-For languages with protection on specific methods or slots,
-it should strip out those not accessible by methods of TYPE.
-An ACCESS of `public' means not in a method of a subclass of type.
-A value of `private' means we can access private parts of the originating
-type."
- (let ((ret nil))
- (semantic-analyze-scoped-inherited-tag-map
- type (lambda (p)
- (let* ((pname (semantic-tag-name p))
- (protection (semantic-tag-type-superclass-protection
- type pname))
- )
- (if (and (eq access 'public) (not (eq protection 'public)))
- nil ;; Don't do it.
-
- ;; We can get some parts of this type.
- (setq ret (nconc ret
- ;; Do not pull in inherited parts here. Those
- ;; will come via the inherited-tag-map fcn
- (semantic-analyze-scoped-type-parts
- p scope t protection))
- ))))
- scope)
- ret))
-
-(defun semantic-analyze-scoped-inherited-tag-map (type fcn scope)
- "Map all parents of TYPE to FCN. Return tags of all the types.
-Argument SCOPE specify additional tags that are in scope
-whose tags can be searched when needed, OR it may be a scope object."
- (require 'semantic/analyze)
- (let* (;; PARENTS specifies only the superclasses and not
- ;; interfaces. Inheriting from an interfaces implies
- ;; you have a copy of all methods locally. I think.
- (parents (semantic-tag-type-superclasses type))
- ps pt
- (tmpscope scope)
- )
- (save-excursion
-
- ;; Create a SCOPE just for looking up the parent based on where
- ;; the parent came from.
- ;;
- ;; @TODO - Should we cache these mini-scopes around in Emacs
- ;; for recycling later? Should this become a helpful
- ;; extra routine?
- (when (and parents (semantic-tag-with-position-p type))
- (save-excursion
- ;; If TYPE has a position, go there and get the scope.
- (semantic-go-to-tag type)
-
- ;; We need to make a mini scope, and only include the misc bits
- ;; that will help in finding the parent. We don't really need
- ;; to do any of the stuff related to variables and what-not.
- (setq tmpscope (semantic-scope-cache))
- (let* ( ;; Step 1:
- (scopetypes (cons type (semantic-analyze-scoped-types (point))))
- (parents (semantic-analyze-scope-nested-tags (point) scopetypes))
- ;;(parentinherited (semantic-analyze-scope-lineage-tags parents scopetypes))
- (lscope nil)
- )
- (oset tmpscope scopetypes scopetypes)
- (oset tmpscope parents parents)
- ;;(oset tmpscope parentinheritance parentinherited)
-
- (when (or scopetypes parents)
- (setq lscope (semantic-analyze-scoped-tags scopetypes tmpscope))
- (oset tmpscope scope lscope))
- (oset tmpscope fullscope (append scopetypes lscope parents))
- )))
- ;; END creating tmpscope
-
- ;; Look up each parent one at a time.
- (dolist (p parents)
- (setq ps (cond ((stringp p) p)
- ((and (semantic-tag-p p) (semantic-tag-prototype-p p))
- (semantic-tag-name p))
- ((and (listp p) (stringp (car p)))
- p))
- pt (condition-case nil
- (or (semantic-analyze-find-tag ps 'type tmpscope)
- ;; A backup hack.
- (semantic-analyze-find-tag ps 'type scope))
- (error nil)))
-
- (when pt
- (funcall fcn pt)
- ;; Note that we pass the original SCOPE in while recursing.
- ;; so that the correct inheritance model is passed along.
- (semantic-analyze-scoped-inherited-tag-map pt fcn scope)
- )))
- nil))
-
-;;; ANALYZER
-;;
-;; Create the scope structure for use in the Analyzer.
-;;
-;;;###autoload
-(defun semantic-calculate-scope (&optional point)
- "Calculate the scope at POINT.
-If POINT is not provided, then use the current location of point.
-The class returned from the scope calculation is variable
-`semantic-scope-cache'."
- (interactive)
- (if (not (and (featurep 'semantic/db) semanticdb-current-database))
- nil ;; Don't do anything...
- (require 'semantic/db-typecache)
- (if (not point) (setq point (point)))
- (when (called-interactively-p 'any)
- (semantic-fetch-tags)
- (semantic-scope-reset-cache))
- (save-excursion
- (goto-char point)
- (let* ((TAG (semantic-current-tag))
- (scopecache
- (semanticdb-cache-get semanticdb-current-table
- 'semantic-scope-cache))
- )
- (when (not (semantic-equivalent-tag-p TAG (oref scopecache tag)))
- (semantic-reset scopecache))
- (if (oref scopecache tag)
- ;; Even though we can recycle most of the scope, we
- ;; need to redo the local variables since those change
- ;; as you move about the tag.
- (condition-case nil
- (oset scopecache localvar (semantic-get-all-local-variables))
- (error nil))
-
- (let* (;; Step 1:
- (scopetypes (semantic-analyze-scoped-types point))
- (parents (semantic-analyze-scope-nested-tags point scopetypes))
- (parentinherited (semantic-analyze-scope-lineage-tags
- parents scopetypes))
- )
- (oset scopecache tag TAG)
- (oset scopecache scopetypes scopetypes)
- (oset scopecache parents parents)
- (oset scopecache parentinheritance parentinherited)
-
- (let* (;; Step 2:
- (scope (when (or scopetypes parents)
- (semantic-analyze-scoped-tags scopetypes scopecache))
- )
- ;; Step 3:
- (localargs (semantic-get-local-arguments))
- (localvar (condition-case nil
- (semantic-get-all-local-variables)
- (error nil)))
- )
-
- ;; Try looking for parents again.
- (when (not parentinherited)
- (setq parentinherited (semantic-analyze-scope-lineage-tags
- parents (append scopetypes scope)))
- (when parentinherited
- (oset scopecache parentinheritance parentinherited)
- ;; Try calculating the scope again with the new inherited parent list.
- (setq scope (when (or scopetypes parents)
- (semantic-analyze-scoped-tags scopetypes scopecache))
- )))
-
- ;; Fill out the scope.
- (oset scopecache scope scope)
- (oset scopecache fullscope (append scopetypes scope parents))
- (oset scopecache localargs localargs)
- (oset scopecache localvar localvar)
- )))
- ;; Make sure we become dependent on the typecache.
- (semanticdb-typecache-add-dependant scopecache)
- ;; Handy debug output.
- (when (called-interactively-p 'any)
- (require 'eieio-datadebug)
- (data-debug-show scopecache))
- ;; Return ourselves, but make a clone first so that the caller
- ;; can reset the scope cache without affecting others.
- (clone scopecache)))))
-
-(defun semantic-scope-find (name &optional class scope-in)
- "Find the tag with NAME, and optional CLASS in the current SCOPE-IN.
-Searches various elements of the scope for NAME. Return ALL the
-hits in order, with the first tag being in the closest scope."
- (let ((scope (or scope-in (semantic-calculate-scope)))
- (ans nil))
- ;; Is the passed in scope really a scope? if so, look through
- ;; the options in that scope.
- (if (semantic-scope-cache-p scope)
- (let* ((la
- ;; This should be first, but bugs in the
- ;; C parser will turn function calls into
- ;; assumed int return function prototypes. Yuck!
- (semantic-find-tags-by-name name (oref scope localargs)))
- (lv
- (semantic-find-tags-by-name name (oref scope localvar)))
- (fullscoperaw (oref scope fullscope))
- (sc (semantic-find-tags-by-name name fullscoperaw))
- (typescoperaw (oref scope typescope))
- (tsc (semantic-find-tags-by-name name typescoperaw))
- )
- (setq ans
- (if class
- ;; Scan out things not of the right class.
- (semantic-find-tags-by-class class (append la lv sc tsc))
- (append la lv sc tsc))
- )
-
- (when (and (not ans) (or typescoperaw fullscoperaw))
- (let ((namesplit (semantic-analyze-split-name name)))
- (when (consp namesplit)
- ;; It may be we need to hack our way through type typescope.
- (while namesplit
- (setq ans (append
- (semantic-find-tags-by-name (car namesplit)
- typescoperaw)
- (semantic-find-tags-by-name (car namesplit)
- fullscoperaw)
- ))
- (if (not ans)
- (setq typescoperaw nil)
- (when (cdr namesplit)
- (setq typescoperaw (semantic-tag-type-members
- (car ans)))))
-
- (setq namesplit (cdr namesplit)))
- ;; Once done, store the current typecache lookup
- (oset scope typescope
- (append typescoperaw (oref scope typescope)))
- )))
- ;; Return it.
- ans)
- ;; Not a real scope. Our scope calculation analyze parts of
- ;; what it finds, and needs to pass lists through to do it's work.
- ;; Treat that list as a singly entry.
- (if class
- (semantic-find-tags-by-class class scope)
- scope)
- )))
-
-;;; DUMP
-;;
-(cl-defmethod semantic-analyze-show ((context semantic-scope-cache))
- "Insert CONTEXT into the current buffer in a nice way."
- (require 'semantic/analyze)
- (semantic-analyze-princ-sequence (oref context scopetypes) "-> ScopeTypes: " )
- (semantic-analyze-princ-sequence (oref context parents) "-> Parents: " )
- (semantic-analyze-princ-sequence (oref context scope) "-> Scope: " )
- ;;(semantic-analyze-princ-sequence (oref context fullscope) "Fullscope: " )
- (semantic-analyze-princ-sequence (oref context localargs) "-> Local Args: " )
- (semantic-analyze-princ-sequence (oref context localvar) "-> Local Vars: " )
- )
-
-(provide 'semantic/scope)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/scope"
-;; End:
-
-;;; semantic/scope.el ends here
+++ /dev/null
-;;; semantic/senator.el --- SEmantic NAvigaTOR -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000-2024 Free Software Foundation, Inc.
-
-;; Author: David Ponce <david@dponce.com>
-;; Maintainer: emacs-devel@gnu.org
-;; Created: 10 Nov 2000
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; This file defines some user commands for navigating between
-;; Semantic tags. This is a subset of the version of senator.el in
-;; the upstream CEDET package; the rest is incorporated into other
-;; parts of Semantic or Emacs.
-
-;;; Code:
-
-(require 'ring)
-(require 'semantic)
-(require 'semantic/ctxt)
-(require 'semantic/decorate)
-(require 'semantic/format)
-(require 'semantic/analyze)
-
-(eval-when-compile (require 'semantic/find))
-
-;; (eval-when-compile (require 'hippie-exp))
-
-(declare-function semantic-analyze-tag-references "semantic/analyze/refs")
-(declare-function semantic-analyze-refs-impl "semantic/analyze/refs")
-(declare-function semantic-analyze-tag-type "semantic/analyze/fcn")
-(declare-function semantic-tag-external-class "semantic/sort")
-(declare-function imenu--mouse-menu "imenu")
-
-;;; Customization
-(defgroup senator nil
- "Semantic Navigator."
- :group 'semantic)
-
-;;;###autoload
-(defcustom senator-step-at-tag-classes nil
- "List of tag classes recognized by Senator's navigation commands.
-A tag class is a symbol, such as `variable', `function', or `type'.
-
-As a special exception, if the value is nil, Senator's navigation
-commands recognize all tag classes."
- :type '(repeat (symbol)))
-;;;###autoload
-(make-variable-buffer-local 'senator-step-at-tag-classes)
-
-;;;###autoload
-(defcustom senator-step-at-start-end-tag-classes nil
- "List of tag classes at which Senator's navigation commands should stop.
-A tag class is a symbol, such as `variable', `function', or `type'.
-The navigation commands stop at the start and end of each tag
-class in this list, provided the tag class is recognized (see
-`senator-step-at-tag-classes').
-
-As a special exception, if the value is nil, the navigation
-commands stop at the beginning of every tag.
-
-If t, the navigation commands stop at the start and end of any
-tag, where possible."
- :type '(choice :tag "Identifiers"
- (repeat :menu-tag "Symbols" (symbol))
- (const :tag "All" t)))
-;;;###autoload
-(make-variable-buffer-local 'senator-step-at-start-end-tag-classes)
-
-(defcustom senator-highlight-found nil
- "If non-nil, Senator commands momentarily highlight found tags."
- :type 'boolean)
-(make-variable-buffer-local 'senator-highlight-found)
-
-;;; Faces
-(defface senator-momentary-highlight-face
- '((((class color) (background dark))
- (:background "gray30"))
- (((class color) (background light))
- (:background "gray70")))
- "Face used to momentarily highlight tags."
- :group 'semantic-faces)
-
-;;; Common functions
-
-(defun senator-momentary-highlight-tag (tag)
- "Momentarily highlight TAG.
-Does nothing if `senator-highlight-found' is nil."
- (and senator-highlight-found
- (semantic-momentary-highlight-tag
- tag 'senator-momentary-highlight-face)))
-
-(defun senator-step-at-start-end-p (tag)
- "Return non-nil if must step at start and end of TAG."
- (and tag
- (or (eq senator-step-at-start-end-tag-classes t)
- (memq (semantic-tag-class tag)
- senator-step-at-start-end-tag-classes))))
-
-(defun senator-skip-p (tag)
- "Return non-nil if must skip TAG."
- (and tag
- senator-step-at-tag-classes
- (not (memq (semantic-tag-class tag)
- senator-step-at-tag-classes))))
-
-(defun senator-middle-of-tag-p (pos tag)
- "Return non-nil if POS is between start and end of TAG."
- (and (> pos (semantic-tag-start tag))
- (< pos (semantic-tag-end tag))))
-
-(defun senator-step-at-parent (tag)
- "Return TAG's outermost parent if must step at start/end of it.
-Return nil otherwise."
- (if tag
- (let (parent parents)
- (setq parents (semantic-find-tag-by-overlay
- (semantic-tag-start tag)))
- (while (and parents (not parent))
- (setq parent (car parents)
- parents (cdr parents))
- (if (or (eq tag parent)
- (senator-skip-p parent)
- (not (senator-step-at-start-end-p parent)))
- (setq parent nil)))
- parent)))
-
-(defun senator-previous-tag-or-parent (pos)
- "Return the tag before POS or one of its parent where to step."
- (let (ol tag)
- (while (and pos (> pos (point-min)) (not tag))
- (setq pos (previous-overlay-change pos))
- (when pos
- ;; Get overlays at position
- (setq ol (overlays-at pos))
- ;; find the overlay that belongs to semantic
- ;; and STARTS or ENDS at the found position.
- (while (and ol (not tag))
- (setq tag (overlay-get (car ol) 'semantic))
- (unless (and tag (semantic-tag-p tag)
- (or (= (semantic-tag-start tag) pos)
- (= (semantic-tag-end tag) pos)))
- (setq tag nil
- ol (cdr ol))))))
- (or (senator-step-at-parent tag) tag)))
-
-;;; Search functions
-
-(defun senator-search-tag-name (tag)
- "Search for TAG name in current buffer.
-Limit the search to TAG bounds.
-If found, set point to the end of the name, and return point. The
-beginning of the name is at (match-beginning 0).
-Return nil if not found, that is if TAG name doesn't come from the
-source."
- (let ((name (semantic-tag-name tag)))
- (setq name (if (string-match "\\`\\([^[]+\\)[[]" name)
- (match-string 1 name)
- name))
- (goto-char (semantic-tag-start tag))
- (when (re-search-forward (concat
- ;; The tag name is expected to be
- ;; between word delimiters, whitespace,
- ;; or punctuation.
- "\\(\\<\\|\\s-+\\|\\s.\\)"
- (regexp-quote name)
- "\\(\\>\\|\\s-+\\|\\s.\\)")
- (semantic-tag-end tag)
- t)
- (goto-char (match-beginning 0))
- (search-forward name))))
-
-(defcustom senator-search-ignore-tag-classes
- '(code block)
- "List of ignored tag classes.
-Tags of those classes are excluded from search."
- :type '(repeat (symbol :tag "class")))
-
-(defun senator-search-default-tag-filter (tag)
- "Default function that filters searched tags.
-Ignore tags of classes in `senator-search-ignore-tag-classes'."
- (not (memq (semantic-tag-class tag)
- senator-search-ignore-tag-classes)))
-
-(defvar senator-search-tag-filter-functions
- '(senator-search-default-tag-filter)
- "List of functions to be called to filter searched tags.
-Each function is passed a tag. If one of them returns nil, the tag is
-excluded from the search.")
-
-(defun senator-search (searcher text &optional bound noerror count)
- "Use the SEARCHER function to search from point for TEXT in a tag name.
-SEARCHER is typically the function `search-forward', `search-backward',
-`word-search-forward', `word-search-backward', `re-search-forward', or
-`re-search-backward'. See one of the above function to see how the
-TEXT, BOUND, NOERROR, and COUNT arguments are interpreted."
- (let* ((origin (point))
- (count (or count 1))
- (step (cond ((> count 0) 1)
- ((< count 0) (setq count (- count)) -1)
- (0)))
- found next sstart send tag tstart tend)
- (or (zerop step)
- (while (and (not found)
- (setq next (funcall searcher text bound t step)))
- (setq sstart (match-beginning 0)
- send (match-end 0))
- (if (= sstart send)
- (setq found t)
- (and (setq tag (semantic-current-tag))
- (run-hook-with-args-until-failure
- 'senator-search-tag-filter-functions tag)
- (setq tend (senator-search-tag-name tag))
- (setq tstart (match-beginning 0)
- found (and (>= sstart tstart)
- (<= send tend)
- (zerop (setq count (1- count))))))
- (goto-char next))))
- (cond ((null found)
- (setq next origin
- send origin))
- ((= next sstart)
- (setq next send
- send sstart))
- (t
- (setq next sstart)))
- (goto-char next)
- ;; Setup the returned value and the `match-data' or maybe fail!
- (funcall searcher text send noerror step)))
-
-;;; Navigation commands
-
-;;;###autoload
-(defun senator-next-tag ()
- "Navigate to the next Semantic tag.
-Return the tag or nil if at end of buffer."
- (interactive)
- (semantic-error-if-unparsed)
- (let ((pos (point))
- (tag (semantic-current-tag))
- where)
- (if (and tag
- (not (senator-skip-p tag))
- (senator-step-at-start-end-p tag)
- (or (= pos (semantic-tag-start tag))
- (senator-middle-of-tag-p pos tag)))
- nil
- (if (setq tag (senator-step-at-parent tag))
- nil
- (setq tag (semantic-find-tag-by-overlay-next pos))
- (while (and tag (senator-skip-p tag))
- (setq tag (semantic-find-tag-by-overlay-next
- (semantic-tag-start tag))))))
- (if (not tag)
- (progn
- (goto-char (point-max))
- (message "End of buffer"))
- (cond ((and (senator-step-at-start-end-p tag)
- (or (= pos (semantic-tag-start tag))
- (senator-middle-of-tag-p pos tag)))
- (setq where "end")
- (goto-char (semantic-tag-end tag)))
- (t
- (setq where "start")
- (goto-char (semantic-tag-start tag))))
- (senator-momentary-highlight-tag tag)
- (message "%S: %s (%s)"
- (semantic-tag-class tag)
- (semantic-tag-name tag)
- where))
- tag))
-
-;;;###autoload
-(defun senator-previous-tag ()
- "Navigate to the previous Semantic tag.
-Return the tag or nil if at beginning of buffer."
- (interactive)
- (semantic-error-if-unparsed)
- (let ((pos (point))
- (tag (semantic-current-tag))
- where)
- (if (and tag
- (not (senator-skip-p tag))
- (senator-step-at-start-end-p tag)
- (or (= pos (semantic-tag-end tag))
- (senator-middle-of-tag-p pos tag)))
- nil
- (if (setq tag (senator-step-at-parent tag))
- nil
- (setq tag (senator-previous-tag-or-parent pos))
- (while (and tag (senator-skip-p tag))
- (setq tag (senator-previous-tag-or-parent
- (semantic-tag-start tag))))))
- (if (not tag)
- (progn
- (goto-char (point-min))
- (message "Beginning of buffer"))
- (cond ((or (not (senator-step-at-start-end-p tag))
- (= pos (semantic-tag-end tag))
- (senator-middle-of-tag-p pos tag))
- (setq where "start")
- (goto-char (semantic-tag-start tag)))
- (t
- (setq where "end")
- (goto-char (semantic-tag-end tag))))
- (senator-momentary-highlight-tag tag)
- (message "%S: %s (%s)"
- (semantic-tag-class tag)
- (semantic-tag-name tag)
- where))
- tag))
-
-;;; Search commands
-
-(defun senator-search-forward (string &optional bound noerror count)
- "Search in tag names forward from point for STRING.
-Set point to the end of the occurrence found, and return point.
-See also the function `search-forward' for details on the BOUND,
-NOERROR and COUNT arguments."
- (interactive "sSemantic search: ")
- (senator-search 'search-forward string bound noerror count))
-
-(defun senator-re-search-forward (regexp &optional bound noerror count)
- "Search in tag names forward from point for regular expression REGEXP.
-Set point to the end of the occurrence found, and return point.
-See also the function `re-search-forward' for details on the BOUND,
-NOERROR and COUNT arguments."
- (interactive "sSemantic regexp search: ")
- (senator-search 're-search-forward regexp bound noerror count))
-
-(defun senator-word-search-forward (word &optional bound noerror count)
- "Search in tag names forward from point for WORD.
-Set point to the end of the occurrence found, and return point.
-See also the function `word-search-forward' for details on the BOUND,
-NOERROR and COUNT arguments."
- (interactive "sSemantic word search: ")
- (senator-search 'word-search-forward word bound noerror count))
-
-(defun senator-search-backward (string &optional bound noerror count)
- "Search in tag names backward from point for STRING.
-Set point to the beginning of the occurrence found, and return point.
-See also the function `search-backward' for details on the BOUND,
-NOERROR and COUNT arguments."
- (interactive "sSemantic backward search: ")
- (senator-search 'search-backward string bound noerror count))
-
-(defun senator-re-search-backward (regexp &optional bound noerror count)
- "Search in tag names backward from point for regular expression REGEXP.
-Set point to the beginning of the occurrence found, and return point.
-See also the function `re-search-backward' for details on the BOUND,
-NOERROR and COUNT arguments."
- (interactive "sSemantic backward regexp search: ")
- (senator-search 're-search-backward regexp bound noerror count))
-
-(defun senator-word-search-backward (word &optional bound noerror count)
- "Search in tag names backward from point for WORD.
-Set point to the beginning of the occurrence found, and return point.
-See also the function `word-search-backward' for details on the BOUND,
-NOERROR and COUNT arguments."
- (interactive "sSemantic backward word search: ")
- (senator-search 'word-search-backward word bound noerror count))
-
-;;; Other useful search commands (minor mode menu)
-
-(defvar senator-last-search-type nil
- "Type of last non-incremental search command called.")
-
-(defun senator-nonincremental-repeat-search-forward ()
- "Search forward for the previous search string or regexp."
- (interactive)
- (cond
- ((and (eq senator-last-search-type 'string)
- search-ring)
- (senator-search-forward (car search-ring)))
- ((and (eq senator-last-search-type 'regexp)
- regexp-search-ring)
- (senator-re-search-forward (car regexp-search-ring)))
- (t
- (error "No previous search"))))
-
-(defun senator-nonincremental-repeat-search-backward ()
- "Search backward for the previous search string or regexp."
- (interactive)
- (cond
- ((and (eq senator-last-search-type 'string)
- search-ring)
- (senator-search-backward (car search-ring)))
- ((and (eq senator-last-search-type 'regexp)
- regexp-search-ring)
- (senator-re-search-backward (car regexp-search-ring)))
- (t
- (error "No previous search"))))
-
-(defun senator-nonincremental-search-forward (string)
- "Search for STRING nonincrementally."
- (interactive "sSemantic search for string: ")
- (setq senator-last-search-type 'string)
- (if (equal string "")
- (senator-search-forward (car search-ring))
- (isearch-update-ring string nil)
- (senator-search-forward string)))
-
-(defun senator-nonincremental-search-backward (string)
- "Search backward for STRING nonincrementally."
- (interactive "sSemantic search for string: ")
- (setq senator-last-search-type 'string)
- (if (equal string "")
- (senator-search-backward (car search-ring))
- (isearch-update-ring string nil)
- (senator-search-backward string)))
-
-(defun senator-nonincremental-re-search-forward (string)
- "Search for the regular expression STRING nonincrementally."
- (interactive "sSemantic search for regexp: ")
- (setq senator-last-search-type 'regexp)
- (if (equal string "")
- (senator-re-search-forward (car regexp-search-ring))
- (isearch-update-ring string t)
- (senator-re-search-forward string)))
-
-(defun senator-nonincremental-re-search-backward (string)
- "Search backward for the regular expression STRING nonincrementally."
- (interactive "sSemantic search for regexp: ")
- (setq senator-last-search-type 'regexp)
- (if (equal string "")
- (senator-re-search-backward (car regexp-search-ring))
- (isearch-update-ring string t)
- (senator-re-search-backward string)))
-
-(defvar senator--search-filter nil)
-
-(defun senator-search-set-tag-class-filter (&optional classes)
- "In current buffer, limit search scope to tag CLASSES.
-CLASSES is a list of tag class symbols or nil. If nil only global
-filters in `senator-search-tag-filter-functions' remain active."
- (interactive "sClasses: ")
- (setq classes
- (cond
- ((null classes)
- nil)
- ((symbolp classes)
- (list classes))
- ((stringp classes)
- (mapcar #'read (split-string classes)))
- (t
- (signal 'wrong-type-argument (list classes)))
- ))
- ;; Clear previous filter.
- (remove-hook 'senator-search-tag-filter-functions
- senator--search-filter t)
- (kill-local-variable 'senator--search-filter)
- (if classes
- (let ((names (mapconcat #'symbol-name classes "', `")))
- (setq-local senator--search-filter
- (lambda (tag)
- (memq (semantic-tag-class tag) classes)))
- (add-hook 'senator-search-tag-filter-functions
- senator--search-filter nil t)
- (message "Limit search to `%s' tags" names))
- (message "Default search filter restored")))
-
-;;; Folding
-;;
-;; Use new folding state. It might be wise to extend the idea
-;; of folding for hiding all but this, or show all children, etc.
-
-(defun senator-fold-tag (&optional tag)
- "Fold the current TAG."
- (interactive)
- (semantic-set-tag-folded (or tag (semantic-current-tag)) t))
-
-(defun senator-unfold-tag (&optional tag)
- "Fold the current TAG."
- (interactive)
- (semantic-set-tag-folded (or tag (semantic-current-tag)) nil))
-
-(defun senator-fold-tag-toggle (&optional tag)
- "Fold the current TAG."
- (interactive)
- (let ((tag (or tag (semantic-current-tag))))
- (if (semantic-tag-folded-p tag)
- (senator-unfold-tag tag)
- (senator-fold-tag tag))))
-
-;; @TODO - move this to some analyzer / refs tool
-(define-overloadable-function semantic-up-reference (tag)
- "Return a tag that is referred to by TAG.
-A \"reference\" could be any interesting feature of TAG.
-In C++, a function may have a `parent' which is non-local.
-If that parent which is only a reference in the function tag
-is found, we can jump to it.
-Some tags such as includes have other reference features.")
-
-;;;###autoload
-(defun senator-go-to-up-reference (&optional tag)
- "Move up one reference from the current TAG.
-A \"reference\" could be any interesting feature of TAG.
-In C++, a function may have a `parent' which is non-local.
-If that parent which is only a reference in the function tag
-is found, we can jump to it.
-Some tags such as includes have other reference features."
- (interactive)
- (semantic-error-if-unparsed)
- (let ((result (semantic-up-reference (or tag (semantic-current-tag)))))
- (if (not result)
- (error "No up reference found")
- (push-mark)
- (when (fboundp 'xref-push-marker-stack)
- (xref-push-marker-stack))
- (cond
- ;; A tag
- ((semantic-tag-p result)
- (semantic-go-to-tag result)
- (pop-to-buffer-same-window (current-buffer))
- (semantic-momentary-highlight-tag result))
- ;; Buffers
- ((bufferp result)
- (pop-to-buffer-same-window result)
- (pulse-momentary-highlight-one-line (point)))
- ;; Files
- ((and (stringp result) (file-exists-p result))
- (find-file result)
- (pulse-momentary-highlight-one-line (point)))
- (t
- (error "Unknown result type from `semantic-up-reference'"))))))
-
-(defun semantic-up-reference-default (tag)
- "Return a tag that is referred to by TAG.
-Makes C/C++ language like assumptions."
- (cond ((semantic-tag-faux-p tag)
- ;; Faux tags should have a real tag in some other location.
- (require 'semantic/sort)
- (let ((options (semantic-tag-external-class tag)))
- ;; I should do something a little better than
- ;; this. Oy!
- (car options)
- ))
-
- ;; Include always point to another file.
- ((eq (semantic-tag-class tag) 'include)
- (let ((file (semantic-dependency-tag-file tag)))
- (cond
- ((or (not file) (not (file-exists-p file)))
- (error "Could not location include %s"
- (semantic-tag-name tag)))
- ((get-file-buffer file)
- (get-file-buffer file))
- ((stringp file)
- file)
- )))
-
- ;; Is there a parent of the function to jump to?
- ((and (semantic-tag-of-class-p tag 'function)
- (semantic-tag-function-parent tag))
- (let* ((scope (semantic-calculate-scope (point))))
- ;; @todo - it would be cool to ask the user which one if
- ;; more than one.
- (car (oref scope parents))
- ))
-
- ;; Is there a non-prototype version of the tag to jump to?
- ((semantic-tag-get-attribute tag :prototype-flag)
- (require 'semantic/analyze/refs)
- (let* ((sar (semantic-analyze-tag-references tag)))
- (car (semantic-analyze-refs-impl sar t)))
- )
-
- ;; If this is a datatype, and we have superclasses
- ((and (semantic-tag-of-class-p tag 'type)
- (semantic-tag-type-superclasses tag))
- (require 'semantic/analyze)
- (let ((scope (semantic-calculate-scope (point)))
- (parents (semantic-tag-type-superclasses tag)))
- (semantic-analyze-find-tag (car parents) 'type scope)))
-
- ;; Get the data type, and try to find that.
- ((semantic-tag-type tag)
- (let ((scope (semantic-calculate-scope (point))))
- (semantic-analyze-tag-type tag scope))
- )
- (t nil)))
-
-(defvar-local senator-isearch-semantic-mode nil
- "Non-nil if isearch does semantic search.
-This is a buffer local variable.")
-
-(defun senator-beginning-of-defun (&optional _arg)
- "Move backward to the beginning of a defun.
-Use semantic tags to navigate.
-ARG is the number of tags to navigate (not yet implemented)."
- (semantic-fetch-tags)
- (let* ((senator-highlight-found nil)
- ;; Step at beginning of next tag with class specified in
- ;; `senator-step-at-tag-classes'.
- (senator-step-at-start-end-tag-classes t)
- (tag (senator-previous-tag)))
- (when tag
- (if (= (point) (semantic-tag-end tag))
- (goto-char (semantic-tag-start tag)))
- (beginning-of-line))))
-
-(defun senator-end-of-defun (&optional _arg)
- "Move forward to next end of defun.
-Use semantic tags to navigate.
-ARG is the number of tags to navigate (not yet implemented)."
- (semantic-fetch-tags)
- (let* ((senator-highlight-found nil)
- ;; Step at end of next tag with class specified in
- ;; `senator-step-at-tag-classes'.
- (senator-step-at-start-end-tag-classes t)
- (tag (senator-next-tag)))
- (when tag
- (if (= (point) (semantic-tag-start tag))
- (goto-char (semantic-tag-end tag)))
- (skip-chars-forward " \t")
- (if (looking-at "\\s<\\|\n")
- (forward-line 1)))))
-
-(defun senator-narrow-to-defun ()
- "Make text outside current defun invisible.
-The defun visible is the one that contains point or follows point.
-Use semantic tags to navigate."
- (interactive)
- (semantic-fetch-tags)
- (save-excursion
- (widen)
- (senator-end-of-defun)
- (let ((end (point)))
- (senator-beginning-of-defun)
- (narrow-to-region (point) end))))
-
-(defun senator-mark-defun ()
- "Put mark at end of this defun, point at beginning.
-The defun marked is the one that contains point or follows point.
-Use semantic tags to navigate."
- (interactive)
- (let ((origin (point))
- (end (progn (senator-end-of-defun) (point)))
- (start (progn (senator-beginning-of-defun) (point))))
- (goto-char origin)
- (push-mark)
- (goto-char end) ;; end-of-defun
- (push-mark (point) nil t)
- (goto-char start) ;; beginning-of-defun
- (re-search-backward "^\n" (- (point) 1) t)))
-
-;;; Tag Cut & Paste
-
-;; To copy a tag, means to put a tag definition into the tag
-;; ring. To kill a tag, put the tag into the tag ring AND put
-;; the body of the tag into the kill-ring.
-;;
-;; To retrieve a killed tag's text, use C-y (yank), but to retrieve
-;; the tag as a reference of some sort, use senator-yank-tag.
-
-(defvar senator-tag-ring (make-ring 20)
- "Ring of tags for use with cut and paste.")
-
-;;;###autoload
-(defun senator-copy-tag ()
- "Take the current tag, and place it in the tag ring."
- (interactive)
- (semantic-fetch-tags)
- (let ((ft (semantic-obtain-foreign-tag)))
- (when ft
- (ring-insert senator-tag-ring ft)
- (kill-ring-save (semantic-tag-start ft) (semantic-tag-end ft))
- (when (called-interactively-p 'interactive)
- (message "Use C-y to yank text. \
-Use `senator-yank-tag' for prototype insert.")))
- ft))
-
-;;;###autoload
-(defun senator-kill-tag ()
- "Take the current tag, place it in the tag ring, and kill it.
-Killing the tag removes the text for that tag, and places it into
-the kill ring. Retrieve that text with \\[yank]."
- (interactive)
- (let ((ct (senator-copy-tag))) ;; this handles the reparse for us.
- (kill-region (semantic-tag-start ct)
- (semantic-tag-end ct))
- (when (called-interactively-p 'interactive)
- (message "Use C-y to yank text. \
-Use `senator-yank-tag' for prototype insert."))))
-
-;;;###autoload
-(defun senator-yank-tag ()
- "Yank a tag from the tag ring.
-The form the tag takes is different depending on where it is being
-yanked to."
- (interactive)
- (or (ring-empty-p senator-tag-ring)
- (let ((ft (ring-ref senator-tag-ring 0)))
- (semantic-foreign-tag-check ft)
- (semantic-insert-foreign-tag ft)
- (when (called-interactively-p 'interactive)
- (message "Use C-y to recover the yank the text of %s."
- (semantic-tag-name ft))))))
-
-(cl-defstruct (senator-register
- (:constructor nil)
- (:constructor senator-make-register (foreign-tag)))
- foreign-tag)
-
-(cl-defmethod register-val-jump-to ((data senator-register) _arg)
- (let ((ft (senator-register-foreign-tag data)))
- (switch-to-buffer (semantic-tag-buffer ft))
- (goto-char (semantic-tag-start ft))))
-
-(cl-defmethod register-val-describe ((data senator-register) _verbose)
- (cl-prin1-to-string (senator-register-foreign-tag data)))
-
-(cl-defmethod register-val-insert ((data senator-register))
- (semantic-insert-foreign-tag (senator-register-foreign-tag data)))
-
-;;;###autoload
-(defun senator-copy-tag-to-register (register &optional kill-flag)
- "Copy the current tag into REGISTER.
-Optional argument KILL-FLAG will delete the text of the tag to the
-kill ring.
-
-Interactively, reads the register using `register-read-with-preview'."
- (interactive (list (register-read-with-preview "Tag to register: "
- (register-confirm-overwrite))
- current-prefix-arg))
- (semantic-fetch-tags)
- (let ((ft (semantic-obtain-foreign-tag)))
- (when ft
- (set-register register (senator-make-register ft))
- (if kill-flag
- (kill-region (semantic-tag-start ft)
- (semantic-tag-end ft))))))
-
-;;;###autoload
-(defun senator-transpose-tags-up ()
- "Transpose the current tag, and the preceding tag."
- (interactive)
- (semantic-fetch-tags)
- (let* ((current-tag (semantic-current-tag))
- (prev-tag (save-excursion
- (goto-char (semantic-tag-start current-tag))
- (semantic-find-tag-by-overlay-prev)))
- (ct-parent (semantic-find-tag-parent-by-overlay current-tag))
- (pt-parent (semantic-find-tag-parent-by-overlay prev-tag)))
- (if (not (eq ct-parent pt-parent))
- (error "Cannot transpose tags"))
- (let ((txt (buffer-substring (semantic-tag-start current-tag)
- (semantic-tag-end current-tag)))
- (line (count-lines (semantic-tag-start current-tag)
- (point)))
- (insert-point nil)
- )
- (delete-region (semantic-tag-start current-tag)
- (semantic-tag-end current-tag))
- (delete-blank-lines)
- (goto-char (semantic-tag-start prev-tag))
- (setq insert-point (point))
- (insert txt)
- (if (/= (current-column) 0)
- (insert "\n"))
- (insert "\n")
- (goto-char insert-point)
- (forward-line line)
- )))
-
-;;;###autoload
-(defun senator-transpose-tags-down ()
- "Transpose the current tag, and the following tag."
- (interactive)
- (semantic-fetch-tags)
- (let* ((current-tag (semantic-current-tag))
- (next-tag (save-excursion
- (goto-char (semantic-tag-end current-tag))
- (semantic-find-tag-by-overlay-next)))
- (end-pt (point-marker))
- )
- (goto-char (semantic-tag-start next-tag))
- (forward-char 1)
- (senator-transpose-tags-up)
- ;; I know that the above fcn deletes the next tag, so our pt marker
- ;; will be stable.
- (goto-char end-pt)))
-
-;;; Using semantic search in isearch mode
-
-(defun senator-lazy-highlight-update ()
- "Force lazy highlight update."
- (lazy-highlight-cleanup t)
- (setq isearch-lazy-highlight-last-string nil)
- (setq isearch-adjusted t)
- (isearch-update))
-
-;; Recent versions of GNU Emacs allow overriding the isearch search
-;; function for special needs, and avoid to advice the built-in search
-;; function :-)
-(defun senator-isearch-search-fun ()
- "Return the function to use for the search.
-Use a senator search function when semantic isearch mode is enabled."
- (intern
- (concat (if senator-isearch-semantic-mode
- "senator-"
- "")
- (cond (isearch-regexp-function "word-")
- (isearch-regexp "re-")
- (t ""))
- "search-"
- (if isearch-forward
- "forward"
- "backward"))))
-
-(defun senator-isearch-toggle-semantic-mode ()
- "Toggle semantic searching on or off in isearch mode."
- (interactive)
- (setq senator-isearch-semantic-mode
- (not senator-isearch-semantic-mode))
- (if isearch-mode
- ;; force lazy highlight update
- (senator-lazy-highlight-update)
- (message "Isearch semantic mode %s"
- (if senator-isearch-semantic-mode
- "enabled"
- "disabled"))))
-
-(defvar senator-old-isearch-search-fun nil
- "Hold previous value of `isearch-search-fun-function'.")
-
-(defun senator-isearch-mode-hook ()
- "Isearch mode hook to setup semantic searching."
- (if (and isearch-mode senator-isearch-semantic-mode)
- (progn
- ;; When `senator-isearch-semantic-mode' is on save the
- ;; previous `isearch-search-fun-function' and install the
- ;; senator one.
- (when (and (local-variable-p 'isearch-search-fun-function)
- (not (local-variable-p 'senator-old-isearch-search-fun)))
- (setq-local senator-old-isearch-search-fun
- isearch-search-fun-function))
- (setq-local isearch-search-fun-function
- #'senator-isearch-search-fun))
- ;; When `senator-isearch-semantic-mode' is off restore the
- ;; previous `isearch-search-fun-function'.
- (when (eq isearch-search-fun-function 'senator-isearch-search-fun)
- (if (local-variable-p 'senator-old-isearch-search-fun)
- (progn
- (setq-local isearch-search-fun-function
- senator-old-isearch-search-fun)
- (kill-local-variable 'senator-old-isearch-search-fun))
- (kill-local-variable 'isearch-search-fun-function)))))
-
-;; (add-hook 'isearch-mode-hook 'senator-isearch-mode-hook)
-;; (add-hook 'isearch-mode-end-hook 'senator-isearch-mode-hook)
-
-;; ;; Keyboard shortcut to toggle semantic search in isearch mode.
-;; (define-key isearch-mode-map
-;; [(control ?,)]
-;; 'senator-isearch-toggle-semantic-mode)
-
-(provide 'semantic/senator)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/senator"
-;; End:
-
-;;; semantic/senator.el ends here
+++ /dev/null
-;;; semantic/sort.el --- Utilities for sorting and re-arranging tag tables. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Tag tables originate in the order they appear in a buffer, or source file.
-;; It is often useful to re-arrange them is some predictable way for browsing
-;; purposes. Re-organization may be alphabetical, or even a complete
-;; reorganization of parents and children.
-;;
-;; Originally written in semantic/util.el
-;;
-
-(require 'semantic)
-(eval-when-compile
- (require 'semantic/find))
-
-(declare-function semanticdb-find-tags-external-children-of-type
- "semantic/db-find")
-
-;;; Alphanumeric sorting
-;;
-;; Takes a list of tags, and sorts them in a case-insensitive way
-;; at a single level.
-
-;;; Code:
-(defun semantic-string-lessp-ci (s1 s2)
- "Case insensitive version of `string-lessp'.
-Argument S1 and S2 are the strings to compare."
- (eq (compare-strings s1 0 nil s2 0 nil t) -1))
-
-(defun semantic-sort-tag-type (tag)
- "Return a type string for TAG guaranteed to be a string."
- (let ((ty (semantic-tag-type tag)))
- (cond ((stringp ty)
- ty)
- ((listp ty)
- (or (car ty) ""))
- (t ""))))
-
-(defun semantic-tag-lessp-name-then-type (A B)
- "Return t if tag A is < tag B.
-First sorts on name, then sorts on the name of the :type of
-each tag."
- (let ((na (semantic-tag-name A))
- (nb (semantic-tag-name B))
- )
- (if (string-lessp na nb)
- t ; a sure thing.
- (if (string= na nb)
- ;; If equal, test the :type which might be different.
- (let* ((ta (semantic-tag-type A))
- (tb (semantic-tag-type B))
- (tas (cond ((stringp ta)
- ta)
- ((semantic-tag-p ta)
- (semantic-tag-name ta))
- (t nil)))
- (tbs (cond ((stringp tb)
- tb)
- ((semantic-tag-p tb)
- (semantic-tag-name tb))
- (t nil))))
- (if (and (stringp tas) (stringp tbs))
- (string< tas tbs)
- ;; This is if A == B, and no types in A or B
- nil))
- ;; This nil is if A > B, but not =
- nil))))
-
-(defun semantic-sort-tags-by-name-increasing (tags)
- "Sort TAGS by name in increasing order with side effects.
-Return the sorted list."
- (sort tags :key #'semantic-tag-name))
-
-(defun semantic-sort-tags-by-name-decreasing (tags)
- "Sort TAGS by name in decreasing order with side effects.
-Return the sorted list."
- (sort tags :key #'semantic-tag-name :reverse t))
-
-(defun semantic-sort-tags-by-type-increasing (tags)
- "Sort TAGS by type in increasing order with side effects.
-Return the sorted list."
- (sort tags :key #'semantic-sort-tag-type))
-
-(defun semantic-sort-tags-by-type-decreasing (tags)
- "Sort TAGS by type in decreasing order with side effects.
-Return the sorted list."
- (sort tags :key #'semantic-sort-tag-type :reverse t))
-
-(defun semantic-sort-tags-by-name-increasing-ci (tags)
- "Sort TAGS by name in increasing order with side effects.
-Return the sorted list."
- (sort tags :key #'semantic-tag-name :lessp #'semantic-string-lessp-ci))
-
-(defun semantic-sort-tags-by-name-decreasing-ci (tags)
- "Sort TAGS by name in decreasing order with side effects.
-Return the sorted list."
- (sort tags
- :key #'semantic-tag-name :lessp #'semantic-string-lessp-ci
- :reverse t))
-
-(defun semantic-sort-tags-by-type-increasing-ci (tags)
- "Sort TAGS by type in increasing order with side effects.
-Return the sorted list."
- (sort tags :key #'semantic-sort-tag-type :lessp #'semantic-string-lessp-ci))
-
-(defun semantic-sort-tags-by-type-decreasing-ci (tags)
- "Sort TAGS by type in decreasing order with side effects.
-Return the sorted list."
- (sort tags
- :key #'semantic-sort-tag-type :lessp #'semantic-string-lessp-ci
- :reverse t))
-
-(defun semantic-sort-tags-by-name-then-type-increasing (tags)
- "Sort TAGS by name, then type in increasing order with side effects.
-Return the sorted list."
- (sort tags #'semantic-tag-lessp-name-then-type))
-
-(defun semantic-sort-tags-by-name-then-type-decreasing (tags)
- "Sort TAGS by name, then type in increasing order with side effects.
-Return the sorted list."
- (sort tags #'semantic-tag-lessp-name-then-type))
-\f
-;;; Unique
-;;
-;; Scan a list of tags, removing duplicates.
-;; This must first sort the tags by name alphabetically ascending.
-;;
-;; Useful for completion lists, or other situations where the
-;; other data isn't as useful.
-
-(defun semantic-unique-tag-table-by-name (tags)
- "Scan a list of TAGS, removing duplicate names.
-This must first sort the tags by name alphabetically ascending.
-For more complex uniqueness testing used by the semanticdb
-typecaching system, see `semanticdb-typecache-merge-streams'."
- (let ((sorted (semantic-sort-tags-by-name-increasing
- (copy-sequence tags)))
- (uniq nil))
- (while sorted
- (if (or (not uniq)
- (not (string= (semantic-tag-name (car sorted))
- (semantic-tag-name (car uniq)))))
- (setq uniq (cons (car sorted) uniq)))
- (setq sorted (cdr sorted))
- )
- (nreverse uniq)))
-
-(defun semantic-unique-tag-table (tags)
- "Scan a list of TAGS, removing duplicates.
-This must first sort the tags by position ascending.
-TAGS are removed only if they are equivalent, as can happen when
-multiple tag sources are scanned.
-For more complex uniqueness testing used by the semanticdb
-typecaching system, see `semanticdb-typecache-merge-streams'."
- (let ((sorted (sort (copy-sequence tags)
- (lambda (a b)
- (cond ((not (semantic-tag-with-position-p a))
- t)
- ((not (semantic-tag-with-position-p b))
- nil)
- (t
- (< (semantic-tag-start a)
- (semantic-tag-start b)))))))
- (uniq nil))
- (while sorted
- (if (or (not uniq)
- (not (semantic-equivalent-tag-p (car sorted) (car uniq))))
- (setq uniq (cons (car sorted) uniq)))
- (setq sorted (cdr sorted))
- )
- (nreverse uniq)))
-
-\f
-;;; Tag Table Flattening
-;;
-;; In the 1.4 search API, there was a parameter "search-parts" which
-;; was used to find tags inside other tags. This was used
-;; infrequently, mostly for completion/jump routines. These types
-;; of commands would be better off with a flattened list, where all
-;; tags appear at the top level.
-
-;;;###autoload
-(defun semantic-flatten-tags-table (&optional table)
- "Flatten the tags table TABLE.
-All tags in TABLE, and all components of top level tags
-in TABLE will appear at the top level of list.
-Tags promoted to the top of the list will still appear
-unmodified as components of their parent tags."
- (let* ((table (semantic-something-to-tag-table table))
- ;; Initialize the starting list with our table.
- (lists (list table)))
- (mapc (lambda (tag)
- (let ((components (semantic-tag-components tag)))
- (if (and components
- ;; unpositioned tags can be hazardous to
- ;; completion. Do we need any type of tag
- ;; here? - EL
- (semantic-tag-with-position-p (car components)))
- (setq lists (cons
- (semantic-flatten-tags-table components)
- lists)))))
- table)
- (apply #'append (nreverse lists))))
-
-\f
-;;; Buckets:
-;;
-;; A list of tags can be grouped into buckets based on the tag class.
-;; Bucketize means to take a list of tags at a given level in a tag
-;; table, and reorganize them into buckets based on class.
-;;
-(defvar semantic-bucketize-tag-class
- ;; Must use lambda because `semantic-tag-class' is a macro.
- (lambda (tok) (semantic-tag-class tok))
- "Function used to get a symbol describing the class of a tag.
-This function must take one argument of a semantic tag.
-It should return a symbol found in `semantic-symbol->name-assoc-list'
-which `semantic-bucketize' uses to bin up tokens.
-To create new bins for an application augment
-`semantic-symbol->name-assoc-list', and
-`semantic-symbol->name-assoc-list-for-type-parts' in addition
-to setting this variable (locally in your function).")
-
-(defun semantic-bucketize (tags &optional parent filter)
- "Sort TAGS into a group of buckets based on tag class.
-Unknown classes are placed in a Misc bucket.
-Type bucket names are defined by either `semantic-symbol->name-assoc-list'.
-If PARENT is specified, then TAGS belong to this PARENT in some way.
-This will use `semantic-symbol->name-assoc-list-for-type-parts' to
-generate bucket names.
-Optional argument FILTER is a filter function to be applied to each bucket.
-The filter function will take one argument, which is a list of tokens, and
-may re-organize the list with side-effects."
- (let* ((name-list (if parent
- semantic-symbol->name-assoc-list-for-type-parts
- semantic-symbol->name-assoc-list))
- (sn name-list)
- (bins (make-vector (1+ (length sn)) nil))
- ask tagtype
- (nsn nil)
- (num 1)
- (out nil))
- ;; Build up the bucket vector
- (while sn
- (setq nsn (cons (cons (car (car sn)) num) nsn)
- sn (cdr sn)
- num (1+ num)))
- ;; Place into buckets
- (while tags
- (setq tagtype (funcall semantic-bucketize-tag-class (car tags))
- ask (assq tagtype nsn)
- num (or (cdr ask) 0))
- (aset bins num (cons (car tags) (aref bins num)))
- (setq tags (cdr tags)))
- ;; Remove from buckets into a list.
- (setq num 1)
- (while (< num (length bins))
- (when (aref bins num)
- (setq out
- (cons (cons
- (cdr (nth (1- num) name-list))
- ;; Filtering, First hacked by David Ponce david@dponce.com
- (funcall (or filter 'nreverse) (aref bins num)))
- out)))
- (setq num (1+ num)))
- (if (aref bins 0)
- (setq out (cons (cons "Misc"
- (funcall (or filter 'nreverse) (aref bins 0)))
- out)))
- (nreverse out)))
-\f
-;;; Adoption
-;;
-;; Some languages allow children of a type to be defined outside
-;; the syntactic scope of that class. These routines will find those
-;; external members, and bring them together in a cloned copy of the
-;; class tag.
-;;
-(defvar-local semantic-orphaned-member-metaparent-type "class"
- "In `semantic-adopt-external-members', the type of `type' for metaparents.
-A metaparent is a made-up type semantic token used to hold the child list
-of orphaned members of a named type.")
-
-(defvar semantic-mark-external-member-function nil
- "Function called when an externally defined orphan is found.
-By default, the token is always marked with the `adopted' property.
-This function should be locally bound by a program that needs
-to add additional behaviors into the token list.
-This function is called with two arguments. The first is TOKEN which is
-a shallow copy of the token to be modified. The second is the PARENT
-which is adopting TOKEN. This function should return TOKEN (or a copy of it)
-which is then integrated into the revised token list.")
-
-(defun semantic-adopt-external-members (tags)
- "Rebuild TAGS so that externally defined members are regrouped.
-Some languages such as C++ and CLOS permit the declaration of member
-functions outside the definition of the class. It is easier to study
-the structure of a program when such methods are grouped together
-more logically.
-
-This function uses `semantic-tag-external-member-p' to
-determine when a potential child is an externally defined member.
-
-Note: Applications which use this function must account for token
-types which do not have a position, but have children which *do*
-have positions.
-
-Applications should use `semantic-mark-external-member-function'
-to modify all tags which are found as externally defined to some
-type. For example, changing the token type for generating extra
-buckets with the bucket function."
- (let ((parent-buckets nil)
- (decent-list nil)
- (out nil)
- (tmp nil)
- )
- ;; Rebuild the output list, stripping out all parented
- ;; external entries
- (while tags
- (cond
- ((setq tmp (semantic-tag-external-member-parent (car tags)))
- (let ((tagcopy (semantic-tag-clone (car tags)))
- (a (assoc tmp parent-buckets)))
- (semantic--tag-put-property-no-side-effect tagcopy 'adopted t)
- (if a
- ;; If this parent is already in the list, append.
- (setcdr (nthcdr (1- (length a)) a) (list tagcopy))
- ;; If not, prepend this new parent bucket into our list
- (setq parent-buckets
- (cons (cons tmp (list tagcopy)) parent-buckets)))
- ))
- ((eq (semantic-tag-class (car tags)) 'type)
- ;; Types need to be rebuilt from scratch so we can add in new
- ;; children to the child list. Only the top-level cons
- ;; cells need to be duplicated so we can hack out the
- ;; child list later.
- (setq out (cons (semantic-tag-clone (car tags)) out))
- (setq decent-list (cons (car out) decent-list))
- )
- (t
- ;; Otherwise, append this tag to our new output list.
- (setq out (cons (car tags) out)))
- )
- (setq tags (cdr tags)))
- ;; Rescan out, by descending into all types and finding parents
- ;; for all entries moved into the parent-buckets.
- (while decent-list
- (let* ((bucket (assoc (semantic-tag-name (car decent-list))
- parent-buckets))
- (bucketkids (cdr bucket)))
- (when bucket
- ;; Run our secondary marking function on the children
- (if semantic-mark-external-member-function
- (setq bucketkids
- (mapcar (lambda (tok)
- (funcall semantic-mark-external-member-function
- tok (car decent-list)))
- bucketkids)))
- ;; We have some extra kids. Merge.
- (semantic-tag-put-attribute
- (car decent-list) :members
- (append (semantic-tag-type-members (car decent-list))
- bucketkids))
- ;; Nuke the bucket label so it is not found again.
- (setcar bucket nil))
- (setq decent-list
- (append (cdr decent-list)
- ;; get embedded types to scan and make copies
- ;; of them.
- (mapcar
- (lambda (tok) (semantic-tag-clone tok))
- (semantic-find-tags-by-class 'type
- (semantic-tag-type-members (car decent-list)))))
- )))
- ;; Scan over all remaining lost external methods, and tack them
- ;; onto the end.
- (while parent-buckets
- (if (car (car parent-buckets))
- (let* ((tmp (car parent-buckets))
- (fauxtag (semantic-tag-new-type
- (car tmp)
- semantic-orphaned-member-metaparent-type
- nil ;; Part list
- nil ;; parents (unknown)
- ))
- (bucketkids (cdr tmp)))
- (semantic-tag-set-faux fauxtag) ;; properties
- (if semantic-mark-external-member-function
- (setq bucketkids
- (mapcar (lambda (tok)
- (funcall semantic-mark-external-member-function
- tok fauxtag))
- bucketkids)))
- (semantic-tag-put-attribute fauxtag :members bucketkids)
- ;; We have a bunch of methods with no parent in this file.
- ;; Create a meta-type to hold it.
- (setq out (cons fauxtag out))
- ))
- (setq parent-buckets (cdr parent-buckets)))
- ;; Return the new list.
- (nreverse out)))
-
-\f
-;;; External children
-;;
-;; In order to adopt external children, we need a few overload methods
-;; to enable the feature.
-
-;;;###autoload
-(define-overloadable-function semantic-tag-external-member-parent (tag)
- "Return a parent for TAG when TAG is an external member.
-TAG is an external member if it is defined at a toplevel and
-has some sort of label defining a parent. The parent return will
-be a string.
-
-The default behavior, if not overridden with
-`tag-member-parent' gets the `parent' extra
-specifier of TAG.
-
-If this function is overridden, use
-`semantic-tag-external-member-parent-default' to also
-include the default behavior, and merely extend your own."
- )
-
-(defun semantic-tag-external-member-parent-default (tag)
- "Return the name of TAGs parent only if TAG is not defined in its parent."
- ;; Use only the extra spec because a type has a parent which
- ;; means something completely different.
- (let ((tp (semantic-tag-get-attribute tag :parent)))
- (when (stringp tp)
- tp)))
-
-(define-overloadable-function semantic-tag-external-member-p (parent tag)
- "Return non-nil if PARENT is the parent of TAG.
-TAG is an external member of PARENT when it is somehow tagged
-as having PARENT as its parent.
-PARENT and TAG must both be semantic tags.
-
-The default behavior, if not overridden with
-`tag-external-member-p' is to match :parent attribute in
-the name of TAG.
-
-If this function is overridden, use
-`semantic-tag-external-member-children-default' to also
-include the default behavior, and merely extend your own."
- )
-
-(defun semantic-tag-external-member-p-default (parent tag)
- "Return non-nil if PARENT is the parent of TAG."
- ;; Use only the extra spec because a type has a parent which
- ;; means something completely different.
- (let ((tp (semantic-tag-external-member-parent tag)))
- (and (stringp tp)
- (string= (semantic-tag-name parent) tp))))
-
-(define-overloadable-function semantic-tag-external-member-children (tag &optional usedb)
- "Return the list of children which are not *in* TAG.
-If optional argument USEDB is non-nil, then also search files in
-the Semantic Database. If USEDB is a list of databases, search those
-databases.
-
-Children in this case are functions or types which are members of
-TAG, such as the parts of a type, but which are not defined inside
-the class. C++ and CLOS both permit methods of a class to be defined
-outside the bounds of the class' definition.
-
-The default behavior, if not overridden with
-`tag-external-member-children' is to search using
-`semantic-tag-external-member-p' in all top level definitions
-with a parent of TAG.
-
-If this function is overridden, use
-`semantic-tag-external-member-children-default' to also
-include the default behavior, and merely extend your own."
- )
-
-(defun semantic-tag-external-member-children-default (tag &optional usedb)
- "Return list of external children for TAG.
-Optional argument USEDB specifies if the semantic database is used.
-See `semantic-tag-external-member-children' for details."
- (if (and usedb
- (require 'semantic/db-mode)
- (semanticdb-minor-mode-p)
- (require 'semantic/db-find))
- (let ((m (semanticdb-find-tags-external-children-of-type
- (semantic-tag-name tag) tag)))
- (if m (apply #'append (mapcar #'cdr m))))
- (semantic--find-tags-by-function
- (lambda (tok)
- ;; This bit of annoying backquote forces the contents of
- ;; tag into the generated lambda.
- (semantic-tag-external-member-p tag tok))
- (current-buffer))))
-
-(define-overloadable-function semantic-tag-external-class (tag)
- "Return a list of real tags that faux TAG might represent.
-
-In some languages, a method can be defined on an object which is
-not in the same file. In this case,
-`semantic-adopt-external-members' will create a faux-tag. If it
-is necessary to get the tag from which for faux TAG was most
-likely derived, then this function is needed."
- (unless (semantic-tag-faux-p tag)
- (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p)))
- (:override)
- )
-
-(defvar semanticdb-search-system-databases)
-
-(defun semantic-tag-external-class-default (tag)
- "Return a list of real tags that faux TAG might represent.
-See `semantic-tag-external-class' for details."
- (if (and (require 'semantic/db-mode)
- (semanticdb-minor-mode-p))
- (let* ((semanticdb-search-system-databases nil)
- (m (semanticdb-find-tags-by-class
- (semantic-tag-class tag)
- (semanticdb-find-tags-by-name (semantic-tag-name tag)))))
- (semanticdb-strip-find-results m 'name))
- ;; Presumably, if the tag is faux, it is not local.
- nil))
-
-(provide 'semantic/sort)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/sort"
-;; End:
-
-;;; semantic/sort.el ends here
+++ /dev/null
-;;; semantic/symref.el --- Symbol Reference API -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic Symbol Reference API.
-;;
-;; Semantic's native parsing tools do not handle symbol references.
-;; Tracking such information is a task that requires a huge amount of
-;; space and processing not appropriate for an Emacs Lisp program.
-;;
-;; Many desired tools used in refactoring, however, need to have
-;; such references available to them. This API aims to provide a
-;; range of functions that can be used to identify references. The
-;; API is backed by an OO system that is used to allow multiple
-;; external tools to provide the information.
-;;
-;; The default implementation uses a find/grep combination to do a
-;; search. This works ok in small projects. For larger projects, it
-;; is important to find an alternate tool to use as a back-end to
-;; symref.
-;;
-;; See the command: `semantic-symref' for an example app using this api.
-;;
-;; TO USE THIS TOOL
-;;
-;; The following functions can be used to find different kinds of
-;; references.
-;;
-;; `semantic-symref-find-references-by-name'
-;; `semantic-symref-find-file-references-by-name'
-;; `semantic-symref-find-text'
-;;
-;; All the search routines return a class of type
-;; `semantic-symref-result'. You can reference the various slots, but
-;; you will need the following methods to get extended information.
-;;
-;; `semantic-symref-result-get-files'
-;; `semantic-symref-result-get-tags'
-;;
-;; ADD A NEW EXTERNAL TOOL
-;;
-;; To support a new external tool, subclass `semantic-symref-tool-baseclass'
-;; and implement the methods. The baseclass provides support for
-;; managing external processes that produce parsable output.
-;;
-;; Your tool should then create an instance of `semantic-symref-result'.
-
-(require 'semantic)
-(eval-when-compile (require 'semantic/find)) ;For semantic-find-tags-*
-(eval-when-compile (require 'ede/proj)) ;For `metasubproject' warning.
-
-(defvar ede-minor-mode)
-(declare-function data-debug-new-buffer "data-debug")
-(declare-function data-debug-insert-object-slots "eieio-datadebug")
-(declare-function ede-toplevel "ede/base")
-(declare-function ede-project-root-directory "ede/files")
-(declare-function ede-up-directory "ede/files")
-
-;;; Code:
-(defcustom semantic-symref-tool 'detect
- "The active symbol reference tool name.
-The tool symbol can be `detect', or a symbol that is the name of
-a tool that can be used for symbol referencing."
- :type 'symbol
- :group 'semantic)
-(make-variable-buffer-local 'semantic-symref-tool)
-
-;;; TOOL SETUP
-;;
-(defvar semantic-symref-tool-alist
- '( ( (lambda (rootdir) (file-exists-p (expand-file-name "GPATH" rootdir))) .
- global)
- ( (lambda (rootdir) (file-exists-p (expand-file-name "ID" rootdir))) .
- idutils)
- ( (lambda (rootdir) (file-exists-p (expand-file-name "cscope.out" rootdir))) .
- cscope )
- )
- "Alist of tools usable by `semantic-symref'.
-Each entry is of the form:
- ( PREDICATE . KEY )
-Where PREDICATE is a function that takes a directory name for the
-root of a project, and returns non-nil if the tool represented by KEY
-is supported.
-
-If no tools are supported, then `grep' is assumed.")
-
-(defun semantic-symref-calculate-rootdir ()
- "Calculate the root directory for a symref search.
-Start with an EDE project, or use the default directory."
- (let* ((rootproj (when (and (featurep 'ede) ede-minor-mode)
- (ede-toplevel)))
- (rootdirbase (if rootproj
- (ede-project-root-directory rootproj)
- default-directory)))
- (if (and rootproj (condition-case nil
- ;; Hack for subprojects.
- (oref rootproj metasubproject)
- (error nil)))
- (ede-up-directory rootdirbase)
- rootdirbase)))
-
-(defun semantic-symref-detect-symref-tool ()
- "Detect the symref tool to use for the current buffer."
- (if (not (eq semantic-symref-tool 'detect))
- semantic-symref-tool
- ;; We are to perform a detection for the right tool to use.
- (let* ((rootdir (semantic-symref-calculate-rootdir))
- (tools semantic-symref-tool-alist))
- (while (and tools (eq semantic-symref-tool 'detect))
- (when (funcall (car (car tools)) rootdir)
- (setq semantic-symref-tool (cdr (car tools))))
- (setq tools (cdr tools)))
-
- (when (eq semantic-symref-tool 'detect)
- (setq semantic-symref-tool 'grep))
-
- semantic-symref-tool)))
-
-(defun semantic-symref-instantiate (&rest args)
- "Instantiate a new symref search object.
-ARGS are the initialization arguments to pass to the created class."
- (let* ((srt (symbol-name (semantic-symref-detect-symref-tool)))
- (class (intern-soft (concat "semantic-symref-tool-" srt)))
- (inst nil)
- )
- (when (not (class-p class))
- (error "Unknown symref tool %s" semantic-symref-tool))
- (setq inst (apply #'make-instance class args))
- inst))
-
-(defvar semantic-symref-last-result nil
- "The last calculated symref result.")
-
-(defun semantic-symref-data-debug-last-result ()
- "Run the last symref data result in Data Debug."
- (interactive)
- (require 'eieio-datadebug)
- (if semantic-symref-last-result
- (progn
- (data-debug-new-buffer "*Symbol Reference ADEBUG*")
- (data-debug-insert-object-slots semantic-symref-last-result "]"))
- (message "Empty results.")))
-
-;;; EXTERNAL API
-;;
-
-;;;###autoload
-(defun semantic-symref-find-references-by-name (name &optional scope tool-return)
- "Find a list of references to NAME in the current project.
-Optional SCOPE specifies which file set to search. Defaults to `project'.
-Refers to `semantic-symref-tool', to determine the reference tool to use
-for the current buffer.
-Returns an object of class `semantic-symref-result'.
-TOOL-RETURN is an optional symbol, which will be assigned the tool used
-to perform the search. This was added for use by a test harness."
- (interactive "sName: ")
- (let* ((inst (semantic-symref-instantiate
- :searchfor name
- :searchtype 'symbol
- :searchscope (or scope 'project)
- :resulttype 'line))
- (result (semantic-symref-get-result inst)))
- (when tool-return
- (set tool-return inst))
- (prog1
- (setq semantic-symref-last-result result)
- (when (called-interactively-p 'interactive)
- (semantic-symref-data-debug-last-result))))
- )
-
-;;;###autoload
-(defun semantic-symref-find-tags-by-name (name &optional scope)
- "Find a list of tags by NAME in the current project.
-Optional SCOPE specifies which file set to search. Defaults to `project'.
-Refers to `semantic-symref-tool', to determine the reference tool to use
-for the current buffer.
-Returns an object of class `semantic-symref-result'."
- (interactive "sName: ")
- (let* ((inst (semantic-symref-instantiate
- :searchfor name
- :searchtype 'tagname
- :searchscope (or scope 'project)
- :resulttype 'line))
- (result (semantic-symref-get-result inst)))
- (prog1
- (setq semantic-symref-last-result result)
- (when (called-interactively-p 'interactive)
- (semantic-symref-data-debug-last-result))))
- )
-
-;;;###autoload
-(defun semantic-symref-find-tags-by-regexp (name &optional scope)
- "Find a list of references to NAME in the current project.
-Optional SCOPE specifies which file set to search. Defaults to `project'.
-Refers to `semantic-symref-tool', to determine the reference tool to use
-for the current buffer.
-Returns an object of class `semantic-symref-result'."
- (interactive "sName: ")
- (let* ((inst (semantic-symref-instantiate
- :searchfor name
- :searchtype 'tagregexp
- :searchscope (or scope 'project)
- :resulttype 'line))
- (result (semantic-symref-get-result inst)))
- (prog1
- (setq semantic-symref-last-result result)
- (when (called-interactively-p 'interactive)
- (semantic-symref-data-debug-last-result))))
- )
-
-;;;###autoload
-(defun semantic-symref-find-tags-by-completion (name &optional scope)
- "Find a list of references to NAME in the current project.
-Optional SCOPE specifies which file set to search. Defaults to `project'.
-Refers to `semantic-symref-tool', to determine the reference tool to use
-for the current buffer.
-Returns an object of class `semantic-symref-result'."
- (interactive "sName: ")
- (let* ((inst (semantic-symref-instantiate
- :searchfor name
- :searchtype 'tagcompletions
- :searchscope (or scope 'project)
- :resulttype 'line))
- (result (semantic-symref-get-result inst)))
- (prog1
- (setq semantic-symref-last-result result)
- (when (called-interactively-p 'interactive)
- (semantic-symref-data-debug-last-result))))
- )
-
-;;;###autoload
-(defun semantic-symref-find-file-references-by-name (name &optional scope)
- "Find a list of references to NAME in the current project.
-Optional SCOPE specifies which file set to search. Defaults to `project'.
-Refers to `semantic-symref-tool', to determine the reference tool to use
-for the current buffer.
-Returns an object of class `semantic-symref-result'."
- (interactive "sName: ")
- (let* ((inst (semantic-symref-instantiate
- :searchfor name
- :searchtype 'regexp
- :searchscope (or scope 'project)
- :resulttype 'file))
- (result (semantic-symref-get-result inst)))
- (prog1
- (setq semantic-symref-last-result result)
- (when (called-interactively-p 'interactive)
- (semantic-symref-data-debug-last-result))))
- )
-
-;;;###autoload
-(defun semantic-symref-find-text (text &optional scope)
- "Find a list of occurrences of TEXT in the current project.
-TEXT is a regexp formatted for use with grep -E.
-Optional SCOPE specifies which file set to search. Defaults to `project'.
-Refers to `semantic-symref-tool', to determine the reference tool to use
-for the current buffer.
-Returns an object of class `semantic-symref-result'."
- (interactive "sGrep -E style Regexp: ")
- (let* ((inst (semantic-symref-instantiate
- :searchfor text
- :searchtype 'regexp
- :searchscope (or scope 'project)
- :resulttype 'line))
- (result (semantic-symref-get-result inst)))
- (prog1
- (setq semantic-symref-last-result result)
- (when (called-interactively-p 'interactive)
- (semantic-symref-data-debug-last-result))))
- )
-
-;;; SYMREF TOOLS
-;;
-;; The base symref tool provides something to hang new tools off of
-;; for finding symbol references.
-(defclass semantic-symref-tool-baseclass ()
- ((searchfor :initarg :searchfor
- :type string
- :documentation "The thing to search for.")
- (searchtype :initarg :searchtype
- :type symbol
- :documentation "The type of search to do.
-Values could be 'symbol, 'regexp, 'tagname, or 'completion.")
- (searchscope :initarg :searchscope
- :type symbol
- :documentation
- "The scope to search for.
-Can be 'project, 'target, or 'file.")
- (resulttype :initarg :resulttype
- :type symbol
- :documentation
- "The kind of search results desired.
-Can be `line', `file', or `tag'.
-The type of result can be converted from `line' to `file', or `line' to `tag',
-but not from `file' to `line' or `tag'.")
- )
- "Baseclass for all symbol references tools.
-A symbol reference tool supplies functionality to identify the locations of
-where different symbols are used.
-
-Subclasses should be named `semantic-symref-tool-NAME', where
-NAME is the name of the tool used in the configuration variable
-`semantic-symref-tool'."
- :abstract t)
-
-(cl-defmethod semantic-symref-get-result ((tool semantic-symref-tool-baseclass))
- "Calculate the results of a search based on TOOL.
-The symref TOOL should already contain the search criteria."
- (let ((answer (semantic-symref-perform-search tool))
- )
- (when answer
- (let ((answersym (if (eq (oref tool resulttype) 'file)
- :hit-files
- (if (stringp (car answer))
- :hit-text
- :hit-lines))))
- (semantic-symref-result (oref tool searchfor)
- answersym
- answer
- :created-by tool))
- )
- ))
-
-(cl-defmethod semantic-symref-perform-search ((_tool semantic-symref-tool-baseclass))
- "Base search for symref tools should throw an error."
- (error "Symref tool objects must implement `semantic-symref-perform-search'"))
-
-(cl-defmethod semantic-symref-parse-tool-output ((tool semantic-symref-tool-baseclass)
- outputbuffer)
- "Parse the entire OUTPUTBUFFER of a symref tool.
-Calls the method `semantic-symref-parse-tool-output-one-line' over and
-over until it returns nil."
- (with-current-buffer outputbuffer
- (goto-char (point-min))
- (let ((result nil)
- (hit nil))
- (while (setq hit (semantic-symref-parse-tool-output-one-line tool))
- (setq result (cons hit result)))
- (nreverse result)))
- )
-
-(cl-defmethod semantic-symref-parse-tool-output-one-line ((_tool semantic-symref-tool-baseclass))
- "Base tool output parser is not implemented."
- (error "Symref tool objects must implement `semantic-symref-parse-tool-output-one-line'"))
-
-;;; RESULTS
-;;
-;; The results class and methods provide features for accessing hits.
-(defclass semantic-symref-result ()
- ((created-by :initarg :created-by
- :type semantic-symref-tool-baseclass
- :documentation
- "Back-pointer to the symref tool creating these results.")
- (hit-files :initarg :hit-files
- :type list
- :documentation
- "The list of files hit.")
- (hit-text :initarg :hit-text
- :type list
- :documentation
- "If the result doesn't provide full lines, then fill in hit-text.
-GNU Global does completion search this way.")
- (hit-lines :initarg :hit-lines
- :type list
- :documentation
- "The list of line hits.
-Each element is a cons cell of the form (LINE . FILENAME).")
- (hit-tags :initarg :hit-tags
- :type list
- :documentation
- "The list of tags with hits in them.
-Use the `semantic-symref-hit-to-tag-via-buffer' method to get
-this list.")
- )
- "The results from a symbol reference search.")
-
-(cl-defmethod semantic-symref-result-get-files ((result semantic-symref-result))
- "Get the list of files from the symref result RESULT."
- (if (slot-boundp result 'hit-files)
- (oref result hit-files)
- (let* ((lines (oref result hit-lines))
- (files (mapcar (lambda (a) (cdr a)) lines))
- (ans nil))
- (setq ans (list (car files))
- files (cdr files))
- (dolist (F files)
- ;; This algorithm for uniquifying the file list depends on the
- ;; tool in question providing all the hits in the same file
- ;; grouped together.
- (when (not (string= F (car ans)))
- (setq ans (cons F ans))))
- (oset result hit-files (nreverse ans))
- )
- ))
-
-(defvar semantic-symref-recently-opened-buffers nil
- "List of buffers opened by `semantic-symref-result-get-tags'.")
-
-(defun semantic-symref-cleanup-recent-buffers-fcn ()
- "Hook function to be used in `post-command-hook' to cleanup buffers.
-Buffers collected during symref can result in some files being
-opened multiple times for one operation. This will keep buffers open
-until the next command is executed."
- ;;(message "To Clean Up: %S" semantic-symref-recently-opened-buffers)
- (mapc (lambda (buff)
- ;; Don't delete any buffers which are being used
- ;; upon completion of some command.
- (when (not (get-buffer-window buff))
- (kill-buffer buff)))
- semantic-symref-recently-opened-buffers)
- (setq semantic-symref-recently-opened-buffers nil)
- (remove-hook 'post-command-hook #'semantic-symref-cleanup-recent-buffers-fcn)
- )
-
-(cl-defmethod semantic-symref-result-get-tags ((result semantic-symref-result)
- &optional open-buffers)
- "Get the list of tags from the symref result RESULT.
-Optional OPEN-BUFFERS indicates that the buffers that the hits are
-in should remain open after scanning.
-Note: This can be quite slow if most of the hits are not in buffers
-already."
- (if (and (slot-boundp result 'hit-tags) (oref result hit-tags))
- (oref result hit-tags)
- ;; Calculate the tags.
- (let ((lines (oref result hit-lines))
- (txt (oref (oref result created-by) searchfor))
- (searchtype (oref (oref result created-by) searchtype))
- (ans nil)
- (out nil))
- (save-excursion
- (setq ans (mapcar
- (lambda (hit)
- (semantic-symref-hit-to-tag-via-buffer
- hit txt searchtype open-buffers))
- lines)))
- ;; Kill off dead buffers, unless we were requested to leave them open.
- (if (not open-buffers)
- (add-hook 'post-command-hook #'semantic-symref-cleanup-recent-buffers-fcn)
- ;; Else, just clear the saved buffers so they aren't deleted later.
- (setq semantic-symref-recently-opened-buffers nil)
- )
- ;; Strip out duplicates.
- (dolist (T ans)
- (if (and T (not (semantic-equivalent-tag-p (car out) T)))
- (setq out (cons T out))
- (when T
- ;; Else, add this line into the existing list of lines.
- (let ((lines (append (semantic--tag-get-property (car out) :hit)
- (semantic--tag-get-property T :hit))))
- (semantic--tag-put-property (car out) :hit lines)))
- ))
- ;; Out is reversed... twice
- (oset result hit-tags (nreverse out)))))
-
-(defun semantic-symref-hit-to-tag-via-db (hit searchtxt searchtype)
- "Convert the symref HIT into a TAG by looking up the tag via a database.
-Return the Semantic tag associated with HIT.
-SEARCHTXT is the text that is being searched for.
-Used to narrow the in-buffer search.
-SEARCHTYPE is the type of search (such as `symbol' or `tagname').
-If there is no database, or if the searchtype is wrong, return nil."
- ;; Allowed search types for this mechanism:
- ;; tagname, tagregexp, tagcompletions
- (if (not (memq searchtype '(tagname tagregexp tagcompletions)))
- nil
- (let* ((file (cdr hit))
- ;; FAIL here vv - don't load is not obeyed if no table found.
- (db (semanticdb-file-table-object file t))
- (found
- (cond ((eq searchtype 'tagname)
- (semantic-find-tags-by-name searchtxt db))
- ((eq searchtype 'tagregexp)
- (semantic-find-tags-by-name-regexp searchtxt db))
- ((eq searchtype 'tagcompletions)
- (semantic-find-tags-for-completion searchtxt db))))
- (hit nil)
- )
- ;; Loop over FOUND to see if we can line up a match with a line number.
- (when (= (length found) 1)
- (setq hit (car found)))
-
- ;; FAIL here ^^ - symref finds line numbers, but our DB uses character locations.
- ;; as such, this is a cheat and we will need to give up.
- hit)))
-
-(defun semantic-symref-hit-to-tag-via-buffer (hit searchtxt searchtype &optional open-buffers)
- "Convert the symref HIT into a TAG by looking up the tag via a buffer.
-Return the Semantic tag associated with HIT.
-SEARCHTXT is the text that is being searched for.
-Used to narrow the in-buffer search.
-SEARCHTYPE is the type of search (such as `symbol' or `tagname').
-Optional OPEN-BUFFERS, when nil will use a faster version of
-`find-file' when a file needs to be opened. If non-nil, then
-normal buffer initialization will be used.
-This function will leave buffers loaded from a file open, but
-will add buffers that must be opened to
-`semantic-symref-recently-opened-buffers'.
-Any caller MUST deal with that variable, either clearing it, or
-deleting the buffers that were opened."
- (let* ((line (car hit))
- (file (cdr hit))
- (buff (find-buffer-visiting file))
- (tag nil)
- )
- (cond
- ;; We have a buffer already. Check it out.
- (buff
- (set-buffer buff))
-
- ;; We have a table, but it needs a refresh.
- ;; This means we should load in that buffer.
- (t
- (let ((kbuff
- (if open-buffers
- ;; Even if we keep the buffers open, don't
- ;; let EDE ask lots of questions.
- (let ((ede-auto-add-method 'never))
- (find-file-noselect file t))
- ;; When not keeping the buffers open, then
- ;; don't setup all the fancy froo-froo features
- ;; either.
- (semantic-find-file-noselect file t))))
- (set-buffer kbuff)
- (push kbuff semantic-symref-recently-opened-buffers)
- (semantic-fetch-tags)
- ))
- )
-
- ;; Too much baggage in goto-line
- ;; (goto-line line)
- (goto-char (point-min))
- (forward-line (1- line))
-
- ;; Search forward for the matching text.
- ;; FIXME: This still fails if the regexp uses something specific
- ;; to the extended syntax, like grouping.
- (when (re-search-forward (if (memq searchtype '(regexp tagregexp))
- searchtxt
- (regexp-quote searchtxt))
- (line-end-position)
- t)
- (goto-char (match-beginning 0))
- )
-
- (setq tag (semantic-current-tag))
-
- ;; If we are searching for a tag, but bound the tag we are looking
- ;; for, see if it resides in some other parent tag.
- ;;
- ;; If there is no parent tag, then we still need to hang the originator
- ;; in our list.
- (when (and (eq searchtype 'symbol)
- (string= (semantic-tag-name tag) searchtxt))
- (setq tag (or (semantic-current-tag-parent) tag)))
-
- ;; Copy the tag, which adds a :filename property.
- (when tag
- (setq tag (semantic-tag-copy tag nil t))
- ;; Ad this hit to the tag.
- (semantic--tag-put-property tag :hit (list line)))
- tag))
-
-(provide 'semantic/symref)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/symref"
-;; End:
-
-;;; semantic/symref.el ends here
+++ /dev/null
-;;; semantic/symref/cscope.el --- Semantic-symref support via cscope -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic symref support via cscope.
-
-(require 'cedet-cscope)
-(require 'semantic/symref)
-
-(defvar ede-minor-mode)
-(declare-function ede-toplevel "ede/base")
-(declare-function ede-project-root-directory "ede/files")
-
-;;; Code:
-;;;###autoload
-(defclass semantic-symref-tool-cscope (semantic-symref-tool-baseclass)
- (
- )
- "A symref tool implementation using CScope.
-The CScope command can be used to generate lists of tags in a way
-similar to that of `grep'. This tool will parse the output to generate
-the hit list.
-
-See the function `cedet-cscope-search' for more details.")
-
-(cl-defmethod semantic-symref-perform-search ((tool semantic-symref-tool-cscope))
- "Perform a search with CScope."
- (let* ((rootproj (when (and (featurep 'ede) ede-minor-mode)
- (ede-toplevel)))
- (default-directory (if rootproj
- (ede-project-root-directory rootproj)
- default-directory))
- ;; CScope has to be run from the project root where
- ;; cscope.out is.
- (b (cedet-cscope-search (oref tool searchfor)
- (oref tool searchtype)
- (oref tool resulttype)
- (oref tool searchscope))))
- (semantic-symref-parse-tool-output tool b)))
-
-(defconst semantic-symref-cscope--line-re
- "^\\([^ ]+\\) [^ ]+ \\([0-9]+\\) ")
-
-(cl-defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-cscope))
- "Parse one line of grep output, and return it as a match list.
-Moves cursor to end of the match."
- (cond ((eq (oref tool resulttype) 'file)
- ;; Search for files
- (when (re-search-forward "^\\([^\n]+\\)$" nil t)
- (match-string 1)))
- ((eq (oref tool searchtype) 'tagcompletions)
- ;; Search for files
- (when (re-search-forward "^[^ ]+ [^ ]+ [^ ]+ \\(.*\\)$" nil t)
- (let ((subtxt (match-string 1))
- (searchtxt (oref tool searchfor)))
- (if (string-match (concat "\\<" searchtxt "\\(\\w\\|\\s_\\)*\\>")
- subtxt)
- (match-string 0 subtxt)
- ;; We have to return something at this point.
- subtxt)))
- )
- ((eq (oref tool resulttype) 'line-and-text)
- (when (re-search-forward semantic-symref-cscope--line-re nil t)
- (list (string-to-number (match-string 2))
- (expand-file-name (match-string 1))
- (buffer-substring-no-properties (point) (line-end-position)))))
- (t ; :resulttype is 'line
- (when (re-search-forward semantic-symref-cscope--line-re nil t)
- (cons (string-to-number (match-string 2))
- (expand-file-name (match-string 1)))
- ))))
-
-(provide 'semantic/symref/cscope)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/symref/cscope"
-;; End:
-
-;;; semantic/symref/cscope.el ends here
+++ /dev/null
-;;; semantic/symref/filter.el --- Filter symbol reference hits for accuracy -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Filter symbol reference hits for accuracy.
-;;
-;; Most symbol referencing tools, such as find/grep only find matching
-;; strings, but cannot determine the difference between an actual use,
-;; and something else with a similar name, or even a string in a comment.
-;;
-;; This file provides utilities for filtering down to accurate matches
-;; starting at a basic filter level that doesn't use symref, up to filters
-;; across symref results.
-
-;;; Code:
-
-(require 'semantic)
-(require 'semantic/analyze)
-(declare-function srecode-active-template-region "srecode/fields")
-(declare-function srecode-delete "srecode/fields")
-(declare-function srecode-field "srecode/fields")
-(declare-function srecode-template-inserted-region "srecode/fields")
-(declare-function srecode-overlaid-activate "srecode/fields")
-(declare-function semantic-idle-summary-useful-context-p "semantic/idle")
-
-;;; FILTERS
-;;
-(defun semantic-symref-filter-hit (target &optional position)
- "Determine if the tag TARGET is used at POSITION in the current buffer.
-Return non-nil for a match."
- (semantic-analyze-current-symbol
- (lambda (_start _end prefix)
- (let ((tag (car (nreverse prefix))))
- (and (semantic-tag-p tag)
- (semantic-equivalent-tag-p target tag))))
- position))
-
-;;; IN-BUFFER FILTERING
-
-;; The following does filtering in-buffer only, and not against
-;; a symref results object.
-
-(defun semantic-symref-hits-in-region (target hookfcn start end)
- "Find all occurrences of the symbol TARGET that match TARGET the tag.
-For each match, call HOOKFCN.
-HOOKFCN takes three arguments that match
-`semantic-analyze-current-symbol's use of HOOKFCN.
- ( START END PREFIX )
-
-Search occurs in the current buffer between START and END."
- (require 'semantic/idle)
- (save-excursion
- (goto-char start)
- (let* ((str (semantic-tag-name target))
- (case-fold-search semantic-case-fold)
- (regexp (concat "\\<" (regexp-quote str) "\\>")))
- (while (re-search-forward regexp end t)
- (when (semantic-idle-summary-useful-context-p)
- (semantic-analyze-current-symbol
- (lambda (start end prefix)
- (let ((tag (car (nreverse prefix))))
- ;; check for semantic match on the text match.
- (when (and (semantic-tag-p tag)
- (semantic-equivalent-tag-p target tag))
- (save-excursion
- (funcall hookfcn start end prefix)))))
- (point)))))))
-
-(defun semantic-symref-test-count-hits-in-tag ()
- "Lookup in the current tag the symbol under point.
-the count all the other references to the same symbol within the
-tag that contains point, and return that."
- (interactive)
- (let* ((ctxt (semantic-analyze-current-context))
- (target (car (reverse (oref ctxt prefix))))
- (tag (semantic-current-tag))
- (start (current-time))
- (Lcount 0))
- (when (semantic-tag-p target)
- (semantic-symref-hits-in-region
- target (lambda (_start _end _prefix) (setq Lcount (1+ Lcount)))
- (semantic-tag-start tag)
- (semantic-tag-end tag))
- (when (called-interactively-p 'interactive)
- (message "Found %d occurrences of %s in %.2f seconds"
- Lcount (semantic-tag-name target)
- (semantic-elapsed-time start nil)))
- Lcount)))
-
-(defvar srecode-field-archive)
-
-(defun semantic-symref-rename-local-variable ()
- "Fancy way to rename the local variable under point.
-Depends on the SRecode Field editing API."
- (interactive)
- ;; Do the replacement as needed.
- (let* ((ctxt (semantic-analyze-current-context))
- (target (car (reverse (oref ctxt prefix))))
- (tag (semantic-current-tag))
- )
-
- (when (or (not target)
- (not (semantic-tag-with-position-p target)))
- (error "Cannot identify symbol under point"))
-
- (when (not (semantic-tag-of-class-p target 'variable))
- (error "Can only rename variables"))
-
- (when (or (< (semantic-tag-start target) (semantic-tag-start tag))
- (> (semantic-tag-end target) (semantic-tag-end tag)))
- (error "Can only rename variables declared in %s"
- (semantic-tag-name tag)))
-
- ;; I think we're good for this example. Give it a go through
- ;; our fancy interface from SRecode.
- (require 'srecode/fields)
-
- ;; Make sure there is nothing active.
- (let ((ar (srecode-active-template-region)))
- (when ar (srecode-delete ar)))
-
- (let ((srecode-field-archive nil)
- (region nil)
- )
- (semantic-symref-hits-in-region
- target (lambda (start end _prefix)
- ;; For every valid hit, create one field.
- (srecode-field "LOCAL" :name "LOCAL" :start start :end end))
- (semantic-tag-start tag) (semantic-tag-end tag))
-
- ;; Now that the fields are setup, create the region.
- (setq region (srecode-template-inserted-region
- "REGION" :start (semantic-tag-start tag)
- :end (semantic-tag-end tag)))
-
- ;; Activate the region.
- (srecode-overlaid-activate region)
-
- )
- ))
-
-(provide 'semantic/symref/filter)
-
-;;; semantic/symref/filter.el ends here
+++ /dev/null
-;;; semantic/symref/global.el --- Use GNU Global for symbol references -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; GNU Global use with the semantic-symref system.
-
-(require 'cedet-global)
-(require 'semantic/symref)
-
-;;; Code:
-;;;###autoload
-(defclass semantic-symref-tool-global (semantic-symref-tool-baseclass)
- (
- )
- "A symref tool implementation using GNU Global.
-The GNU Global command can be used to generate lists of tags in a way
-similar to that of `grep'. This tool will parse the output to generate
-the hit list.
-
-See the function `cedet-gnu-global-search' for more details.")
-
-(cl-defmethod semantic-symref-perform-search ((tool semantic-symref-tool-global))
- "Perform a search with GNU Global."
- (let ((b (cedet-gnu-global-search (oref tool searchfor)
- (oref tool searchtype)
- (oref tool resulttype)
- (oref tool searchscope))))
- (semantic-symref-parse-tool-output tool b)))
-
-(defconst semantic-symref-global--line-re
- "^\\([^ ]+\\) +\\([0-9]+\\) \\([^ ]+\\) ")
-
-(cl-defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-global))
- "Parse one line of grep output, and return it as a match list.
-Moves cursor to end of the match."
- (cond ((or (eq (oref tool resulttype) 'file)
- (eq (oref tool searchtype) 'tagcompletions))
- ;; Search for files
- (when (re-search-forward "^\\([^\n]+\\)$" nil t)
- (match-string 1)))
- ((eq (oref tool resulttype) 'line-and-text)
- (when (re-search-forward semantic-symref-global--line-re nil t)
- (list (string-to-number (match-string 2))
- (match-string 3)
- (buffer-substring-no-properties (point) (line-end-position)))))
- (t
- (when (re-search-forward semantic-symref-global--line-re nil t)
- (cons (string-to-number (match-string 2))
- (match-string 3))
- ))))
-
-(provide 'semantic/symref/global)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/symref/global"
-;; End:
-
-;;; semantic/symref/global.el ends here
+++ /dev/null
-;;; semantic/symref/grep.el --- Symref implementation using find/grep -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Implement the symref tool API using the external tools find/grep.
-;;
-;; The symref GREP tool uses grep in a project to find symbol references.
-;; This is a lowest-common-denominator tool with sucky performance that
-;; can be used in small projects to find symbol references.
-
-(require 'semantic/symref)
-(require 'grep)
-
-;;; Code:
-
-;;; GREP
-;;;###autoload
-(defclass semantic-symref-tool-grep (semantic-symref-tool-baseclass)
- (
- )
- "A symref tool implementation using grep.
-This tool uses EDE to find the root of the project, then executes
-`find-grep' in the project. The output is parsed for hits and
-those hits returned.")
-
-(defvar semantic-symref-filepattern-alist nil "Unused obsolete variable.")
-(make-obsolete-variable 'semantic-symref-filepattern-alist
- 'grep-filepattern-alist "30.1")
-
-(defun semantic-symref-derive-find-filepatterns (&optional mode)
- "Derive a list of file (glob) patterns for the current buffer.
-Looks first in `grep-filepattern-alist'. If it is not there, it then
-looks in `auto-mode-alist', and attempts to derive something from that.
-Optional argument MODE specifies the `major-mode' to test."
- ;; First, try the filepattern alist.
- (let* ((mode (or mode major-mode))
- (pat (cdr (assoc mode grep-filepattern-alist))))
- (when (not pat)
- ;; No hit, try auto-mode-alist.
- (dolist (X auto-mode-alist)
- (when (and (eq (cdr X) mode)
- ;; Only take in simple patterns, so try to convert this one.
- (string-match "\\\\\\.\\([^\\'>]+\\)\\\\'" (car X)))
- (push (concat "*." (match-string 1 (car X))) pat))))
- ;; Convert the list into some find-flags.
- (if (null pat)
- (error "Customize `grep-filepattern-alist' for %S"
- major-mode)
- (let ((args `("-name" ,(car pat))))
- (if (null (cdr pat))
- args
- `("(" ,@args
- ,@(mapcan (lambda (s) `("-o" "-name" ,s)) (cdr pat))
- ")"))))))
-
-(defvar semantic-symref-grep-flags)
-
-(defvar semantic-symref-grep-expand-keywords
- (condition-case nil
- (let* ((kw (copy-alist grep-expand-keywords))
- (C (assoc "<C>" kw)))
- (setcdr C 'semantic-symref-grep-flags)
- kw)
- (error nil))
- "Grep expand keywords used when expanding templates for symref.")
-
-(defun semantic-symref-grep-use-template (rootdir filepattern flags pattern)
- "Use the grep template expand feature to create a grep command.
-ROOTDIR is the root location to run the `find' from.
-FILEPATTERN is a string representing find flags for searching file patterns.
-FLAGS are flags passed to Grep, such as -n or -l.
-PATTERN is the pattern used by Grep."
- ;; We have grep-compute-defaults. Let's use it.
- (grep-compute-defaults)
- (let* ((semantic-symref-grep-flags flags)
- (grep-expand-keywords semantic-symref-grep-expand-keywords)
- (cmd (grep-expand-template
- (if (memq system-type '(windows-nt ms-dos))
- ;; FIXME: Is this still needed?
- ;; grep-find uses '--color=always' on MS-Windows
- ;; because it wants the colorized output, to show
- ;; it to the user. By contrast, here we don't show
- ;; the output, and the SGR escapes get in the way
- ;; of parsing the output.
- (replace-regexp-in-string "--color=always" ""
- grep-find-template t t)
- grep-find-template)
- pattern
- filepattern
- rootdir)))
- cmd))
-
-(defcustom semantic-symref-grep-shell shell-file-name
- "The shell command to use for executing find/grep.
-This shell should support pipe redirect syntax."
- :group 'semantic
- :type 'string)
-
-(defun semantic-symref-grep--quote-grep (string)
- "Quote STRING as a grep-syntax regexp."
- (replace-regexp-in-string (rx (in ".^$*[\\"))
- (lambda (s) (concat "\\" s))
- string nil t))
-
-(defvar semantic-symref-grep--local-dir nil)
-
-(cl-defmethod semantic-symref-perform-search ((tool semantic-symref-tool-grep))
- "Perform a search with Grep."
- ;; Grep doesn't support some types of searches.
- (let ((st (oref tool searchtype)))
- (when (not (memq st '(symbol regexp)))
- (error "Symref impl GREP does not support searchtype of %s" st))
- )
- ;; Find the root of the project, and do a find-grep...
- (let* (;; Find the file patterns to use.
- (rootdir (semantic-symref-calculate-rootdir))
- (filepatterns (semantic-symref-derive-find-filepatterns))
- (filepattern (mapconcat #'shell-quote-argument filepatterns " "))
- ;; Grep based flags.
- (grepflags (cond ((eq (oref tool resulttype) 'file)
- "-l ")
- ((eq (oref tool searchtype) 'regexp)
- "-nE ")
- (t "-nw ")))
- (searchfor (oref tool searchfor))
- (greppat (if (eq (oref tool searchtype) 'regexp)
- searchfor
- (semantic-symref-grep--quote-grep searchfor)))
- ;; Misc
- (b (get-buffer-create "*Semantic SymRef*"))
- (ans nil)
- )
-
- (with-current-buffer b
- (erase-buffer)
- (setq default-directory rootdir)
- (let ((cmd (semantic-symref-grep-use-template
- "."
- filepattern grepflags greppat)))
- (process-file semantic-symref-grep-shell nil b nil
- shell-command-switch cmd)))
- (let ((semantic-symref-grep--local-dir (directory-file-name (file-local-name rootdir))))
- (setq ans (semantic-symref-parse-tool-output tool b)))
- ;; Return the answer
- ans))
-
-(cl-defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-grep))
- "Parse one line of grep output, and return it as a match list.
-Moves cursor to end of the match."
- (pcase-let
- ((`(,grep-re ,file-group ,line-group . ,_) (car grep-regexp-alist)))
- (cond ((eq (oref tool resulttype) 'file)
- ;; Search for files
- (when (re-search-forward "^\\([^\n]+\\)$" nil t)
- (match-string 1)))
- ((eq (oref tool resulttype) 'line-and-text)
- (when (re-search-forward grep-re nil t)
- (list (string-to-number (match-string line-group))
- (concat semantic-symref-grep--local-dir (substring (match-string file-group) 1))
- (buffer-substring-no-properties (point) (line-end-position)))))
- (t
- (when (re-search-forward grep-re nil t)
- (cons (string-to-number (match-string line-group))
- (concat semantic-symref-grep--local-dir (substring (match-string file-group) 1)))
- )))))
-
-(provide 'semantic/symref/grep)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/symref/grep"
-;; End:
-
-;;; semantic/symref/grep.el ends here
+++ /dev/null
-;;; semantic/symref/idutils.el --- Symref implementation for idutils -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Support IDUtils use in the Semantic Symref tool.
-
-(require 'cedet-idutils)
-(require 'semantic/symref)
-
-;;; Code:
-;;;###autoload
-(defclass semantic-symref-tool-idutils (semantic-symref-tool-baseclass)
- (
- )
- "A symref tool implementation using ID Utils.
-The udutils command set can be used to generate lists of tags in a way
-similar to that of `grep'. This tool will parse the output to generate
-the hit list.
-
-See the function `cedet-idutils-search' for more details.")
-
-(cl-defmethod semantic-symref-perform-search ((tool semantic-symref-tool-idutils))
- "Perform a search with IDUtils."
- (let ((b (cedet-idutils-search (oref tool searchfor)
- (oref tool searchtype)
- (oref tool resulttype)
- (oref tool searchscope))))
- (semantic-symref-parse-tool-output tool b)))
-
-(defconst semantic-symref-idutils--line-re
- "^\\(\\(?:[a-zA-Z]:\\)?[^:\n]+\\):\\([0-9]+\\):")
-
-(cl-defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-idutils))
- "Parse one line of grep output, and return it as a match list.
-Moves cursor to end of the match."
- (cond ((eq (oref tool resulttype) 'file)
- ;; Search for files
- (when (re-search-forward "^\\([^\n]+\\)$" nil t)
- (match-string 1)))
- ((eq (oref tool searchtype) 'tagcompletions)
- (when (re-search-forward "^\\([^ ]+\\) " nil t)
- (match-string 1)))
- ((eq (oref tool resulttype) 'line-and-text)
- (when (re-search-forward semantic-symref-idutils--line-re nil t)
- (list (string-to-number (match-string 2))
- (expand-file-name (match-string 1) default-directory)
- (buffer-substring-no-properties (point) (line-end-position)))))
- (t ; resulttype is line
- (when (re-search-forward semantic-symref-idutils--line-re nil t)
- (cons (string-to-number (match-string 2))
- (expand-file-name (match-string 1) default-directory))
- ))))
-
-(provide 'semantic/symref/idutils)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/symref/idutils"
-;; End:
-
-;;; semantic/symref/idutils.el ends here
+++ /dev/null
-;;; semantic/symref/list.el --- Symref Output List UI -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Provide a simple user facing API to finding symbol references.
-;;
-;; This UI is the base of some refactoring tools. For any refactor,
-;; the user will execute `semantic-symref' in a tag.
-;; Once that data is collected, the output will be listed in a buffer.
-;; In the output buffer, the user can then initiate different
-;; refactoring operations.
-;;
-;; NOTE: Need to add some refactoring tools.
-
-(require 'semantic/symref)
-(require 'semantic/complete)
-(require 'semantic/senator)
-(require 'pulse)
-
-;;; Code:
-
-;;;###autoload
-(defun semantic-symref ()
- "Find references to the current tag.
-This command uses the currently configured references tool within the
-current project to find references to the current tag. The
-references are organized by file and the name of the function
-they are used in.
-Display the references in `semantic-symref-results-mode'."
- (interactive)
- (semantic-fetch-tags)
- (let ((ct (semantic-current-tag)))
- ;; Must have a tag...
- (when (not ct) (error "Place cursor inside tag to be searched for"))
- ;; Check with user.
- (when (not (y-or-n-p (format "Find references for %s? "
- (semantic-tag-name ct))))
- (error "Quit"))
- ;; Gather results and tags
- (message "Gathering References...")
- (let* ((name (semantic-tag-name ct))
- (res (semantic-symref-find-references-by-name name)))
- (semantic-symref-produce-list-on-results res name))))
-
-;;;###autoload
-(defun semantic-symref-symbol (sym)
- "Find references to the symbol SYM.
-This command uses the currently configured references tool within the
-current project to find references to the input SYM. The
-references are organized by file and the name of the function
-they are used in.
-Display the references in `semantic-symref-results-mode'."
- (interactive (list (semantic-tag-name (semantic-complete-read-tag-project
- "Symrefs for: "))))
- (semantic-fetch-tags)
- ;; Gather results and tags
- (message "Gathering References...")
- (let ((res (semantic-symref-find-references-by-name sym)))
- (semantic-symref-produce-list-on-results res sym)))
-
-;;;###autoload
-(defun semantic-symref-regexp (sym)
- "Find references to the a symbol regexp SYM.
-This command uses the currently configured references tool within the
-current project to find references to the input SYM. The
-references are the organized by file and the name of the function
-they are used in.
-Display the references in `semantic-symref-results-mode'."
- (interactive (list (let* ((tag (semantic-current-tag))
- (default (when tag
- (regexp-quote
- (semantic-tag-name tag)))))
- (read-string (format-prompt " Symrefs for" default)
- nil nil default))))
- ;; FIXME: Shouldn't the input be in Emacs regexp format, for
- ;; consistency? Converting it to extended is not hard.
- (semantic-fetch-tags)
- (message "Gathering References...")
- ;; Gather results and tags
- (let ((res (semantic-symref-find-text sym)))
- (semantic-symref-produce-list-on-results res sym)))
-
-;;; RESULTS MODE
-;;
-(defgroup semantic-symref-results-mode nil
- "Symref Results group."
- :group 'semantic)
-
-(defvar semantic-symref-results-mode-map
- (let ((km (make-sparse-keymap)))
- (suppress-keymap km)
- (define-key km "\C-i" #'forward-button)
- (define-key km "\M-C-i" #'backward-button)
- (define-key km " " #'push-button)
- (define-key km "-" #'semantic-symref-list-toggle-showing)
- (define-key km "=" #'semantic-symref-list-toggle-showing)
- (define-key km "+" #'semantic-symref-list-toggle-showing)
- (define-key km "n" #'semantic-symref-list-next-line)
- (define-key km "p" #'semantic-symref-list-prev-line)
- (define-key km "q" #'quit-window)
- (define-key km "\C-c\C-e" #'semantic-symref-list-expand-all)
- (define-key km "\C-c\C-r" #'semantic-symref-list-contract-all)
- (define-key km "R" #'semantic-symref-list-rename-open-hits)
- (define-key km "(" #'semantic-symref-list-create-macro-on-open-hit)
- (define-key km "E" #'semantic-symref-list-call-macro-on-open-hits)
- km)
- "Keymap used in `semantic-symref-results-mode'.")
-
-(defvar semantic-symref-list-menu-entries
- (list
- "Symref"
- ["Toggle Line Open"
- semantic-symref-list-toggle-showing
- :active t
- :help "Toggle the current line open or closed." ]
- ["Expand All Entries"
- semantic-symref-list-expand-all
- :active t
- :help "Expand every expandable entry." ]
- ["Contract All Entries"
- semantic-symref-list-contract-all
- :active t
- :help "Close every expandable entry." ]
- ["Rename Symbol in Open hits"
- semantic-symref-list-rename-open-hits
- :active t
- :help "Rename the searched for symbol in all hits that are currently open."
- ])
- "Menu entries for the Semantic Symref list mode.")
-
-(defvar semantic-symref-list-menu nil
- "Menu keymap build from `semantic-symref-results-mode'.")
-
-(easy-menu-define semantic-symref-list-menu
- semantic-symref-results-mode-map
- "Symref Mode Menu."
- semantic-symref-list-menu-entries)
-
-(defcustom semantic-symref-auto-expand-results nil
- "Non-nil to expand symref results on buffer creation."
- :type 'boolean)
-
-(defcustom semantic-symref-results-mode-hook nil
- "Hook run when `semantic-symref-results-mode' starts."
- :type 'hook)
-
-(defvar semantic-symref-current-results nil
- "The current results in a results mode buffer.")
-
-(defun semantic-symref-produce-list-on-results (res str)
- "Produce a symref list mode buffer on the results RES."
- (when (not res) (error "No references found"))
- (semantic-symref-result-get-tags res t)
- (message "Gathering References...done")
- ;; Build a references buffer.
- (let ((buff (get-buffer-create (format "*Symref %s" str))))
- (switch-to-buffer-other-window buff)
- (set-buffer buff)
- (semantic-symref-results-mode)
- (setq-local semantic-symref-current-results res)
- (semantic-symref-results-dump res)
- (goto-char (point-min))))
-
-(define-derived-mode semantic-symref-results-mode nil "Symref"
- "Major-mode for displaying Semantic Symbol Reference results."
- (buffer-disable-undo)
- ;; FIXME: Why bother turning off font-lock?
- (setq-local font-lock-global-modes nil)
- (font-lock-mode -1))
-
-(defcustom semantic-symref-results-summary-function 'semantic-format-tag-prototype
- "Function to use when creating items in Imenu.
-Some useful functions are found in `semantic-format-tag-functions'."
- :type semantic-format-tag-custom-list)
-
-(defun semantic-symref-results-dump (results)
- "Dump the RESULTS into the current buffer."
- ;; Get ready for the insert.
- (let ((inhibit-read-only t))
- (erase-buffer)
- ;; Insert the contents.
- (let ((lastfile nil))
- (dolist (T (oref results hit-tags))
- (unless (equal lastfile (semantic-tag-file-name T))
- (setq lastfile (semantic-tag-file-name T))
- (insert-button lastfile
- 'mouse-face 'custom-button-pressed-face
- 'action 'semantic-symref-rb-goto-file
- 'tag T)
- (insert "\n"))
- (insert " ")
- (insert-button "[+]"
- 'mouse-face 'highlight
- 'face nil
- 'action 'semantic-symref-rb-toggle-expand-tag
- 'tag T
- 'state 'closed)
- (insert " ")
- (insert-button (funcall semantic-symref-results-summary-function
- T nil t)
- 'mouse-face 'custom-button-pressed-face
- 'face nil
- 'action 'semantic-symref-rb-goto-tag
- 'tag T)
- (insert "\n")))
- ;; Auto expand
- (when semantic-symref-auto-expand-results
- (semantic-symref-list-expand-all)))
- ;; Clean up the mess
- (set-buffer-modified-p nil))
-
-;;; Commands for semantic-symref-results
-;;
-(defun semantic-symref-list-toggle-showing ()
- "Toggle showing the contents below the current line."
- (interactive)
- (beginning-of-line)
- (when (re-search-forward "\\[[-+]\\]" (line-end-position) t)
- (forward-char -1)
- (push-button)))
-
-(defun semantic-symref-rb-toggle-expand-tag (&optional button)
- "Go to the file specified in the symref results buffer.
-BUTTON is the button that was clicked."
- (interactive)
- (let* ((tag (button-get button 'tag))
- (buff (semantic-tag-buffer tag))
- (hits (semantic--tag-get-property tag :hit))
- (state (button-get button 'state))
- (text nil))
- (cond
- ((eq state 'closed)
- (with-current-buffer buff
- (dolist (H hits)
- (goto-char (point-min))
- (forward-line (1- H))
- (beginning-of-line)
- (back-to-indentation)
- (setq text (cons (buffer-substring (point) (line-end-position)) text)))
- (setq text (nreverse text)))
- (goto-char (button-start button))
- (forward-char 1)
- (let ((inhibit-read-only t))
- (delete-char 1)
- (insert "-")
- (button-put button 'state 'open)
- (save-excursion
- (end-of-line)
- (while text
- (insert "\n")
- (insert " ")
- (insert-button (car text)
- 'mouse-face 'highlight
- 'face nil
- 'action 'semantic-symref-rb-goto-match
- 'tag tag
- 'line (car hits))
- (setq text (cdr text)
- hits (cdr hits))))))
- ((eq state 'open)
- (let ((inhibit-read-only t))
- (button-put button 'state 'closed)
- ;; Delete the various bits.
- (goto-char (button-start button))
- (forward-char 1)
- (delete-char 1)
- (insert "+")
- (save-excursion
- (end-of-line)
- (forward-char 1)
- (delete-region (point)
- (save-excursion
- (forward-char 1)
- (forward-line (length hits))
- (point)))))))))
-
-(defun semantic-symref-rb-goto-file (&optional button)
- "Go to the file specified in the symref results buffer.
-BUTTON is the button that was clicked."
- (let* ((tag (button-get button 'tag))
- (buff (semantic-tag-buffer tag))
- (win (selected-window))
- )
- (switch-to-buffer-other-window buff)
- (pulse-momentary-highlight-one-line (point))
- (when (eq last-command-event ?\s) (select-window win))
- ))
-
-
-(defun semantic-symref-rb-goto-tag (&optional button)
- "Go to the file specified in the symref results buffer.
-BUTTON is the button that was clicked."
- (interactive)
- (let* ((tag (button-get button 'tag))
- (buff (semantic-tag-buffer tag))
- (win (selected-window))
- )
- (switch-to-buffer-other-window buff)
- (semantic-go-to-tag tag)
- (pulse-momentary-highlight-one-line (point))
- (when (eq last-command-event ?\s) (select-window win))
- )
- )
-
-(defun semantic-symref-rb-goto-match (&optional button)
- "Go to the file specified in the symref results buffer.
-BUTTON is the button that was clicked."
- (interactive)
- (let* ((tag (button-get button 'tag))
- (line (button-get button 'line))
- (buff (semantic-tag-buffer tag))
- (win (selected-window))
- )
- (switch-to-buffer-other-window buff)
- (goto-char (point-min))
- (forward-line (1- line))
- (pulse-momentary-highlight-one-line (point))
- (when (eq last-command-event ?\s) (select-window win))
- )
- )
-
-(defun semantic-symref-list-next-line ()
- "Next line in `semantic-symref-results-mode'."
- (interactive)
- (forward-line 1)
- (back-to-indentation))
-
-(defun semantic-symref-list-prev-line ()
- "Next line in `semantic-symref-results-mode'."
- (interactive)
- (forward-line -1)
- (back-to-indentation))
-
-(defun semantic-symref-list-expand-all ()
- "Expand all the nodes in the current buffer."
- (interactive)
- (let ((start (make-marker)))
- (move-marker start (point))
- (goto-char (point-min))
- (while (re-search-forward "\\[[+]\\]" nil t)
- (semantic-symref-list-toggle-showing))
- ;; Restore position
- (goto-char start)))
-
-(defun semantic-symref-list-contract-all ()
- "Expand all the nodes in the current buffer."
- (interactive)
- (let ((start (make-marker)))
- (move-marker start (point))
- (goto-char (point-min))
- (while (re-search-forward "\\[[-]\\]" nil t)
- (semantic-symref-list-toggle-showing))
- ;; Restore position
- (goto-char start)))
-
-;;; UTILS
-;;
-;; List mode utils for understanding the current line
-
-(defun semantic-symref-list-on-hit-p ()
- "Return the line number if the cursor is on a buffer line with a hit.
-Hits are the line of code from the buffer, not the tag summary or
-file lines."
- (save-excursion
- (end-of-line)
- (let* ((ol (car (overlays-at (1- (point)))))) ;; trust this for now
- (when ol (overlay-get ol 'line)))))
-
-
-;;; Keyboard Macros on a Hit
-;;
-;; Record a macro on a hit, and store in a special way for execution later.
-(defun semantic-symref-list-create-macro-on-open-hit ()
- "Record a keyboard macro at the location of the hit in the current list.
-Under point should be one hit for the active keyword. Move
-cursor to the beginning of that symbol, then record a macro as if
-`kmacro-start-macro' was pressed. Use `kmacro-end-macro',
-{kmacro-end-macro} to end the macro, and return to the symbol found list."
- (interactive)
- (let* ((oldsym (oref (oref semantic-symref-current-results
- created-by)
- searchfor))
- (ol (save-excursion
- (end-of-line)
- (car (overlays-at (1- (point))))))
- (tag (when ol (overlay-get ol 'tag)))
- (line (when ol (overlay-get ol 'line))))
- (when (not line)
- (error "Cannot create macro on a non-hit line"))
- ;; Go there, and do something useful.
- (switch-to-buffer-other-window (semantic-tag-buffer tag))
- (goto-char (point-min))
- (forward-line (1- line))
- (when (not (re-search-forward (regexp-quote oldsym) (line-end-position) t))
- (error "Cannot find hit. Cannot record macro"))
- (goto-char (match-beginning 0))
- ;; Cursor is now in the right location. Start recording a macro.
- (kmacro-start-macro nil)
- ;; Notify the user
- (message "Complete with C-x ). Use E in the symref buffer to call this macro.")))
-
-(defun semantic-symref-list-call-macro-on-open-hits ()
- "Call the most recently created keyboard macro on each hit.
-Cursor is placed at the beginning of the symbol found, even if
-there is more than one symbol on the current line. The
-previously recorded macro is then executed."
- (interactive)
- (save-window-excursion
- (let ((count (semantic-symref-list-map-open-hits
- (lambda ()
- (switch-to-buffer (current-buffer))
- (kmacro-call-macro nil)))))
- (semantic-symref-list-update-open-hits)
- (message "Executed Macro %d times." count))))
-
-;;; REFACTORING EDITS
-;;
-;; Utilities and features for refactoring across a list of hits.
-;;
-(defun semantic-symref-list-rename-open-hits (newname)
- "Rename the discovered symbol references to NEWNAME.
-Only renames the locations that are open in the symref list.
-Closed items will be skipped."
- (interactive
- (list (read-string "Rename to: "
- (oref (oref semantic-symref-current-results
- created-by)
- searchfor))))
- (let ((count (semantic-symref-list-map-open-hits
- (lambda () (replace-match newname nil t)))))
- (semantic-symref-list-update-open-hits)
- (message "Renamed %d occurrences." count)))
-
-;;; REFACTORING UTILITIES
-;;
-;; Refactoring tools want to operate on only the "good" stuff the
-;; user selected.
-(defun semantic-symref-list-map-open-hits (function)
- "For every open hit in the symref buffer, perform FUNCTION.
-The `match-data' will be set to a successful hit of the searched for symbol.
-Return the number of occurrences FUNCTION was operated upon."
-
- ;; First Pass in this function - a straight rename.
- ;; Second Pass - Allow context specification based on
- ;; class members. (Not Done)
-
- (let ((oldsym (oref (oref semantic-symref-current-results
- created-by)
- searchfor))
- (count 0))
- (save-excursion
- (goto-char (point-min))
- (while (not (eobp))
- ;; Is this line a "hit" line?
- (let* ((ol (car (overlays-at (1- (point))))) ;; trust this for now
- (tag (when ol (overlay-get ol 'tag)))
- (line (when ol (overlay-get ol 'line))))
- (when line
- ;; The "line" means we have an open hit.
- (with-current-buffer (semantic-tag-buffer tag)
- (goto-char (point-min))
- (forward-line (1- line))
- (beginning-of-line)
- (while (re-search-forward (regexp-quote oldsym) (line-end-position) t)
- (setq count (1+ count))
- (save-excursion ;; Leave cursor after the matched name.
- (goto-char (match-beginning 0)) ;; Go to beginning of that sym
- (funcall function))))))
- ;; Go to the next line
- (forward-line 1)
- (end-of-line)))
- count))
-
-(defun semantic-symref-list-update-open-hits ()
- "Update the text for all the open hits in the symref list."
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward "\\[-\\]" nil t)
- (end-of-line)
- (let* ((ol (car (overlays-at (1- (point))))) ;; trust this for now
- (tag (when ol (overlay-get ol 'tag))))
- ;; If there is a tag, then close/open it.
- (when tag
- (semantic-symref-list-toggle-showing)
- (semantic-symref-list-toggle-showing))))))
-
-(provide 'semantic/symref/list)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/symref/list"
-;; End:
-
-;;; semantic/symref/list.el ends here
+++ /dev/null
-;;; semantic/tag-file.el --- Routines that find files based on tags. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2005, 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; A tag, by itself, can have representations in several files.
-;; These routines will find those files.
-
-(require 'semantic/tag)
-
-(defvar ede-minor-mode)
-(declare-function semantic-dependency-find-file-on-path "semantic/dep")
-(declare-function ede-toplevel "ede/base")
-
-;;; Code:
-
-;;; Location a TAG came from.
-;;
-
-(cl-defgeneric semantic-tag-parent-buffer (parent)
- "Return the buffer in which a tag can be found, knowing its PARENT."
- (cond ((and (semantic-tag-p parent) (semantic-tag-in-buffer-p parent))
- ;; We have a parent with a buffer, then go there.
- (semantic-tag-buffer parent))
- ((and (semantic-tag-p parent) (semantic-tag-file-name parent))
- ;; The parent only has a file-name, then
- ;; find that file, and switch to that buffer.
- (find-file-noselect (semantic-tag-file-name parent)))))
-
-;;;###autoload
-(defun semantic-go-to-tag (tag &optional parent)
- "Go to the location of TAG.
-TAG may be a stripped element, in which case PARENT specifies a
-parent tag that has position information.
-PARENT can also be a `semanticdb-table' object."
- (save-match-data
- (set-buffer
- (cond ((semantic-tag-in-buffer-p tag)
- ;; We have a linked tag, go to that buffer.
- (semantic-tag-buffer tag))
- ((semantic-tag-file-name tag)
- ;; If it didn't have a buffer, but does have a file
- ;; name, then we need to get to that file so the tag
- ;; location is made accurate.
- (find-file-noselect (semantic-tag-file-name tag)))
- ((and parent (semantic-tag-parent-buffer parent)))
- ;; Well, just assume things are in the current buffer.
- (t (current-buffer)))))
- ;; We should be in the correct buffer now, try and figure out
- ;; where the tag is.
- (cond ((semantic-tag-with-position-p tag)
- ;; If it's a number, go there
- (goto-char (semantic-tag-start tag)))
- ((semantic-tag-with-position-p parent)
- ;; Otherwise, it's a trimmed vector, such as a parameter,
- ;; or a structure part. If there is a parent, we can use it
- ;; as a bounds for searching.
- (goto-char (semantic-tag-start parent))
- ;; Here we make an assumption that the text returned by
- ;; the parser and concocted by us actually exists
- ;; in the buffer.
- (re-search-forward (semantic-tag-name tag)
- (semantic-tag-end parent)
- t))
- ((semantic-tag-get-attribute tag :line)
- ;; The tag has a line number in it. Go there.
- (goto-char (point-min))
- (forward-line (1- (semantic-tag-get-attribute tag :line))))
- ((and (semantic-tag-p parent) (semantic-tag-get-attribute parent :line))
- ;; The tag has a line number in it. Go there.
- (goto-char (point-min))
- (forward-line (1- (semantic-tag-get-attribute parent :line)))
- (re-search-forward (semantic-tag-name tag) nil t))
- (t
- ;; Take a guess that the tag has a unique name, and just
- ;; search for it from the beginning of the buffer.
- (goto-char (point-min))
- (re-search-forward (semantic-tag-name tag) nil t)))
- )
-
-;;; Dependencies
-;;
-;; A tag which is of type 'include specifies a dependency.
-;; Dependencies usually represent a file of some sort.
-;; Find the file described by a dependency.
-
-;;;###autoload
-(define-overloadable-function semantic-dependency-tag-file (&optional tag)
- "Find the filename represented from TAG.
-Depends on `semantic-dependency-include-path' for searching. Always searches
-`.' first, then searches additional paths."
- (or tag (setq tag (car (semantic-find-tag-by-overlay nil))))
- (unless (semantic-tag-of-class-p tag 'include)
- (signal 'wrong-type-argument (list tag 'include)))
- (save-excursion
- (let ((result nil)
- (default-directory default-directory)
- (edefind nil)
- (tag-fname nil))
- (cond ((semantic-tag-in-buffer-p tag)
- ;; If the tag has an overlay and buffer associated with it,
- ;; switch to that buffer so that we get the right override methods.
- (set-buffer (semantic-tag-buffer tag)))
- ((semantic-tag-file-name tag)
- ;; If it didn't have a buffer, but does have a file
- ;; name, then we need to get to that file so the tag
- ;; location is made accurate.
- ;;(set-buffer (find-file-noselect (semantic-tag-file-name tag)))
- ;;
- ;; 2/3/08
- ;; The above causes unnecessary buffer loads all over the place. Ick!
- ;; All we really need is for 'default-directory' to be set correctly.
- (setq default-directory (file-name-directory (semantic-tag-file-name tag)))
- ))
- ;; Setup the filename represented by this include
- (setq tag-fname (semantic-tag-include-filename tag))
-
- ;; First, see if this file exists in the current EDE project
- (if (and (fboundp 'ede-expand-filename) ede-minor-mode
- (setq edefind
- (condition-case nil
- (let ((proj (ede-toplevel)))
- (when proj
- (ede-expand-filename proj tag-fname)))
- (error nil))))
- (setq result edefind))
- (if (not result)
- (setq result
- ;; I don't have a plan for refreshing tags with a dependency
- ;; stuck on them somehow. I'm thinking that putting a cache
- ;; onto the dependency finding with a hash table might be best.
- ;;(if (semantic--tag-get-property tag 'dependency-file)
- ;; (semantic--tag-get-property tag 'dependency-file)
- (:override
- (save-excursion
- (require 'semantic/dep)
- (semantic-dependency-find-file-on-path
- tag-fname (semantic-tag-include-system-p tag))))
- ;; )
- ))
- (if (stringp result)
- (progn
- (semantic--tag-put-property tag 'dependency-file result)
- result)
- ;; @todo: Do something to make this get flushed w/
- ;; when the path is changed.
- ;; @undo: Just eliminate
- ;; (semantic--tag-put-property tag 'dependency-file 'none)
- nil)
- )))
-
-;;; PROTOTYPE FILE
-;;
-;; In C, a function in the .c file often has a representation in a
-;; corresponding .h file. This routine attempts to find the
-;; prototype file a given source file would be associated with.
-;; This can be used by prototype manager programs.
-(define-overloadable-function semantic-prototype-file (buffer)
- "Return a file in which prototypes belonging to BUFFER should be placed.
-Default behavior (if not overridden) looks for a token specifying the
-prototype file, or the existence of an EDE variable indicating which
-file prototypes belong in."
- (:override
- ;; Perform some default behaviors
- (if (and (fboundp 'ede-header-file) ede-minor-mode)
- (with-current-buffer buffer
- (ede-header-file))
- ;; No EDE options for a quick answer. Search.
- (with-current-buffer buffer
- (if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t)
- (match-string 1))))))
-
-(provide 'semantic/tag-file)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/tag-file"
-;; End:
-
-;;; semantic/tag-file.el ends here
+++ /dev/null
-;;; semantic/tag-ls.el --- Language Specific override functions for tags -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2004, 2006-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; There are some features of tags that are too language dependent to
-;; put in the core `semantic-tag' functionality. For instance, the
-;; protection of a tag (as specified by UML) could be almost anything.
-;; In Java, it is a type specifier. In C, there is a label. This
-;; information can be derived, and thus should not be stored in the tag
-;; itself. These are the functions that languages can use to derive
-;; the information.
-
-(require 'semantic)
-(require 'semantic/find)
-
-;;; Code:
-
-;;; TAG SIMILARITY:
-;;
-;; Two tags that represent the same thing are "similar", but not the "same".
-;; Similar tags might have the same name, but one is a :prototype, while
-;; the other is an implementation.
-;;
-;; Each language will have different things that can be ignored
-;; between two "similar" tags, so similarity checks involve a series
-;; of mode overridable features. Some are "internal" features.
-(defvar semantic-tag-similar-ignorable-attributes '(:prototype-flag)
- "The tag attributes that can be ignored during a similarity test.")
-
-(define-overloadable-function semantic--tag-similar-names-p (tag1 tag2 blankok)
- "Compare the names of TAG1 and TAG2.
-If BLANKOK is false, then the names must exactly match.
-If BLANKOK is true, then if either of TAG1 or TAG2 has blank
-names, then that is ok, and this returns true, but if they both
-have values, they must still match.")
-
-(defun semantic--tag-similar-names-p-default (tag1 tag2 blankok)
- "Compare the names of TAG1 and TAG2.
-If BLANKOK is false, then the names must exactly match.
-If BLANKOK is true, then if either of TAG1 or TAG2 has blank
-names, then that is ok, and this returns true, but if they both
-have values, they must still match."
- (let ((n1 (semantic-tag-name tag1))
- (n2 (semantic-tag-name tag2)))
- (or (and blankok (or (null n1) (null n2) (string= n1 "") (string= n2 "")))
- (string= n1 n2))))
-
-(define-overloadable-function semantic--tag-similar-types-p (tag1 tag2)
- "Compare the types of TAG1 and TAG2.
-This function can be overridden, for example to compare a fully
-qualified with an unqualified type."
- (cond
- ((and (null (semantic-tag-type tag1))
- (null (semantic-tag-type tag2)))
- t)
- ((or (null (semantic-tag-type tag1))
- (null (semantic-tag-type tag2)))
- nil)
- (t
- (:override))))
-
-(defun semantic--tag-similar-types-p-default (tag1 tag2)
- "Compare the types of TAG1 and TAG2.
-This function can be overridden, for example to compare a fully
-qualified with an unqualified type."
- (semantic-tag-of-type-p tag1 (semantic-tag-type tag2)))
-
-(define-overloadable-function semantic--tag-attribute-similar-p (attr value1 value2 ignorable-attributes)
- "Test to see if attribute ATTR is similar for VALUE1 and VALUE2.
-IGNORABLE-ATTRIBUTES is described in `semantic-tag-similar-p'.
-This function is internal, but allows customization of `semantic-tag-similar-p'
-for a given mode at a more granular level.
-
-Note that :type, :name, and anything in IGNORABLE-ATTRIBUTES will
-not be passed to this function.
-
-Modes that override this function can call
-`semantic--tag-attribute-similar-p-default' to do the default equality tests if
-ATTR is not special for that mode.")
-
-(defun semantic--tag-attribute-similar-p-default (_attr value1 value2 ignorable-attributes)
- "For ATTR, VALUE1, VALUE2 and IGNORABLE-ATTRIBUTES, test for similarity."
- (cond
- ;; Tag sublists require special testing.
- ((and (listp value1) (semantic-tag-p (car value1))
- (listp value2) (semantic-tag-p (car value2)))
- (let ((ans t)
- (taglist1 value1)
- (taglist2 value2))
- (when (not (eq (length taglist1) (length taglist2)))
- (setq ans nil))
- (while (and ans taglist1 taglist2)
- (setq ans (apply #'semantic-tag-similar-p
- (car taglist1) (car taglist2)
- ignorable-attributes)
- taglist1 (cdr taglist1)
- taglist2 (cdr taglist2)))
- ans))
-
- ;; The attributes are not the same?
- ((not (equal value1 value2))
- nil)
-
- (t t))
- )
-
-(define-overloadable-function semantic-tag-similar-p (tag1 tag2 &rest ignorable-attributes)
- "Test to see if TAG1 and TAG2 are similar.
-Two tags are similar if their name, datatype, and various attributes
-are the same.
-
-Similar tags that have sub-tags such as arg lists or type members,
-are similar w/out checking the sub-list of tags.
-
-Optional argument IGNORABLE-ATTRIBUTES are attributes to ignore while comparing
-similarity.
-
-By default, `semantic-tag-similar-ignorable-attributes' is referenced for
-attributes, and IGNORABLE-ATTRIBUTES will augment this list.
-
-Note that even though :name is not an attribute, it can be used to
-indicate lax comparison of names via `semantic--tag-similar-names-p'")
-
-;; Note: optional thing is because overloadable fcns don't handle this
-;; quite right.
-(defun semantic-tag-similar-p-default (tag1 tag2 &optional ignorable-attributes)
- "Test to see if TAG1 and TAG2 are similar.
-Two tags are similar if their name, datatype, and various attributes
-are the same.
-
-IGNORABLE-ATTRIBUTES are tag attributes that can be ignored.
-
-See `semantic-tag-similar-p' for details."
- (or
- ;; Tags are similar if they have the exact same lisp object
- ;; Added for performance when testing a relatively common case in some uses
- ;; of this code.
- (eq tag1 tag2)
- ;; More complex similarity test.
- (let* ((ignore (append ignorable-attributes semantic-tag-similar-ignorable-attributes))
- (A1 (and (semantic--tag-similar-names-p tag1 tag2 (memq :name ignore))
- (semantic--tag-similar-types-p tag1 tag2)
- (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))))
- (attr1 (semantic-tag-attributes tag1))
- (attr2 (semantic-tag-attributes tag2))
- (A2 t)
- (A3 t)
- )
- ;; Test if there are non-ignorable attributes in A2 which are not present in A1
- (while (and A2 attr2)
- (let ((a (car attr2)))
- (unless (or (eq a :type) (memq a ignore))
- (setq A2 (semantic-tag-get-attribute tag1 a)))
- (setq attr2 (cdr (cdr attr2)))))
- (while (and A2 attr1 A3)
- (let ((a (car attr1)))
-
- (cond ((or (eq a :type) ;; already tested above.
- (memq a ignore)) ;; Ignore them...
- nil)
-
- (t
- (setq A3
- (semantic--tag-attribute-similar-p
- a (car (cdr attr1)) (semantic-tag-get-attribute tag2 a)
- ignorable-attributes)))
- ))
- (setq attr1 (cdr (cdr attr1))))
- (and A1 A2 A3))))
-
-;;; FULL NAMES
-;;
-;; For programmer convenience, a full name is not specified in source
-;; code. Instead some abbreviation is made, and the local environment
-;; will contain the info needed to determine the full name.
-(define-overloadable-function semantic-tag-full-package (tag &optional stream-or-buffer)
- "Return the fully qualified package name of TAG in a package hierarchy.
-STREAM-OR-BUFFER can be anything convertible by
-`semantic-something-to-tag-table', but must be a toplevel
-semantic tag stream that contains TAG.
-
-A Package Hierarchy is defined in UML by the way classes and methods
-are organized on disk. Some languages use this concept such that a
-class can be accessed via it's fully qualified name, (such as Java.)
-
-Other languages qualify names within a Namespace (such as C++) which
-result in a different package like structure.
-
-Languages which do not override this function will just search the
-stream for a tag of class `package', and return that."
- (let ((stream (semantic-something-to-tag-table
- (or stream-or-buffer tag))))
- (:override-with-args (tag stream))))
-
-(defun semantic-tag-full-package-default (_tag stream)
- "Default method for `semantic-tag-full-package' for TAG.
-Return the name of the first tag of class `package' in STREAM."
- (let ((pack (car-safe (semantic-find-tags-by-class 'package stream))))
- (when (and pack (semantic-tag-p pack))
- (semantic-tag-name pack))))
-
-(define-overloadable-function semantic-tag-full-name (tag &optional stream-or-buffer)
- "Return the fully qualified name of TAG in the package hierarchy.
-STREAM-OR-BUFFER can be anything convertible by
-`semantic-something-to-tag-table', but must be a toplevel
-semantic tag stream that contains TAG.
-
-A Package Hierarchy is defined in UML by the way classes and methods
-are organized on disk. Some languages use this concept such that a
-class can be accessed via it's fully qualified name, (such as Java.)
-
-Other languages qualify names within a Namespace (such as C++) which
-result in a different package like structure.
-
-Languages which do not override this function with
-`tag-full-name' will combine `semantic-tag-full-package' and
-`semantic-tag-name', separated with language separator character.
-Override functions only need to handle STREAM-OR-BUFFER with a
-tag stream value, or nil.
-
-TODO - this function should probably also take a PARENT to TAG to
-resolve issues where a method in a class in a package is present."
- (let ((stream (semantic-something-to-tag-table
- (or stream-or-buffer tag))))
- (:override-with-args (tag stream))))
-
-(defun semantic-tag-full-name-default (tag stream)
- "Default method for `semantic-tag-full-name'.
-Return the name of TAG found in the toplevel STREAM."
- (let ((pack (semantic-tag-full-package tag stream))
- (name (semantic-tag-name tag)))
- (if pack
- (concat pack
- (car semantic-type-relation-separator-character)
- name)
- name)))
-
-;;; UML features:
-;;
-;; UML can represent several types of features of a tag
-;; such as the `protection' of a symbol, or if it is abstract,
-;; leaf, etc. Learn about UML to catch onto the lingo.
-
-(define-overloadable-function semantic-tag-calculate-parent (tag)
- "Attempt to calculate the parent of TAG.
-The default behavior (if not overridden with `tag-calculate-parent')
-is to search a buffer found with TAG, and if externally defined,
-search locally, then semanticdb for that tag (when enabled.)")
-
-(defun semantic-tag-calculate-parent-default (tag)
- "Attempt to calculate the parent of TAG."
- (when (semantic-tag-in-buffer-p tag)
- (with-current-buffer (semantic-tag-buffer tag)
- (save-excursion
- (goto-char (semantic-tag-start tag))
- (semantic-current-tag-parent))
- )))
-
-(define-overloadable-function semantic-tag-protection (tag &optional parent)
- "Return protection information about TAG with optional PARENT.
-This function returns on of the following symbols:
- nil - No special protection. Language dependent.
- `public' - Anyone can access this TAG.
- `private' - Only methods in the local scope can access TAG.
- `protected' - Like private for outside scopes, like public for child
- classes.
-Some languages may choose to provide additional return symbols specific
-to themselves. Use of this function should allow for this.
-
-The default behavior (if not overridden with `tag-protection'
-is to return a symbol based on type modifiers."
- (and (not parent)
- (semantic-tag-overlay tag)
- (semantic-tag-in-buffer-p tag)
- (setq parent (semantic-tag-calculate-parent tag)))
- (:override))
-
-(defun semantic-tag-protection-default (tag &optional _parent)
- "Return the protection of TAG as a child of PARENT default action.
-See `semantic-tag-protection'."
- (let ((mods (semantic-tag-modifiers tag))
- (prot nil))
- (while (and (not prot) mods)
- (if (stringp (car mods))
- (let ((s (car mods)))
- (setq prot
- ;; A few silly defaults to get things started.
- (cond ((member s '("public" "extern" "export"))
- 'public)
- ((string= s "private")
- 'private)
- ((string= s "protected")
- 'protected)
- ((string= s "package")
- 'package)
- ))))
- (setq mods (cdr mods)))
- prot))
-
-(defun semantic-tag-package-protected-p (tag &optional parent currentpackage)
- "Non-nil if TAG is not available via package access control.
-For languages (such as Java) where a method is package protected,
-this method will return nil if TAG, as found in PARENT is available
-for access from a file in CURRENTPACKAGE.
-If TAG is not protected by PACKAGE, also return t. Use
-`semantic-tag-protected-p' instead.
-If PARENT is not provided, it will be derived when passed to
-`semantic-tag-protection'.
-If CURRENTPACKAGE is not provided, it will be derived from the current
-buffer."
- (let ((tagpro (semantic-tag-protection tag parent)))
- (if (not (eq tagpro 'package))
- t ;; protected
-
- ;; package protection, so check currentpackage.
- ;; Deriving the package is better from the parent, as TAG is
- ;; probably a field or method.
- (if (not currentpackage)
- (setq currentpackage (semantic-tag-full-package nil (current-buffer))))
- (let ((tagpack (semantic-tag-full-package (or parent tag))))
- (if (string= currentpackage tagpack)
- nil
- t)) )))
-
-(defun semantic-tag-protected-p (tag protection &optional parent)
- "Non-nil if TAG is protected.
-PROTECTION is a symbol which can be returned by the method
-`semantic-tag-protection'.
-PARENT is the parent data type which contains TAG.
-
-For these PROTECTIONs, true is returned if TAG is:
-@table @asis
-@item nil
- Always true.
-@item private
- True if nil.
-@item protected
- True if private or nil.
-@item public
- True if private, protected, or nil.
-@end table"
- (if (null protection)
- t
- (let ((tagpro (semantic-tag-protection tag parent)))
- (or (and (eq protection 'private)
- (null tagpro))
- (and (eq protection 'protected)
- (or (null tagpro)
- (eq tagpro 'private)))
- (and (eq protection 'public)
- (not (eq tagpro 'public)))))
- ))
-
-(define-overloadable-function semantic-tag-abstract-p (tag &optional parent)
- "Return non-nil if TAG is abstract.
-Optional PARENT is the parent tag of TAG.
-In UML, abstract methods and classes have special meaning and behavior
-in how methods are overridden. In UML, abstract methods are italicized.
-
-The default behavior (if not overridden with `tag-abstract-p'
-is to return true if `abstract' is in the type modifiers.")
-
-(defun semantic-tag-abstract-p-default (tag &optional _parent)
- "Return non-nil if TAG is abstract as a child of PARENT default action.
-See `semantic-tag-abstract-p'."
- (let ((mods (semantic-tag-modifiers tag))
- (abs nil))
- (while (and (not abs) mods)
- (if (stringp (car mods))
- (setq abs (member (car mods) '("abstract" "virtual"))))
- (setq mods (cdr mods)))
- abs))
-
-(define-overloadable-function semantic-tag-leaf-p (tag &optional parent)
- "Return non-nil if TAG is leaf.
-Optional PARENT is the parent tag of TAG.
-In UML, leaf methods and classes have special meaning and behavior.
-
-The default behavior (if not overridden with `tag-leaf-p'
-is to return true if `leaf' is in the type modifiers.")
-
-(defun semantic-tag-leaf-p-default (tag &optional _parent)
- "Return non-nil if TAG is leaf as a child of PARENT default action.
-See `semantic-tag-leaf-p'."
- (let ((mods (semantic-tag-modifiers tag))
- (leaf nil))
- (while (and (not leaf) mods)
- (if (stringp (car mods))
- ;; Use java FINAL as example default. There is none
- ;; for C/C++
- (setq leaf (string= (car mods) "final")))
- (setq mods (cdr mods)))
- leaf))
-
-(define-overloadable-function semantic-tag-static-p (tag &optional parent)
- "Return non-nil if TAG is static.
-Optional PARENT is the parent tag of TAG.
-In UML, static methods and attributes mean that they are allocated
-in the parent class, and are not instance specific.
-UML notation specifies that STATIC entries are underlined.")
-
-(defun semantic-tag-static-p-default (tag &optional _parent)
- "Return non-nil if TAG is static as a child of PARENT default action.
-See `semantic-tag-static-p'."
- (let ((mods (semantic-tag-modifiers tag))
- (static nil))
- (while (and (not static) mods)
- (if (stringp (car mods))
- (setq static (string= (car mods) "static")))
- (setq mods (cdr mods)))
- static))
-
-;;;###autoload
-(define-overloadable-function semantic-tag-prototype-p (tag)
- "Return non-nil if TAG is a prototype.
-For some languages, such as C, a prototype is a declaration of
-something without an implementation."
- )
-
-(defun semantic-tag-prototype-p-default (tag)
- "Non-nil if TAG is a prototype."
- (let ((p (semantic-tag-get-attribute tag :prototype-flag)))
- (cond
- ;; Trust the parser author.
- (p p)
- ;; Empty types might be a prototype.
- ;; @todo - make this better.
- ((eq (semantic-tag-class tag) 'type)
- (not (semantic-tag-type-members tag)))
- ;; No other heuristics.
- (t nil))
- ))
-
-(provide 'semantic/tag-ls)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/tag-ls"
-;; End:
-
-;;; semantic/tag-ls.el ends here
+++ /dev/null
-;;; semantic/tag-write.el --- Write tags to a text stream -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Routine for writing out a list of tags to a text stream.
-;;
-;; These routines will be used by semanticdb to output a tag list into
-;; a text stream to be saved to a file. Ideally, you could use tag streams
-;; to share tags between processes as well.
-;;
-;; As a bonus, these routines will also validate the tag structure, and make sure
-;; that they conform to good semantic tag hygiene.
-;;
-
-(require 'semantic)
-
-;;; Code:
-(defun semantic-tag-write-one-tag (tag &optional indent)
- "Write a single tag TAG to standard out.
-INDENT is the amount of indentation to use for this tag."
- (when (not (semantic-tag-p tag))
- (signal 'wrong-type-argument (list tag 'semantic-tag-p)))
- (when (not indent) (setq indent 0))
- ;(princ (make-string indent ? ))
- (princ "(")
- ;; Base parts
- (let ((name (semantic-tag-name tag))
- (class (semantic-tag-class tag)))
- (prin1 name)
- (princ " ")
- (princ (symbol-name class))
- )
- (let ((attr (semantic-tag-attributes tag))
- )
- ;; Attributes
- (cond ((not attr)
- (princ " nil"))
-
- ((= (length attr) 2) ;; One item
- (princ " (")
- (semantic-tag-write-one-attribute attr indent)
- (princ ")")
- )
- (t
- ;; More than one tag.
- (princ "\n")
- (princ (make-string (+ indent 3) ? ))
- (princ "(")
- (while attr
- (semantic-tag-write-one-attribute attr (+ indent 4))
- (setq attr (cdr (cdr attr)))
- (when attr
- (princ "\n")
- (princ (make-string (+ indent 4) ? )))
- )
- (princ ")\n")
- (princ (make-string (+ indent 3) ? ))
- ))
- ;; Properties - for now, always nil.
- (let ((rs (semantic--tag-get-property tag 'reparse-symbol)))
- (if (not rs)
- (princ " nil")
- ;; Else, put in the property list.
- (princ " (reparse-symbol ")
- (princ (symbol-name rs))
- (princ ")"))
- ))
- ;; Overlay
- (if (semantic-tag-with-position-p tag)
- (let ((bounds (semantic-tag-bounds tag)))
- (princ " ")
- (prin1 (apply #'vector bounds))
- )
- (princ " nil"))
- ;; End it.
- (princ ")")
- )
-
-(defun semantic-tag-write-tag-list (tlist &optional indent dontaddnewline)
- "Write the tag list TLIST to the current stream.
-INDENT indicates the current indentation level.
-If optional DONTADDNEWLINE is non-nil, then don't add a newline."
- (if (not indent)
- (setq indent 0)
- (unless dontaddnewline
- ;; Assume cursor at end of current line. Add a CR, and make the list.
- (princ "\n")
- (princ (make-string indent ? ))))
- (princ "( ")
- (while tlist
- (if (semantic-tag-p (car tlist))
- (semantic-tag-write-one-tag (car tlist) (+ indent 2))
- ;; If we don't have a tag in the tag list, use the below hack, and hope
- ;; it doesn't contain anything bad. If we find something bad, go back here
- ;; and start extending what's expected here.
- (princ (format "%S" (car tlist))))
- (setq tlist (cdr tlist))
- (when tlist
- (princ "\n")
- (princ (make-string (+ indent 2) ? )))
- )
- (princ ")")
- (princ (make-string indent ? ))
- )
-
-
-;; Writing out random stuff.
-(defun semantic-tag-write-one-attribute (attrs indent)
- "Write out one attribute from the head of the list of attributes ATTRS.
-INDENT is the current amount of indentation."
- (when (not attrs) (signal 'wrong-type-argument (list 'listp attrs)))
- (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag"))
-
- (princ (symbol-name (car attrs)))
- (princ " ")
- (semantic-tag-write-one-value (car (cdr attrs)) indent)
- )
-
-(defun semantic-tag-write-one-value (value indent)
- "Write out a VALUE for something in a tag.
-INDENT is the current tag indentation.
-Items that are long lists of tags may need their own line."
- (cond
- ;; Another tag.
- ((semantic-tag-p value)
- (semantic-tag-write-one-tag value (+ indent 2)))
- ;; A list of more tags
- ((and (listp value) (semantic-tag-p (car value)))
- (semantic-tag-write-tag-list value (+ indent 2))
- )
- ;; Some arbitrary data.
- (t
- (let ((str (format "%S" value)))
- ;; Protect against odd data types in tags.
- (if (= (aref str 0) ?#)
- (progn
- (princ "nil")
- (message "Warning: Value %s not writable in tag." str))
- (princ str)))))
- )
-;;; EIEIO USAGE
-;;;###autoload
-(defun semantic-tag-write-list-slot-value (value)
- "Write out the VALUE of a slot for EIEIO.
-The VALUE is a list of tags."
- (if (not value)
- (princ "nil")
- (princ "\n '")
- (semantic-tag-write-tag-list value 10 t)
- ))
-
-(provide 'semantic/tag-write)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/tag-write"
-;; End:
-
-;;; semantic/tag-write.el ends here
+++ /dev/null
-;;; semantic/tag.el --- Tag creation and access -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2005, 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; I. The core production of semantic is the list of tags produced by the
-;; different parsers. This file provides 3 APIs related to tag access:
-;;
-;; 1) Primitive Tag Access
-;; There is a set of common features to all tags. These access
-;; functions can get these values.
-;; 2) Standard Tag Access
-;; A Standard Tag should be produced by most traditional languages
-;; with standard styles common to typed object oriented languages.
-;; These functions can access these data elements from a tag.
-;; 3) Generic Tag Access
-;; Access to tag structure in a more direct way.
-;; ** May not be forward compatible.
-;;
-;; II. There is also an API for tag creation. Use `semantic-tag' to create
-;; a new tag.
-;;
-;; III. Tag Comparison. Allows explicit or comparative tests to see
-;; if two tags are the same.
-
-;;; Code:
-;;
-
-;; Keep this only so long as we have obsolete fcns.
-(require 'semantic/fw)
-(require 'semantic/lex)
-
-(declare-function semantic-analyze-split-name "semantic/analyze/fcn")
-(declare-function semantic-fetch-tags "semantic")
-(declare-function semantic-clear-toplevel-cache "semantic")
-(declare-function semantic-tag-similar-p "semantic/tag-ls")
-
-(define-obsolete-variable-alias 'semantic-token-version
- 'semantic-tag-version "28.1")
-(define-obsolete-variable-alias 'semantic-token-incompatible-version
- 'semantic-tag-incompatible-version "28.1")
-
-(defconst semantic-tag-version "2.0"
- "Version string of semantic tags made with this code.")
-
-(defconst semantic-tag-incompatible-version "1.0"
- "Version string of semantic tags which are not currently compatible.
-These old style tags may be loaded from a file with semantic db.
-In this case, we must flush the old tags and start over.")
-\f
-;;; Primitive Tag access system:
-;;
-;; Raw tags in semantic are lists of 5 elements:
-;;
-;; (NAME CLASS ATTRIBUTES PROPERTIES OVERLAY)
-;;
-;; Where:
-;;
-;; - NAME is a string that represents the tag name.
-;;
-;; - CLASS is a symbol that represent the class of the tag (for
-;; example, usual classes are `type', `function', `variable',
-;; `include', `package', `code').
-;;
-;; - ATTRIBUTES is a public list of attributes that describes
-;; language data represented by the tag (for example, a variable
-;; can have a `:constant-flag' attribute, a function an `:arguments'
-;; attribute, etc.).
-;;
-;; - PROPERTIES is a private list of properties used internally.
-;;
-;; - OVERLAY represent the location of data described by the tag.
-;;
-
-(defsubst semantic-tag-name (tag)
- "Return the name of TAG.
-For functions, variables, classes, typedefs, etc., this is the identifier
-that is being defined. For tags without an obvious associated name, this
-may be the statement type, e.g., this may return @code{print} for python's
-print statement."
- (car tag))
-
-(defsubst semantic-tag-class (tag)
- "Return the class of TAG.
-This is a symbol like `variable', `function', or `type'.
-There is no limit to the symbols that may represent the class of a tag.
-Each parser generates tags with classes defined by it.
-
-For functional languages, typical tag classes are:
-
-@table @code
-@item type
-Data types, named map for a memory block.
-@item function
-A function or method, or named execution location.
-@item variable
-A variable, or named storage for data.
-@item include
-Statement that represents a file from which more tags can be found.
-@item package
-Statement that declares this file's package name.
-@item code
-Code that has not name or binding to any other symbol, such as in a script.
-@end table"
- (nth 1 tag))
-
-(defsubst semantic-tag-attributes (tag)
- "Return the list of public attributes of TAG.
-That is a property list: (ATTRIBUTE-1 VALUE-1 ATTRIBUTE-2 VALUE-2...)."
- (nth 2 tag))
-
-(defsubst semantic-tag-properties (tag)
- "Return the list of private properties of TAG.
-That is a property list: (PROPERTY-1 VALUE-1 PROPERTY-2 VALUE-2...)."
- (nth 3 tag))
-
-(defsubst semantic-tag-overlay (tag)
- "Return the OVERLAY part of TAG.
-That is, an overlay or an unloaded buffer representation.
-This function can also return an array of the form [ START END ].
-This occurs for tags that are not currently linked into a buffer."
- (nth 4 tag))
-
-(defsubst semantic--tag-overlay-cdr (tag)
- "Return the cons cell whose car is the OVERLAY part of TAG.
-That function is for internal use only."
- (nthcdr 4 tag))
-
-(defsubst semantic--tag-set-overlay (tag overlay)
- "Set the overlay part of TAG with OVERLAY.
-That function is for internal use only."
- (setcar (semantic--tag-overlay-cdr tag) overlay))
-
-(defsubst semantic-tag-start (tag)
- "Return the start location of TAG."
- (let ((o (semantic-tag-overlay tag)))
- (if (overlayp o)
- (overlay-start o)
- (aref o 0))))
-
-(defsubst semantic-tag-end (tag)
- "Return the end location of TAG."
- (let ((o (semantic-tag-overlay tag)))
- (if (overlayp o)
- (overlay-end o)
- (aref o 1))))
-
-(defsubst semantic-tag-bounds (tag)
- "Return the location (START END) of data TAG describes."
- (list (semantic-tag-start tag)
- (semantic-tag-end tag)))
-
-(defun semantic-tag-set-bounds (tag start end)
- "In TAG, set the START and END location of data it describes."
- (let ((o (semantic-tag-overlay tag)))
- (if (overlayp o)
- (move-overlay o start end)
- (semantic--tag-set-overlay tag (vector start end)))))
-
-(defun semantic-tag-in-buffer-p (tag)
- "Return the buffer TAG resides in, if tag is already in a buffer.
-If a tag is not in a buffer, return nil."
- (let ((o (semantic-tag-overlay tag)))
- ;; TAG is currently linked to a buffer, return it.
- (when (and (overlayp o)
- (overlay-buffer o))
- (overlay-buffer o))))
-
-(defsubst semantic--tag-get-property (tag property)
- "From TAG, extract the value of PROPERTY.
-Return the value found, or nil if PROPERTY is not one of the
-properties of TAG.
-That function is for internal use only."
- (plist-get (semantic-tag-properties tag) property))
-
-(defun semantic-tag-buffer (tag)
- "Return the buffer TAG resides in.
-If TAG has an originating file, read that file into a (maybe new)
-buffer, and return it.
-Return nil if there is no buffer for this tag."
- (let ((buff (semantic-tag-in-buffer-p tag)))
- (if buff
- buff
- ;; TAG has an originating file, read that file into a buffer, and
- ;; return it.
- (if (semantic--tag-get-property tag :filename)
- (save-match-data
- (find-file-noselect (semantic--tag-get-property tag :filename)))
- ;; TAG is not in Emacs right now, no buffer is available.
- ))))
-
-(defun semantic-tag-mode (&optional tag)
- "Return the major mode active for TAG.
-TAG defaults to the tag at point in current buffer.
-If TAG has a :mode property return it.
-If point is inside TAG bounds, return the major mode active at point.
-Return the major mode active at beginning of TAG otherwise.
-See also the function `semantic-ctxt-current-mode'."
- (or tag (setq tag (semantic-current-tag)))
- (or (semantic--tag-get-property tag :mode)
- (let ((buffer (semantic-tag-buffer tag))
- (start (semantic-tag-start tag))
- (end (semantic-tag-end tag)))
- (save-excursion
- (and buffer (set-buffer buffer))
- ;; Unless point is inside TAG bounds, move it to the
- ;; beginning of TAG.
- (or (and (>= (point) start) (< (point) end))
- (goto-char start))
- (require 'semantic/ctxt)
- (semantic-ctxt-current-mode)))))
-
-;; Is this function still necessary?
-(defun semantic-tag-make-plist (args)
- "Create a property list with ARGS.
-Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN).
-Where KEY is a symbol, and VALUE is the value for that symbol.
-The return value will be a new property list, with these KEY/VALUE
-pairs eliminated:
-
- - KEY associated to nil VALUE.
- - KEY associated to an empty string VALUE.
- - KEY associated to a zero VALUE."
- (let (plist key val)
- (while args
- (setq key (car args)
- val (nth 1 args)
- args (nthcdr 2 args))
- (or (member val '("" nil))
- (and (numberp val) (zerop val))
- (setq plist (cons key (cons val plist)))))
- ;; It is not useful to reverse the new plist.
- plist))
-
-(defsubst semantic--tag-attributes-cdr (tag)
- "Return the cons cell whose car is the ATTRIBUTES part of TAG.
-That function is for internal use only."
- (nthcdr 2 tag))
-
-(defsubst semantic-tag-put-attribute (tag attribute value)
- "Change value in TAG of ATTRIBUTE to VALUE.
-If ATTRIBUTE already exists, its value is set to VALUE, otherwise the
-new ATTRIBUTE VALUE pair is added.
-Return TAG.
-Use this function in a parser when not all attributes are known at the
-same time."
- (let* ((plist-cdr (semantic--tag-attributes-cdr tag)))
- (when (consp plist-cdr)
- (setcar plist-cdr
- (semantic-tag-make-plist
- (plist-put (car plist-cdr) attribute value))))
- tag))
-
-(defun semantic-tag-put-attribute-no-side-effect (tag attribute value)
- "Change value in TAG of ATTRIBUTE to VALUE without side effects.
-All cons cells in the attribute list are replicated so that there
-are no side effects if TAG is in shared lists.
-If ATTRIBUTE already exists, its value is set to VALUE, otherwise the
-new ATTRIBUTE VALUE pair is added.
-Return TAG."
- (let* ((plist-cdr (semantic--tag-attributes-cdr tag)))
- (when (consp plist-cdr)
- (setcar plist-cdr
- (semantic-tag-make-plist
- (plist-put (copy-sequence (car plist-cdr))
- attribute value))))
- tag))
-
-(defsubst semantic-tag-get-attribute (tag attribute)
- "From TAG, return the value of ATTRIBUTE.
-ATTRIBUTE is a symbol whose specification value to get.
-Return the value found, or nil if ATTRIBUTE is not one of the
-attributes of TAG."
- (plist-get (semantic-tag-attributes tag) attribute))
-
-;; These functions are for internal use only!
-(defsubst semantic--tag-properties-cdr (tag)
- "Return the cons cell whose car is the PROPERTIES part of TAG.
-That function is for internal use only."
- (nthcdr 3 tag))
-
-(defun semantic--tag-put-property (tag property value)
- "Change value in TAG of PROPERTY to VALUE.
-If PROPERTY already exists, its value is set to VALUE, otherwise the
-new PROPERTY VALUE pair is added.
-Return TAG.
-That function is for internal use only."
- (let* ((plist-cdr (semantic--tag-properties-cdr tag)))
- (when (consp plist-cdr)
- (setcar plist-cdr
- (semantic-tag-make-plist
- (plist-put (car plist-cdr) property value))))
- tag))
-
-(defun semantic--tag-put-property-no-side-effect (tag property value)
- "Change value in TAG of PROPERTY to VALUE without side effects.
-All cons cells in the property list are replicated so that there
-are no side effects if TAG is in shared lists.
-If PROPERTY already exists, its value is set to VALUE, otherwise the
-new PROPERTY VALUE pair is added.
-Return TAG.
-That function is for internal use only."
- (let* ((plist-cdr (semantic--tag-properties-cdr tag)))
- (when (consp plist-cdr)
- (setcar plist-cdr
- (semantic-tag-make-plist
- (plist-put (copy-sequence (car plist-cdr))
- property value))))
- tag))
-
-(defun semantic-tag-file-name (tag)
- "Return the name of the file from which TAG originated.
-Return nil if that information can't be obtained.
-If TAG is from a loaded buffer, then that buffer's filename is used.
-If TAG is unlinked, but has a :filename property, then that is used."
- (let ((buffer (semantic-tag-in-buffer-p tag)))
- (if buffer
- (buffer-file-name buffer)
- (semantic--tag-get-property tag :filename))))
-\f
-;;; Tag tests and comparisons.
-(defsubst semantic-tag-p (tag)
- "Return non-nil if TAG is most likely a semantic tag."
- (condition-case nil
- (and (consp tag)
- (stringp (car tag)) ; NAME
- (symbolp (nth 1 tag)) (nth 1 tag) ; TAG-CLASS
- (listp (nth 2 tag)) ; ATTRIBUTES
- (listp (nth 3 tag)) ; PROPERTIES
- )
- ;; If an error occurs, then it most certainly is not a tag.
- (error nil)))
-
-;; Used in `semantic-utest-ia.el'.
-(cl-deftype semantic-tag () `(satisfies semantic-tag-p))
-
-(defsubst semantic-tag-of-class-p (tag class)
- "Return non-nil if class of TAG is CLASS."
- (eq (semantic-tag-class tag) class))
-
-(defsubst semantic-tag-type-members (tag)
- "Return the members of the type that TAG describes.
-That is the value of the `:members' attribute."
- (semantic-tag-get-attribute tag :members))
-
-(defsubst semantic-tag-type (tag)
- "Return the value of the `:type' attribute of TAG.
-For a function it would be the data type of the return value.
-For a variable, it is the storage type of that variable.
-For a data type, the type is the style of datatype, such as
-struct or union."
- (semantic-tag-get-attribute tag :type))
-
-(defun semantic-tag-with-position-p (tag)
- "Return non-nil if TAG has positional information."
- (and (semantic-tag-p tag)
- (let ((o (semantic-tag-overlay tag)))
- (or (and (overlayp o)
- (overlay-buffer o))
- (arrayp o)))))
-
-(defun semantic-equivalent-tag-p (tag1 tag2)
- "Compare TAG1 and TAG2 and return non-nil if they are equivalent.
-Use `equal' on elements the name, class, and position.
-Use this function if tags are being copied and regrouped to test
-for if two tags represent the same thing, but may be constructed
-of different cons cells."
- (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
- (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
- (or (and (not (semantic-tag-overlay tag1))
- (not (semantic-tag-overlay tag2)))
- (and (semantic-tag-overlay tag1)
- (semantic-tag-overlay tag2)
- (equal (semantic-tag-bounds tag1)
- (semantic-tag-bounds tag2))))))
-
-
-(defun semantic-tag-similar-with-subtags-p (tag1 tag2 &rest ignorable-attributes)
- "Test to see if TAG1 and TAG2 are similar.
-Uses `semantic-tag-similar-p' but also recurses through sub-tags, such
-as argument lists and type members.
-Optional argument IGNORABLE-ATTRIBUTES is passed down to
-`semantic-tag-similar-p'."
- ;; DEPRECATE THIS.
- (semantic-tag-similar-p tag1 tag2 ignorable-attributes))
-
-(defun semantic-tag-of-type-p (tag type)
- "Compare TAG's type against TYPE. Non nil if equivalent.
-TYPE can be a string, or a tag of class `type'.
-This can be complex since some tags might have a :type that is a tag,
-while other tags might just have a string. This function will also be
-return true of TAG's type is compared directly to the declaration of a
-data type."
- (let* ((tagtype (semantic-tag-type tag))
- (tagtypestring (cond ((stringp tagtype)
- tagtype)
- ((and (semantic-tag-p tagtype)
- (semantic-tag-of-class-p tagtype 'type))
- (semantic-tag-name tagtype))
- (t "")))
- (typestring (cond ((stringp type)
- type)
- ((and (semantic-tag-p type)
- (semantic-tag-of-class-p type 'type))
- (semantic-tag-name type))
- (t "")))
- )
- (and
- tagtypestring
- (or
- ;; Matching strings (input type is string)
- (and (stringp type)
- (string= tagtypestring type))
- ;; Matching strings (tag type is string)
- (and (stringp tagtype)
- (string= tagtype typestring))
- ;; Matching tokens, and the type of the type is the same.
- (and (string= tagtypestring typestring)
- (if (and (semantic-tag-type tagtype) (semantic-tag-type type))
- (equal (semantic-tag-type tagtype) (semantic-tag-type type))
- t))
- ))
- ))
-
-(defun semantic-tag-type-compound-p (tag)
- "Return non-nil the type of TAG is compound.
-Compound implies a structure or similar data type.
-Returns the list of tag members if it is compound."
- (let* ((tagtype (semantic-tag-type tag))
- )
- (when (and (semantic-tag-p tagtype)
- (semantic-tag-of-class-p tagtype 'type))
- ;; We have the potential of this being a nifty compound type.
- (semantic-tag-type-members tagtype)
- )))
-
-(defun semantic-tag-faux-p (tag)
- "Return non-nil if TAG is a FAUX tag.
-FAUX tags are created to represent a construct that is
-not known to exist in the code.
-
-Example: When the class browser sees methods to a class, but
-cannot find the class, it will create a faux tag to represent the
-class to store those methods."
- (semantic--tag-get-property tag :faux-flag))
-\f
-;;; Tag creation
-;;
-
-(defsubst semantic-tag (name class &rest attributes)
- "Create a generic semantic tag.
-NAME is a string representing the name of this tag.
-CLASS is the symbol that represents the class of tag this is,
-such as `variable', or `function'.
-ATTRIBUTES is a list of additional attributes belonging to this tag."
- (list name class (semantic-tag-make-plist attributes) nil nil))
-
-(defsubst semantic-tag-new-variable (name type &optional default-value &rest attributes)
- "Create a semantic tag of class `variable'.
-NAME is the name of this variable.
-TYPE is a string or semantic tag representing the type of this variable.
-Optional DEFAULT-VALUE is a string representing the default value of this
-variable.
-ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply #'semantic-tag name 'variable
- :type type
- :default-value default-value
- attributes))
-
-(defsubst semantic-tag-new-function (name type arg-list &rest attributes)
- "Create a semantic tag of class `function'.
-NAME is the name of this function.
-TYPE is a string or semantic tag representing the type of this function.
-ARG-LIST is a list of strings or semantic tags representing the
-arguments of this function.
-ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply #'semantic-tag name 'function
- :type type
- :arguments arg-list
- attributes))
-
-(defsubst semantic-tag-new-type (name type members parents &rest attributes)
- "Create a semantic tag of class `type'.
-NAME is the name of this type.
-TYPE is a string or semantic tag representing the type of this type.
-MEMBERS is a list of strings or semantic tags representing the
-elements that make up this type if it is a composite type.
-PARENTS is a cons cell. (EXPLICIT-PARENTS . INTERFACE-PARENTS)
-EXPLICIT-PARENTS can be a single string (Just one parent) or a
-list of parents (in a multiple inheritance situation). It can also
-be nil.
-INTERFACE-PARENTS is a list of strings representing the names of
-all INTERFACES, or abstract classes inherited from. It can also be
-nil.
-This slot can be interesting because the form:
- ( nil \"string\")
-is a valid parent where there is no explicit parent, and only an
-interface.
-ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply #'semantic-tag name 'type
- :type type
- :members members
- :superclasses (car parents)
- :interfaces (cdr parents)
- attributes))
-
-(defsubst semantic-tag-new-include (name system-flag &rest attributes)
- "Create a semantic tag of class `include'.
-NAME is the name of this include.
-SYSTEM-FLAG represents that we were able to identify this include as
-belonging to the system, as opposed to belonging to the local project.
-ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply #'semantic-tag name 'include
- :system-flag system-flag
- attributes))
-
-(defsubst semantic-tag-new-package (name detail &rest attributes)
- "Create a semantic tag of class `package'.
-NAME is the name of this package.
-DETAIL is extra information about this package, such as a location
-where it can be found.
-ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply #'semantic-tag name 'package
- :detail detail
- attributes))
-
-(defsubst semantic-tag-new-code (name detail &rest attributes)
- "Create a semantic tag of class `code'.
-NAME is a name for this code.
-DETAIL is extra information about the code.
-ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply #'semantic-tag name 'code
- :detail detail
- attributes))
-
-(defsubst semantic-tag-set-faux (tag)
- "Set TAG to be a new FAUX tag.
-FAUX tags represent constructs not found in the source code.
-You can identify a faux tag with `semantic-tag-faux-p'."
- (semantic--tag-put-property tag :faux-flag t))
-
-(defsubst semantic-tag-set-name (tag name)
- "Set TAG name to NAME."
- (setcar tag name))
-
-;;; TAG Proxies
-;;
-;; A new kind of tag is a TAG PROXY. These are tags that have some
-;; minimal number of features set, such as name and class, but have a
-;; marker in them that indicates how to complete them.
-;;
-;; To make the tags easier to view, the proxy is stored as custom
-;; symbol that is not in the global obarray, but has properties set on
-;; it. This prevents saving of massive amounts of proxy data.
-(defun semantic-create-tag-proxy (function data)
- "Create a tag proxy symbol.
-FUNCTION will be used to resolve the proxy. It should take
-two arguments, DATA and TAG. TAG is a proxy tag that needs
-to be resolved, and DATA is the data passed into this function.
-DATA is data to help resolve the proxy. DATA can be an EIEIO object,
-such that FUNCTION is a method.
-FUNCTION should return a list of tags, preferably one tag."
- (let ((sym (make-symbol ":tag-proxy")))
- (put sym 'proxy-function function)
- (put sym 'proxy-data data)
- sym))
-
-(defun semantic-tag-set-proxy (tag proxy &optional filename)
- "Set TAG to be a proxy. The proxy can be resolved with PROXY.
-This function will also make TAG be a faux tag with
-`semantic-tag-set-faux', and possibly set the tag's
-:filename with FILENAME.
-To create a proxy, see `semantic-create-tag-proxy'."
- (semantic-tag-set-faux tag)
- (semantic--tag-put-property tag :proxy proxy)
- (when filename
- (semantic--tag-put-property tag :filename filename)))
-
-(defun semantic-tag-resolve-proxy (tag)
- "Resolve the proxy in TAG.
-The return value is whatever format the proxy was setup as.
-It should be a list of complete tags.
-If TAG has no proxy, then just return tag."
- (let* ((proxy (semantic--tag-get-property tag :proxy))
- (function (get proxy 'proxy-function))
- (data (get proxy 'proxy-data)))
- (if proxy
- (funcall function data tag)
- tag)))
-
-;;; Copying and cloning tags.
-;;
-(defsubst semantic-tag-clone (tag &optional name)
- "Clone TAG, creating a new TAG.
-If optional argument NAME is not nil it specifies a new name for the
-cloned tag."
- ;; Right now, TAG is a list.
- (list (or name (semantic-tag-name tag))
- (semantic-tag-class tag)
- (copy-sequence (semantic-tag-attributes tag))
- (copy-sequence (semantic-tag-properties tag))
- (semantic-tag-overlay tag)))
-
-(defun semantic-tag-copy (tag &optional name keep-file)
- "Return a copy of TAG unlinked from the originating buffer.
-If optional argument NAME is non-nil it specifies a new name for the
-copied tag.
-If optional argument KEEP-FILE is non-nil, and TAG was linked to a
-buffer, the originating buffer file name is kept in the `:filename'
-property of the copied tag.
-If KEEP-FILE is a string, and the originating buffer is NOT available,
-then KEEP-FILE is stored on the `:filename' property.
-This runs the tag hook `unlink-copy-hook'."
- ;; Right now, TAG is a list.
- (let ((copy (semantic-tag-clone tag name)))
-
- ;; Keep the filename if needed.
- (when keep-file
- (semantic--tag-put-property
- copy :filename (or (semantic-tag-file-name copy)
- (and (stringp keep-file)
- keep-file)
- )))
-
- (when (semantic-tag-with-position-p tag)
- ;; Convert the overlay to a vector, effectively 'unlinking' the tag.
- (semantic--tag-set-overlay
- copy (vector (semantic-tag-start copy) (semantic-tag-end copy)))
-
- ;; Force the children to be copied also.
- ;;(let ((chil (semantic--tag-copy-list
- ;; (semantic-tag-components-with-overlays tag)
- ;; keep-file)))
- ;;;; Put the list into TAG.
- ;;)
-
- ;; Call the unlink-copy hook. This should tell tools that
- ;; this tag is not part of any buffer.
- (when (overlayp (semantic-tag-overlay tag))
- (semantic--tag-run-hooks copy 'unlink-copy-hook))
- )
- copy))
-
-;;(defun semantic--tag-copy-list (tags &optional keep-file)
-;; "Make copies of TAGS and return the list of TAGS."
-;; (let ((out nil))
-;; (dolist (tag tags out)
-;; (setq out (cons (semantic-tag-copy tag nil keep-file)
-;; out))
-;; )))
-
-(defun semantic--tag-copy-properties (tag1 tag2)
- "Copy private properties from TAG1 to TAG2.
-Return TAG2.
-This function is for internal use only."
- (let ((plist (semantic-tag-properties tag1)))
- (while plist
- (semantic--tag-put-property tag2 (car plist) (nth 1 plist))
- (setq plist (nthcdr 2 plist)))
- tag2))
-
-;;; DEEP COPIES
-;;
-(defun semantic-tag-deep-copy-one-tag (tag &optional filter)
- "Make a deep copy of TAG, applying FILTER to each child-tag.
-No properties are copied except for :filename.
-Overlay will be a vector.
-FILTER takes TAG as an argument, and should return a `semantic-tag'.
-It is safe for FILTER to modify the input tag and return it."
- (when (not filter) (setq filter 'identity))
- (when (not (semantic-tag-p tag))
- (signal 'wrong-type-argument (list tag #'semantic-tag-p)))
- (let ((ol (semantic-tag-overlay tag))
- (fn (semantic-tag-file-name tag)))
- (funcall filter (list (semantic-tag-name tag)
- (semantic-tag-class tag)
- (semantic--tag-deep-copy-attributes
- (semantic-tag-attributes tag) filter)
- ;; Only copy the filename property
- (when fn (list :filename fn))
- ;; Only setup a vector if we had an overlay.
- (when ol (vector (semantic-tag-start tag)
- (semantic-tag-end tag)))))))
-
-(defun semantic--tag-deep-copy-attributes (attrs &optional filter)
- "Make a deep copy of ATTRS, applying FILTER to each child-tag.
-
-It is safe to modify ATTR, and return a permutation of that list.
-
-FILTER takes TAG as an argument, and should return a semantic-tag.
-It is safe for FILTER to modify the input tag and return it."
- (when (car attrs)
- (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag"))
- (cons (car attrs)
- (cons (semantic--tag-deep-copy-value (nth 1 attrs) filter)
- (semantic--tag-deep-copy-attributes (nthcdr 2 attrs) filter)))))
-
-(defun semantic--tag-deep-copy-value (value &optional filter)
- "Make a deep copy of VALUE, applying FILTER to each child-tag.
-
-It is safe to modify VALUE, and return a permutation of that list.
-
-FILTER takes TAG as an argument, and should return a semantic-tag.
-It is safe for FILTER to modify the input tag and return it."
- (cond
- ;; Another tag.
- ((semantic-tag-p value)
- (semantic-tag-deep-copy-one-tag value filter))
-
- ;; A list of more tags
- ((and (listp value) (semantic-tag-p (car value)))
- (semantic--tag-deep-copy-tag-list value filter))
-
- ;; Some arbitrary data.
- (t value)))
-
-(defun semantic--tag-deep-copy-tag-list (tags &optional filter)
- "Make a deep copy of TAGS, applying FILTER to each child-tag.
-
-It is safe to modify the TAGS list, and return a permutation of that list.
-
-FILTER takes TAG as an argument, and should return a semantic-tag.
-It is safe for FILTER to modify the input tag and return it."
- (when (car tags)
- (if (semantic-tag-p (car tags))
- (cons (semantic-tag-deep-copy-one-tag (car tags) filter)
- (semantic--tag-deep-copy-tag-list (cdr tags) filter))
- (cons (car tags) (semantic--tag-deep-copy-tag-list (cdr tags) filter)))))
-
-\f
-;;; Standard Tag Access
-;;
-
-;;; Common
-;;
-(defsubst semantic-tag-modifiers (tag)
- "Return the value of the `:typemodifiers' attribute of TAG."
- (semantic-tag-get-attribute tag :typemodifiers))
-
-(defun semantic-tag-docstring (tag &optional buffer)
- "Return the documentation of TAG.
-That is the value defined by the `:documentation' attribute.
-Optional argument BUFFER indicates where to get the text from.
-If not provided, then only the POSITION can be provided.
-
-If you want to get documentation for languages that do not store
-the documentation string in the tag itself, use
-`semantic-documentation-for-tag' instead."
- (let ((p (semantic-tag-get-attribute tag :documentation)))
- (cond
- ((stringp p) p) ;; it is the doc string.
-
- ((semantic-lex-token-with-text-p p)
- (semantic-lex-token-text p))
-
- ((and (semantic-lex-token-without-text-p p)
- buffer)
- (with-current-buffer buffer
- (semantic-lex-token-text (car (semantic-lex p (1+ p))))))
-
- (t nil))))
-
-;;; Generic attributes for tags of any class.
-;;
-(defsubst semantic-tag-named-parent (tag)
- "Return the parent of TAG.
-That is the value of the `:parent' attribute.
-If a definition can occur outside an actual parent structure, but
-refers to that parent by name, then the :parent attribute should be used."
- (semantic-tag-get-attribute tag :parent))
-
-;;; Tags of class `type'
-
-(defun semantic-tag-type-superclasses (tag)
- "Return the list of superclass names of the type that TAG describes."
- (let ((supers (semantic-tag-get-attribute tag :superclasses)))
- (cond ((stringp supers)
- ;; If we have a string, make it a list.
- (list supers))
- ((semantic-tag-p supers)
- ;; If we have one tag, return just the name.
- (list (semantic-tag-name supers)))
- ((and (consp supers) (semantic-tag-p (car supers)))
- ;; If we have a tag list, then return the names.
- (mapcar (lambda (s) (semantic-tag-name s))
- supers))
- ((consp supers)
- ;; A list of something, return it.
- supers))))
-
-(defun semantic--tag-find-parent-by-name (name supers)
- "Find the superclass NAME in the list of SUPERS.
-If a simple search doesn't do it, try splitting up the names
-in SUPERS."
- (let ((stag nil))
- (setq stag (semantic-find-first-tag-by-name name supers))
-
- (when (not stag)
- (require 'semantic/analyze/fcn)
- (dolist (S supers)
- (let* ((sname (semantic-tag-name S))
- (splitparts (semantic-analyze-split-name sname))
- (parts (if (stringp splitparts)
- (list splitparts)
- (nreverse splitparts))))
- (when (string= name (car parts))
- (setq stag S))
- )))
-
- stag))
-
-(defun semantic-tag-type-superclass-protection (tag parentstring)
- "Return the inheritance protection in TAG from PARENTSTRING.
-PARENTSTRING is the name of the parent being inherited.
-The return protection is a symbol, `public', `protection', and `private'."
- (let ((supers (semantic-tag-get-attribute tag :superclasses)))
- (cond ((stringp supers)
- 'public)
- ((semantic-tag-p supers)
- (let ((prot (semantic-tag-get-attribute supers :protection)))
- (or (cdr (assoc prot '(("public" . public)
- ("protected" . protected)
- ("private" . private))))
- 'public)))
- ((and (consp supers) (stringp (car supers)))
- 'public)
- ((and (consp supers) (semantic-tag-p (car supers)))
- (let* ((stag (semantic--tag-find-parent-by-name parentstring supers))
- (prot (when stag
- (semantic-tag-get-attribute stag :protection))))
- (or (cdr (assoc prot '(("public" . public)
- ("protected" . protected)
- ("private" . private))))
- (when (equal prot "unspecified")
- (if (semantic-tag-of-type-p tag "class")
- 'private
- 'public))
- 'public))))
- ))
-
-(defsubst semantic-tag-type-interfaces (tag)
- "Return the list of interfaces of the type that TAG describes."
- ;; @todo - make this as robust as the above.
- (semantic-tag-get-attribute tag :interfaces))
-
-;;; Tags of class `function'
-;;
-(defsubst semantic-tag-function-arguments (tag)
- "Return the arguments of the function that TAG describes.
-That is the value of the `:arguments' attribute."
- (semantic-tag-get-attribute tag :arguments))
-
-(defsubst semantic-tag-function-throws (tag)
- "Return the exceptions the function that TAG describes can throw.
-That is the value of the `:throws' attribute."
- (semantic-tag-get-attribute tag :throws))
-
-(defsubst semantic-tag-function-parent (tag)
- "Return the parent of the function that TAG describes.
-That is the value of the `:parent' attribute.
-A function has a parent if it is a method of a class, and if the
-function does not appear in the body of its parent class."
- (semantic-tag-named-parent tag))
-
-(defsubst semantic-tag-function-destructor-p (tag)
- "Return non-nil if TAG describes a destructor function.
-That is the value of the `:destructor-flag' attribute."
- (semantic-tag-get-attribute tag :destructor-flag))
-
-(defsubst semantic-tag-function-constructor-p (tag)
- "Return non-nil if TAG describes a constructor function.
-That is the value of the `:constructor-flag' attribute."
- (semantic-tag-get-attribute tag :constructor-flag))
-
-;;; Tags of class `variable'
-;;
-(defsubst semantic-tag-variable-default (tag)
- "Return the default value of the variable that TAG describes.
-That is the value of the attribute `:default-value'."
- (semantic-tag-get-attribute tag :default-value))
-
-(defsubst semantic-tag-variable-constant-p (tag)
- "Return non-nil if the variable that TAG describes is a constant.
-That is the value of the attribute `:constant-flag'."
- (semantic-tag-get-attribute tag :constant-flag))
-
-;;; Tags of class `include'
-;;
-(defsubst semantic-tag-include-system-p (tag)
- "Return non-nil if the include that TAG describes is a system include.
-That is the value of the attribute `:system-flag'."
- (semantic-tag-get-attribute tag :system-flag))
-
-(define-overloadable-function semantic-tag-include-filename (tag)
- "Return a filename representation of TAG.
-The default action is to return the `semantic-tag-name'.
-Some languages do not use full filenames in their include statements.
-Override this method to translate the code representation
-into a filename. (A relative filename if necessary.)
-
-See `semantic-dependency-tag-file' to expand an include
-tag to a full file name.")
-
-(defun semantic-tag-include-filename-default (tag)
- "Return a filename representation of TAG.
-Returns `semantic-tag-name'."
- (semantic-tag-name tag))
-
-;;; Tags of class `code'
-;;
-(defsubst semantic-tag-code-detail (tag)
- "Return detail information from code that TAG describes.
-That is the value of the attribute `:detail'."
- (semantic-tag-get-attribute tag :detail))
-
-;;; Tags of class `alias'
-;;
-(defsubst semantic-tag-new-alias (name meta-tag-class value &rest attributes)
- "Create a semantic tag of class alias.
-NAME is a name for this alias.
-META-TAG-CLASS is the class of the tag this tag is an alias.
-VALUE is the aliased definition.
-ATTRIBUTES is a list of additional attributes belonging to this tag."
- (apply #'semantic-tag name 'alias
- :aliasclass meta-tag-class
- :definition value
- attributes))
-
-(defsubst semantic-tag-alias-class (tag)
- "Return the class of tag TAG is an alias."
- (semantic-tag-get-attribute tag :aliasclass))
-
-(define-overloadable-function semantic-tag-alias-definition (tag)
- "Return the definition TAG is an alias.
-The returned value is a tag of the class that
-`semantic-tag-alias-class' returns for TAG.
-The default is to return the value of the :definition attribute.
-Return nil if TAG is not of class `alias'."
- (when (semantic-tag-of-class-p tag 'alias)
- (:override
- (semantic-tag-get-attribute tag :definition))))
-
-;;; Language Specific Tag access via overload
-;;
-;;;###autoload
-(define-overloadable-function semantic-tag-components (tag)
- "Return a list of components for TAG.
-A Component is a part of TAG which itself may be a TAG.
-Examples include the elements of a structure in a
-tag of class `type', or the list of arguments to a
-tag of class `function'."
- )
-
-(defun semantic-tag-components-default (tag)
- "Return a list of components for TAG.
-Perform the described task in `semantic-tag-components'."
- (cond ((semantic-tag-of-class-p tag 'type)
- (semantic-tag-type-members tag))
- ((semantic-tag-of-class-p tag 'function)
- (semantic-tag-function-arguments tag))
- (t nil)))
-
-(define-overloadable-function semantic-tag-components-with-overlays (tag)
- "Return the list of top level components belonging to TAG.
-Children are any sub-tags which contain overlays.
-
-Default behavior is to get `semantic-tag-components' in addition
-to the components of an anonymous type (if applicable.)
-
-Note for language authors:
- If a mode defines a language tag that has tags in it with overlays
-you should still return them with this function.
-Ignoring this step will prevent several features from working correctly."
- )
-
-(defun semantic-tag-components-with-overlays-default (tag)
- "Return the list of top level components belonging to TAG.
-Children are any sub-tags which contain overlays.
-The default action collects regular components of TAG, in addition
-to any components belonging to an anonymous type."
- (let ((explicit-children (semantic-tag-components tag))
- (type (semantic-tag-type tag))
- (anon-type-children nil)
- (all-children nil))
- ;; Identify if this tag has an anonymous structure as
- ;; its type. This implies it may have children with overlays.
- (when (and type (semantic-tag-p type))
- (setq anon-type-children (semantic-tag-components type))
- ;; Add anonymous children
- (while anon-type-children
- (when (semantic-tag-with-position-p (car anon-type-children))
- (setq all-children (cons (car anon-type-children) all-children)))
- (setq anon-type-children (cdr anon-type-children))))
- ;; Add explicit children
- (while explicit-children
- (when (semantic-tag-with-position-p (car explicit-children))
- (setq all-children (cons (car explicit-children) all-children)))
- (setq explicit-children (cdr explicit-children)))
- ;; Return
- (nreverse all-children)))
-
-(defun semantic-tag-children-compatibility (tag &optional positiononly)
- "Return children of TAG.
-If POSITIONONLY is nil, use `semantic-tag-components'.
-If POSITIONONLY is non-nil, use `semantic-tag-components-with-overlays'.
-DO NOT use this fcn in new code. Use one of the above instead."
- (if positiononly
- (semantic-tag-components-with-overlays tag)
- (semantic-tag-components tag)))
-\f
-;;; Tag Region
-;;
-;; A Tag represents a region in a buffer. You can narrow to that tag.
-;;
-(defun semantic-narrow-to-tag (&optional tag)
- "Narrow to the region specified by the bounds of TAG.
-See `semantic-tag-bounds'."
- (interactive)
- (if (not tag) (setq tag (semantic-current-tag)))
- (narrow-to-region (semantic-tag-start tag)
- (semantic-tag-end tag)))
-
-(defmacro semantic-with-buffer-narrowed-to-current-tag (&rest body)
- "Execute BODY with the buffer narrowed to the current tag."
- (declare (indent 0) (debug t))
- `(save-restriction
- (semantic-narrow-to-tag (semantic-current-tag))
- ,@body))
-
-(defmacro semantic-with-buffer-narrowed-to-tag (tag &rest body)
- "Narrow to TAG, and execute BODY."
- (declare (indent 1) (debug t))
- `(save-restriction
- (semantic-narrow-to-tag ,tag)
- ,@body))
-\f
-;;; Tag Hooks
-;;
-;; Semantic may want to provide special hooks when specific operations
-;; are about to happen on a given tag. These routines allow for hook
-;; maintenance on a tag.
-
-;; Internal global variable used to manage tag hooks. For example,
-;; some implementation of `remove-hook' checks that the hook variable
-;; is `default-boundp'.
-(defvar semantic--tag-hook-value)
-
-(defun semantic-tag-add-hook (tag hook function &optional append)
- "Onto TAG, add to the value of HOOK the function FUNCTION.
-FUNCTION is added (if necessary) at the beginning of the hook list
-unless the optional argument APPEND is non-nil, in which case
-FUNCTION is added at the end.
-HOOK should be a symbol, and FUNCTION may be any valid function.
-See also the function `add-hook'."
- (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)))
- (add-hook 'semantic--tag-hook-value function append)
- (semantic--tag-put-property tag hook semantic--tag-hook-value)
- semantic--tag-hook-value))
-
-(defun semantic-tag-remove-hook (tag hook function)
- "Onto TAG, remove from the value of HOOK the function FUNCTION.
-HOOK should be a symbol, and FUNCTION may be any valid function. If
-FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in
-the list of hooks to run in HOOK, then nothing is done.
-See also the function `remove-hook'."
- (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)))
- (remove-hook 'semantic--tag-hook-value function)
- (semantic--tag-put-property tag hook semantic--tag-hook-value)
- semantic--tag-hook-value))
-
-(defun semantic--tag-run-hooks (tag hook &rest args)
- "Run for TAG all expressions saved on the property HOOK.
-Each hook expression must take at least one argument, the TAG.
-For any given situation, additional ARGS may be passed."
- (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))
- (arglist (cons tag args)))
- (condition-case err
- ;; If a hook bombs, ignore it! Usually this is tied into
- ;; some sort of critical system.
- (apply #'run-hook-with-args 'semantic--tag-hook-value arglist)
- (error (message "Error: %S" err)))))
-\f
-;;; Tags and Overlays
-;;
-;; Overlays are used so that we can quickly identify tags from
-;; buffer positions and regions using built in Emacs commands.
-;;
-(defsubst semantic--tag-unlink-list-from-buffer (tags)
- "Convert TAGS from using an overlay to using an overlay proxy.
-This function is for internal use only."
- (mapcar #'semantic--tag-unlink-from-buffer tags))
-
-(defun semantic--tag-unlink-from-buffer (tag)
- "Convert TAG from using an overlay to using an overlay proxy.
-This function is for internal use only."
- (when (semantic-tag-p tag)
- (let ((o (semantic-tag-overlay tag)))
- (when (overlayp o)
- (semantic--tag-set-overlay
- tag (vector (overlay-start o)
- (overlay-end o)))
- (delete-overlay o))
- ;; Look for a link hook on TAG.
- (semantic--tag-run-hooks tag 'unlink-hook)
- ;; Fix the sub-tags which contain overlays.
- (semantic--tag-unlink-list-from-buffer
- (semantic-tag-components-with-overlays tag)))))
-
-(defsubst semantic--tag-link-list-to-buffer (tags)
- "Convert TAGS from using an overlay proxy to using an overlay.
-This function is for internal use only."
- (mapc #'semantic--tag-link-to-buffer tags))
-
-(defun semantic--tag-link-to-buffer (tag)
- "Convert TAG from using an overlay proxy to using an overlay.
-This function is for internal use only."
- (when (semantic-tag-p tag)
- (let ((o (semantic-tag-overlay tag)))
- (when (and (vectorp o) (= (length o) 2))
- (setq o (make-overlay (aref o 0) (aref o 1) (current-buffer)))
- (semantic--tag-set-overlay tag o)
- (overlay-put o 'semantic tag)
- ;; Clear the :filename property
- (semantic--tag-put-property tag :filename nil))
- ;; Look for a link hook on TAG.
- (semantic--tag-run-hooks tag 'link-hook)
- ;; Fix the sub-tags which contain overlays.
- (semantic--tag-link-list-to-buffer
- (semantic-tag-components-with-overlays tag)))))
-
-(defun semantic--tag-unlink-cache-from-buffer ()
- "Convert all tags in the current cache to use overlay proxies.
-This function is for internal use only."
- (require 'semantic)
- (semantic--tag-unlink-list-from-buffer
- ;; @todo- use fetch-tags-fast?
- (semantic-fetch-tags)))
-
-(defvar semantic--buffer-cache)
-
-(defun semantic--tag-link-cache-to-buffer ()
- "Convert all tags in the current cache to use overlays.
-This function is for internal use only."
- (require 'semantic)
- (condition-case nil
- ;; In this unique case, we cannot call the usual toplevel fn.
- ;; because we don't want a reparse, we want the old overlays.
- (semantic--tag-link-list-to-buffer
- semantic--buffer-cache)
- ;; Recover when there is an error restoring the cache.
- (error (message "Error recovering tag list")
- (semantic-clear-toplevel-cache)
- nil)))
-\f
-;;; Tag Cooking
-;;
-;; Raw tags from a parser follow a different positional format than
-;; those used in the buffer cache. Raw tags need to be cooked into
-;; semantic cache friendly tags for use by the masses.
-;;
-(defsubst semantic--tag-expanded-p (tag)
- "Return non-nil if TAG is expanded.
-This function is for internal use only.
-See also the function `semantic--tag-expand'."
- ;; In fact a cooked tag is actually a list of cooked tags
- ;; because a raw tag can be expanded in several cooked ones!
- (when (consp tag)
- (while (and (semantic-tag-p (car tag))
- (vectorp (semantic-tag-overlay (car tag))))
- (setq tag (cdr tag)))
- (null tag)))
-
-(defvar-local semantic-tag-expand-function nil
- "Function used to expand a tag.
-It is passed each tag production, and must return a list of tags
-derived from it, or nil if it does not need to be expanded.
-
-Languages with compound definitions should use this function to expand
-from one compound symbol into several. For example, in C or Java the
-following definition is easily parsed into one tag:
-
- int a, b;
-
-This function should take this compound tag and turn it into two tags,
-one for A, and the other for B.")
-
-(defun semantic--tag-expand (tag)
- "Convert TAG from a raw state to a cooked state, and expand it.
-Returns a list of cooked tags.
-
- The parser returns raw tags with positional data START END at the
-end of the tag data structure (a list for now). We convert it from
-that to a cooked state that uses an overlay proxy, that is, a vector
-[START END].
-
- The raw tag is changed with side effects and maybe expanded in
-several derived tags when the variable `semantic-tag-expand-function'
-is set.
-
-This function is for internal use only."
- (if (semantic--tag-expanded-p tag)
- ;; Just return TAG if it is already expanded (by a grammar
- ;; semantic action), or if it isn't recognized as a valid
- ;; semantic tag.
- tag
-
- ;; Try to cook the tag. This code will be removed when tag will
- ;; be directly created with the right format.
- (condition-case nil
- (let ((ocdr (semantic--tag-overlay-cdr tag)))
- ;; OCDR contains the sub-list of TAG whose car is the
- ;; OVERLAY part of TAG. That is, a list (OVERLAY START END).
- ;; Convert it into an overlay proxy ([START END]).
- (semantic--tag-set-overlay
- tag (vector (nth 1 ocdr) (nth 2 ocdr)))
- ;; Remove START END positions at end of tag.
- (setcdr ocdr nil)
- ;; At this point (length TAG) must be 5!
- ;;(unless (= (length tag) 5)
- ;; (error "Tag expansion failed"))
- )
- (error
- (message "A Rule must return a single tag-line list!")
- (debug tag)
- nil))
- ;; Expand based on local configuration
- (if semantic-tag-expand-function
- (or (funcall semantic-tag-expand-function tag)
- (list tag))
- (list tag))))
-\f
-;; Foreign tags
-;;
-(defmacro semantic-foreign-tag-invalid (tag)
- "Signal that TAG is an invalid foreign tag."
- `(signal 'wrong-type-argument '(semantic-foreign-tag-p ,tag)))
-
-(defsubst semantic-foreign-tag-p (tag)
- "Return non-nil if TAG is a foreign tag.
-That is, a tag unlinked from the originating buffer, which carries the
-originating buffer file name, and major mode."
- (and (semantic-tag-p tag)
- (semantic--tag-get-property tag :foreign-flag)))
-
-(defsubst semantic-foreign-tag-check (tag)
- "Check that TAG is a valid foreign tag.
-Signal an error if not."
- (or (semantic-foreign-tag-p tag)
- (semantic-foreign-tag-invalid tag)))
-
-(defun semantic-foreign-tag (&optional tag)
- "Return a copy of TAG as a foreign tag, or nil if it can't be done.
-TAG defaults to the tag at point in current buffer.
-See also `semantic-foreign-tag-p'."
- (or tag (setq tag (semantic-current-tag)))
- (when (semantic-tag-p tag)
- (let ((ftag (semantic-tag-copy tag nil t))
- ;; Do extra work for the doc strings, since this is a
- ;; common use case.
- (doc (condition-case nil
- (semantic-documentation-for-tag tag)
- (error nil))))
- ;; A foreign tag must carry its originating buffer file name!
- (when (semantic--tag-get-property ftag :filename)
- (semantic--tag-put-property ftag :mode (semantic-tag-mode tag))
- (semantic--tag-put-property ftag :documentation doc)
- (semantic--tag-put-property ftag :foreign-flag t)
- ftag))))
-
-;; High level obtain/insert foreign tag overloads
-(define-overloadable-function semantic-obtain-foreign-tag (&optional tag)
- "Obtain a foreign tag from TAG.
-TAG defaults to the tag at point in current buffer.
-Return the obtained foreign tag or nil if failed."
- (semantic-foreign-tag tag))
-
-(defun semantic-insert-foreign-tag-default (foreign-tag)
- "Insert FOREIGN-TAG into the current buffer.
-The default behavior assumes the current buffer is a language file,
-and attempts to insert a prototype/function call."
- ;; Long term goal: Have a mechanism for a tempo-like template insert
- ;; for the given tag.
- (insert (semantic-format-tag-prototype foreign-tag)))
-
-(define-overloadable-function semantic-insert-foreign-tag (foreign-tag)
- "Insert FOREIGN-TAG into the current buffer.
-Signal an error if FOREIGN-TAG is not a valid foreign tag.
-This function is overridable with the symbol `insert-foreign-tag'."
- (semantic-foreign-tag-check foreign-tag)
- (:override)
- (message (semantic-format-tag-summarize foreign-tag)))
-
-;;; Support log modes here
-(define-mode-local-override semantic-insert-foreign-tag
- log-edit-mode (foreign-tag)
- "Insert foreign tags into `log-edit' mode."
- (insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
-
-(define-mode-local-override semantic-insert-foreign-tag
- change-log-mode (foreign-tag)
- "Insert foreign tags into `log-edit' mode."
- (insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
-\f
-
-(provide 'semantic/tag)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/tag"
-;; End:
-
-;;; semantic/tag.el ends here
+++ /dev/null
-;;; semantic/texi.el --- Semantic details for Texinfo files -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2001-2005, 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Parse Texinfo buffers using regular expressions. The core parser
-;; engine is the function `semantic-texi-parse-headings'. The
-;; parser plug-in is the function `semantic-texi-parse-region' that
-;; overrides `semantic-parse-region'.
-
-(require 'semantic/db-find)
-(require 'semantic/format)
-(require 'semantic/ctxt)
-(require 'texinfo)
-
-(defvar ede-minor-mode)
-(declare-function ispell-lookup-words "ispell")
-(declare-function ede-current-project "ede")
-
-(defvar semantic-texi-super-regex
- "^@\\(top\\|chapter\\|\\(sub\\)*section\\|unnumbered\\(\\(sub\\)*sec\\)?\\|\
-\\(chap\\|\\(sub\\)+\\|major\\)?heading\\|appendix\\(\\(sub\\)*sec\\)?\\|\
-centerchap\\|def\\(var\\|un\\|fn\\|opt\\)x?\\)"
- "Regular expression used to find special sections in a Texinfo file.")
-
-(defvar semantic-texi-name-field-list
- '( ("defvar" . 1)
- ("defvarx" . 1)
- ("defun" . 1)
- ("defunx" . 1)
- ("defopt" . 1)
- ("deffn" . 2)
- ("deffnx" . 2)
- )
- "List of definition commands, and the field position.
-The field position is the field number (based at 1) where the
-name of this section is.")
-
-;;; Code:
-(define-mode-local-override semantic-parse-region texinfo-mode (&rest _ignore)
- "Parse the current texinfo buffer for semantic tags.
-IGNORE any arguments, always parse the whole buffer.
-Each tag returned is of the form:
- (\"NAME\" section (:members CHILDREN))
-or
- (\"NAME\" def)"
- (mapcar #'semantic-texi-expand-tag
- (semantic-texi-parse-headings)))
-
-(define-mode-local-override semantic-parse-changes texinfo-mode ()
- "Parse changes in the current texinfo buffer."
- ;; NOTE: For now, just schedule a full reparse.
- ;; To be implemented later.
- (semantic-parse-tree-set-needs-rebuild))
-
-(defun semantic-texi-expand-tag (tag)
- "Expand the texinfo tag TAG."
- (let ((chil (semantic-tag-components tag)))
- (if chil
- (semantic-tag-put-attribute
- tag :members (mapcar #'semantic-texi-expand-tag chil)))
- (car (semantic--tag-expand tag))))
-
-(defun semantic-texi-parse-headings ()
- "Parse the current texinfo buffer for all semantic tags now."
- (let ((pass1 nil))
- ;; First search and snarf.
- (save-excursion
- (goto-char (point-min))
- (let ((semantic--progress-reporter
- (make-progress-reporter
- (format "Parsing %s..."
- (file-name-nondirectory buffer-file-name))
- (point-min) (point-max))))
- (while (re-search-forward semantic-texi-super-regex nil t)
- (setq pass1 (cons (match-beginning 0) pass1))
- (progress-reporter-update semantic--progress-reporter (point)))
- (progress-reporter-done semantic--progress-reporter)))
- (setq pass1 (nreverse pass1))
- ;; Now, make some tags while creating a set of children.
- (car (semantic-texi-recursive-combobulate-list pass1 0))
- ))
-
-(defsubst semantic-texi-new-section-tag (name members start end)
- "Create a semantic tag of class section.
-NAME is the name of this section.
-MEMBERS is a list of semantic tags representing the elements that make
-up this section.
-START and END define the location of data described by the tag."
- (append (semantic-tag name 'section :members members)
- (list start end)))
-
-(defsubst semantic-texi-new-def-tag (name start end)
- "Create a semantic tag of class def.
-NAME is the name of this definition.
-START and END define the location of data described by the tag."
- (append (semantic-tag name 'def)
- (list start end)))
-
-(defun semantic-texi-set-endpoint (metataglist pnt)
- "Set the end point of the first section tag in METATAGLIST to PNT.
-METATAGLIST is a list of tags in the intermediate tag format used by the
-texinfo parser. PNT is the new point to set."
- (let ((metatag nil))
- (while (and metataglist
- (not (eq (semantic-tag-class (car metataglist)) 'section)))
- (setq metataglist (cdr metataglist)))
- (setq metatag (car metataglist))
- (when metatag
- (setcar (nthcdr (1- (length metatag)) metatag) pnt)
- metatag)))
-
-(defun semantic-texi-recursive-combobulate-list (sectionlist level)
- "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL.
-Return the rearranged new list, with all remaining tags from
-SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a
-tag with greater section value than LEVEL is found."
- (let ((newl nil)
- (oldl sectionlist)
- tag
- )
- (save-excursion
- (catch 'level-jump
- (while oldl
- (goto-char (car oldl))
- (if (looking-at "@\\(\\w+\\)")
- (let* ((word (match-string 1))
- (levelmatch (assoc word texinfo-section-list))
- text begin tmp
- )
- ;; Set begin to the right location
- (setq begin (point))
- ;; Get out of here if there if we made it that far.
- (if (and levelmatch (<= (car (cdr levelmatch)) level))
- (progn
- (when newl
- (semantic-texi-set-endpoint newl begin))
- (throw 'level-jump t)))
- ;; Recombobulate
- (if levelmatch
- (let ((end (match-end 1)))
- ;; Levels sometimes have a @node just in front.
- ;; That node statement should be included in the space
- ;; for this entry.
- (save-excursion
- (skip-chars-backward "\n \t")
- (beginning-of-line)
- (when (looking-at "@node\\>")
- (setq begin (point))))
- ;; When there is a match, the descriptive text
- ;; consists of the rest of the line.
- (goto-char end)
- (skip-chars-forward " \t")
- (setq text (buffer-substring-no-properties
- (point)
- (progn (end-of-line) (point))))
- ;; Next, recurse into the body to find the end.
- (setq tmp (semantic-texi-recursive-combobulate-list
- (cdr oldl) (car (cdr levelmatch))))
- ;; Build a tag
- (setq tag (semantic-texi-new-section-tag
- text (car tmp) begin (point)))
- ;; Before appending the newtag, update the previous tag
- ;; if it is a section tag.
- (when newl
- (semantic-texi-set-endpoint newl begin))
- ;; Append new tag to our master list.
- (setq newl (cons tag newl))
- ;; continue
- (setq oldl (cdr tmp))
- )
- ;; No match means we have a def*, so get the name from
- ;; it based on the type of thingy we found.
- (setq levelmatch (assoc word semantic-texi-name-field-list)
- tmp (or (cdr levelmatch) 1))
- (forward-sexp tmp)
- (skip-chars-forward " \t")
- (setq text (buffer-substring-no-properties
- (point)
- (progn (forward-sexp 1) (point))))
- ;; Seek the end of this definition
- (goto-char begin)
- (semantic-texi-forward-deffn)
- (setq tag (semantic-texi-new-def-tag text begin (point))
- newl (cons tag newl))
- ;; continue
- (setq oldl (cdr oldl)))
- )
- (error "Problem finding section in semantic/texi parser"))
- ;; (setq oldl (cdr oldl))
- )
- ;; When oldl runs out, force a new endpoint as point-max
- (when (not oldl)
- (semantic-texi-set-endpoint newl (point-max)))
- ))
- (cons (nreverse newl) oldl)))
-
-(defun semantic-texi-forward-deffn ()
- "Move forward over one deffn type definition.
-The cursor should be on the @ sign."
- (when (looking-at "@\\(\\w+\\)")
- (let* ((type (match-string 1))
- (seek (concat "^@end\\s-+" (regexp-quote type))))
- (re-search-forward seek nil t))))
-
-(define-mode-local-override semantic-tag-components
- texinfo-mode (tag)
- "Return components belonging to TAG."
- (semantic-tag-get-attribute tag :members))
-
-\f
-;;; Overrides: Context Parsing
-;;
-;; How to treat texi as a language?
-;;
-(defvar semantic-texi-environment-regexp
- (if (string-match texinfo-environment-regexp "@menu")
- ;; Make sure our Emacs has menus in it.
- texinfo-environment-regexp
- ;; If no menus, then merge in the menu concept.
- (when (string-match "cartouche" texinfo-environment-regexp)
- (concat (substring texinfo-environment-regexp
- 0 (match-beginning 0))
- "menu\\|"
- (substring texinfo-environment-regexp
- (match-beginning 0)))))
- "Regular expression for matching texinfo environments.
-uses `texinfo-environment-regexp', but makes sure that it
-can handle the @menu environment.")
-
-(define-mode-local-override semantic-up-context texinfo-mode ()
- "Handle texinfo constructs which do not use parenthetical nesting."
- (let ((done nil))
- (save-excursion
- (let ((parenthetical (semantic-up-context-default))
- )
- (when (not parenthetical)
- ;; We are in parentheses. Are they the types of parens
- ;; belonging to a texinfo construct?
- (forward-word-strictly -1)
- (when (looking-at "@\\w+{")
- (setq done (point))))))
- ;; If we are not in a parenthetical node, then find a block instead.
- ;; Use the texinfo support to find block start/end constructs.
- (save-excursion
- (while (and (not done)
- (re-search-backward semantic-texi-environment-regexp nil t))
- ;; For any hit, if we find an @end foo, then jump to the
- ;; matching @foo. If it is not an end, then we win!
- (if (not (looking-at "@end\\s-+\\(\\w+\\)"))
- (setq done (point))
- ;; Skip over this block
- (let ((env (match-string 1)))
- (re-search-backward (concat "@" env))))
- ))
- ;; All over, post what we find.
- (if done
- ;; We found something, so use it.
- (progn (goto-char done)
- nil)
- t)))
-
-(define-mode-local-override semantic-beginning-of-context texinfo-mode (&optional point)
- "Move to the beginning of the context surrounding POINT."
- (if (semantic-up-context point)
- ;; If we can't go up, we can't do this either.
- t
- ;; We moved, so now we need to skip into whatever this thing is.
- (forward-word-strictly 1) ;; skip the command
- (if (looking-at "\\s-*{")
- ;; In a short command. Go in.
- (down-list 1)
- ;; An environment. Go to the next line.
- (end-of-line)
- (forward-char 1))
- nil))
-
-(define-mode-local-override semantic-ctxt-current-class-list
- texinfo-mode (&optional _point)
- "Determine the class of tags that can be used at POINT.
-For texinfo, there two possibilities returned.
-1) `function' - for a call to a texinfo function
-2) `word' - indicates an English word.
-It would be nice to know function arguments too, but not today."
- (let ((sym (semantic-ctxt-current-symbol)))
- (if (and sym (= (aref (car sym) 0) ?@))
- '(function)
- '(word))))
-
-\f
-;;; Overrides : Formatting
-;;
-;; Various override to better format texi tags.
-;;
-
-(define-mode-local-override semantic-format-tag-abbreviate
- texinfo-mode (tag &optional parent color)
- "Texinfo tags abbreviation."
- (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
- texinfo-mode (tag &optional parent color)
- "Texinfo tags abbreviation."
- (semantic-format-tag-abbreviate tag parent color))
-
-\f
-;;; Texi Unique Features
-;;
-(defun semantic-tag-texi-section-text-bounds (tag)
- "Get the bounds to the text of TAG.
-The text bounds is the text belonging to this node excluding
-the text of any child nodes, but including any defuns."
- (let ((memb (semantic-tag-components tag)))
- ;; Members.. if one is a section, check it out.
- (while (and memb (not (semantic-tag-of-class-p (car memb) 'section)))
- (setq memb (cdr memb)))
- ;; No members? ... then a simple problem!
- (if (not memb)
- (semantic-tag-bounds tag)
- ;; Our end is their beginning...
- (list (semantic-tag-start tag) (semantic-tag-start (car memb))))))
-
-(defun semantic-texi-current-environment (&optional point)
- "Return as a string the type of the current environment.
-Optional argument POINT is where to look for the environment."
- (save-excursion
- (when point (goto-char (point)))
- (while (and (or (not (looking-at semantic-texi-environment-regexp))
- (looking-at "@end"))
- (not (semantic-up-context)))
- )
- (when (looking-at semantic-texi-environment-regexp)
- (match-string 1))))
-
-\f
-;;; Analyzer
-;;
-(eval-when-compile
- (require 'semantic/analyze))
-
-(declare-function semantic-analyze-context "semantic/analyze")
-
-(define-mode-local-override semantic-analyze-current-context
- texinfo-mode (_point)
- "Analysis context makes no sense for texinfo. Return nil."
- (let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point)))
- (prefix (car prefixandbounds))
- (bounds (nth 2 prefixandbounds))
- (prefixclass (semantic-ctxt-current-class-list))
- )
- (when prefix
- (require 'semantic/analyze)
- (semantic-analyze-context
- :buffer (current-buffer)
- :scope nil
- :bounds bounds
- :prefix prefix
- :prefixtypes nil
- :prefixclass prefixclass)
- )
- ))
-
-(defvar semantic-texi-command-completion-list
- (append (mapcar (lambda (a) (car a)) texinfo-section-list)
- texinfo-environments
- ;; Is there a better list somewhere? Here are few
- ;; of the top of my head.
- "anchor" "asis"
- "bullet"
- "code" "copyright"
- "defun" "deffn" "defoption" "defvar" "dfn"
- "emph" "end"
- "ifinfo" "iftex" "inforef" "item" "itemx"
- "kdb"
- "node"
- "ref"
- "set" "setfilename" "settitle"
- "value" "var"
- "xref"
- )
- "List of commands that we might bother completing.")
-
-(define-mode-local-override semantic-analyze-possible-completions
- texinfo-mode (context &rest _flags)
- "List smart completions at point.
-Since texinfo is not a programming language the default version is not
-useful. Instead, look at the current symbol. If it is a command
-do primitive texinfo built ins. If not, use ispell to lookup words
-that start with that symbol."
- (let ((prefix (car (oref context prefix)))
- )
- (cond ((member 'function (oref context prefixclass))
- ;; Do completion for texinfo commands
- (let* ((cmd (substring prefix 1))
- (lst (all-completions
- cmd semantic-texi-command-completion-list)))
- (mapcar (lambda (f) (semantic-tag (concat "@" f) 'function))
- lst))
- )
- ((member 'word (oref context prefixclass))
- ;; Do completion for words via ispell.
- (require 'ispell)
- (let ((word-list (ispell-lookup-words prefix)))
- (mapcar (lambda (f) (semantic-tag f 'word)) word-list))
- )
- (t nil))
- ))
-
-\f
-;;; Parser Setup
-;;
-;; In semantic/imenu.el, not part of Emacs.
-(defvar semantic-imenu-expandable-tag-classes)
-(defvar semantic-imenu-bucketize-file)
-(defvar semantic-imenu-bucketize-type-members)
-
-;;;###autoload
-(defun semantic-default-texi-setup ()
- "Set up a buffer for parsing of Texinfo files."
- ;; This will use our parser.
- (setq semantic-parser-name "TEXI"
- ;; Setup a dummy parser table to enable parsing!
- semantic--parse-table t
- imenu-create-index-function #'semantic-create-imenu-index
- semantic-command-separation-character "@"
- semantic-type-relation-separator-character '(":")
- semantic-symbol->name-assoc-list '((section . "Section")
- (def . "Definition")
- )
- semantic-imenu-expandable-tag-classes '(section)
- semantic-imenu-bucketize-file nil
- semantic-imenu-bucketize-type-members nil
- senator-step-at-start-end-tag-classes '(section)
- semantic-stickyfunc-sticky-classes '(section)
- )
- ;; (local-set-key [(f9)] 'semantic-texi-update-doc-from-texi)
- )
-
-(add-hook 'texinfo-mode-hook #'semantic-default-texi-setup)
-
-\f
-;;; Special features of Texinfo tag streams
-;;
-;; This section provides specialized access into texinfo files.
-;; Because texinfo files often directly refer to functions and programs
-;; it is useful to access the texinfo file from the C code for document
-;; maintenance.
-(defun semantic-texi-associated-files (&optional buffer)
- "Find texinfo files associated with BUFFER."
- (save-excursion
- (if buffer (set-buffer buffer))
- (cond ((and (fboundp 'ede-documentation-files)
- ede-minor-mode (ede-current-project))
- ;; When EDE is active, ask it.
- (ede-documentation-files)
- )
- ((and (featurep 'semantic/db) (semanticdb-minor-mode-p))
- ;; See what texinfo files we have loaded in the database
- (let ((tabs (semanticdb-get-database-tables
- semanticdb-current-database))
- (r nil))
- (while tabs
- (if (eq (oref (car tabs) major-mode) 'texinfo-mode)
- (setq r (cons (oref (car tabs) file) r)))
- (setq tabs (cdr tabs)))
- r))
- (t
- (directory-files default-directory nil "\\.texi\\'"))
- )))
-
-;; Turns out this might not be useful.
-;; Delete later if that is true.
-(defun semantic-texi-find-documentation (name &optional _type)
- "Find the function or variable NAME of TYPE in the texinfo source.
-NAME is a string representing some functional symbol.
-TYPE is a string, such as \"variable\" or \"Command\" used to find
-the correct definition in case NAME qualifies as several things.
-When this function exists, POINT is at the definition.
-If the doc was not found, an error is thrown.
-Note: TYPE not yet implemented."
- (let ((f (semantic-texi-associated-files))
- stream match)
- (while (and f (not match))
- (unless stream
- (with-current-buffer (find-file-noselect (car f))
- (setq stream (semantic-fetch-tags))))
- (setq match (semantic-find-first-tag-by-name name stream))
- (when match
- (set-buffer (semantic-tag-buffer match))
- (goto-char (semantic-tag-start match)))
- (setq f (cdr f)))))
-
-;; (defun semantic-texi-update-doc-from-texi (&optional tag)
-;; "Update the documentation in the texinfo deffn class tag TAG.
-;; The current buffer must be a texinfo file containing TAG.
-;; If TAG is nil, determine a tag based on the current position."
-;; (interactive)
-;; (unless (or (featurep 'semantic/db)
-;; (require 'semantic/db-mode)
-;; (semanticdb-minor-mode-p))
-;; (error "Texinfo updating only works when `semanticdb' is being used"))
-;; (semantic-fetch-tags)
-;; (unless tag
-;; (beginning-of-line)
-;; (setq tag (semantic-current-tag)))
-;; (unless (semantic-tag-of-class-p tag 'def)
-;; (error "Only deffns (or defun or defvar) can be updated"))
-;; (let* ((name (semantic-tag-name tag))
-;; (tags (semanticdb-strip-find-results
-;; (semanticdb-with-match-any-mode
-;; (semanticdb-brute-deep-find-tags-by-name name))
-;; 'name))
-;; (docstring nil)
-;; (docstringproto nil)
-;; (docstringvar nil)
-;; (doctag nil)
-;; (doctagproto nil)
-;; (doctagvar nil)
-;; )
-;; (save-excursion
-;; (while (and tags (not docstring))
-;; (let ((sourcetag (car tags)))
-;; ;; There could be more than one! Come up with a better
-;; ;; solution someday.
-;; (when (semantic-tag-buffer sourcetag)
-;; (set-buffer (semantic-tag-buffer sourcetag))
-;; (unless (eq major-mode 'texinfo-mode)
-;; (cond ((semantic-tag-get-attribute sourcetag :prototype-flag)
-;; ;; If we found a match with doc that is a prototype, then store
-;; ;; that, but don't exit till we find the real deal.
-;; (setq docstringproto (semantic-documentation-for-tag sourcetag)
-;; doctagproto sourcetag))
-;; ((eq (semantic-tag-class sourcetag) 'variable)
-;; (setq docstringvar (semantic-documentation-for-tag sourcetag)
-;; doctagvar sourcetag))
-;; ((semantic-tag-get-attribute sourcetag :override-function-flag)
-;; nil)
-;; (t
-;; (setq docstring (semantic-documentation-for-tag sourcetag))))
-;; (setq doctag (if docstring sourcetag nil))))
-;; (setq tags (cdr tags)))))
-;; ;; If we found a prototype of the function that has some doc, but not the
-;; ;; actual function, let's make due with that.
-;; (if (not docstring)
-;; (cond ((stringp docstringvar)
-;; (setq docstring docstringvar
-;; doctag doctagvar))
-;; ((stringp docstringproto)
-;; (setq docstring docstringproto
-;; doctag doctagproto))))
-;; ;; Test for doc string
-;; (unless docstring
-;; (error "Could not find documentation for %s" (semantic-tag-name tag)))
-;;
-;; (require 'srecode)
-;; (require 'srecode/texi)
-;;
-;; ;; If we have a string, do the replacement.
-;; (delete-region (semantic-tag-start tag)
-;; (semantic-tag-end tag))
-;; ;; Use useful functions from the document library.
-;; (srecode-texi-insert-tag-as-doc doctag)
-;; ;(semantic-insert-foreign-tag doctag)
-;; ))
-
-;; (defun semantic-texi-update-doc-from-source (&optional tag)
-;; "Update the documentation for the source TAG.
-;; The current buffer must be a non-texinfo source file containing TAG.
-;; If TAG is nil, determine the tag based on the current position.
-;; The current buffer must include TAG."
-;; (interactive)
-;; (when (eq major-mode 'texinfo-mode)
-;; (error "Not a source file"))
-;; (semantic-fetch-tags)
-;; (unless tag
-;; (setq tag (semantic-current-tag)))
-;; (unless (semantic-documentation-for-tag tag)
-;; (error "Cannot find interesting documentation to use for %s"
-;; (semantic-tag-name tag)))
-;; (let* ((name (semantic-tag-name tag))
-;; (texi (semantic-texi-associated-files))
-;; (doctag nil)
-;; (docbuff nil))
-;; (while (and texi (not doctag))
-;; (set-buffer (find-file-noselect (car texi)))
-;; (setq doctag (car (semantic-deep-find-tags-by-name
-;; name (semantic-fetch-tags)))
-;; docbuff (if doctag (current-buffer) nil))
-;; (setq texi (cdr texi)))
-;; (unless doctag
-;; (error "Tag %s is not yet documented. Use the `document' command"
-;; name))
-;; ;; Ok, we should have everything we need. Do the deed.
-;; (if (get-buffer-window docbuff)
-;; (set-buffer docbuff)
-;; (switch-to-buffer docbuff))
-;; (goto-char (semantic-tag-start doctag))
-;; (delete-region (semantic-tag-start doctag)
-;; (semantic-tag-end doctag))
-;; ;; Use useful functions from the document library.
-;; (require 'document)
-;; (document-insert-texinfo tag (semantic-tag-buffer tag))
-;; ))
-
-;; (defun semantic-texi-update-doc (&optional tag)
-;; "Update the documentation for TAG.
-;; If the current buffer is a texinfo file, then find the source doc, and
-;; update it. If the current buffer is a source file, then get the
-;; documentation for this item, find the existing doc in the associated
-;; manual, and update that."
-;; (interactive)
-;; (cond ;;((eq major-mode 'texinfo-mode)
-;; ;; (semantic-texi-update-doc-from-texi tag))
-;; (t
-;; (semantic-texi-update-doc-from-source tag))))
-
-(defun semantic-texi-goto-source (&optional tag)
- "Jump to the source for the definition in the texinfo file TAG.
-If TAG is nil, it is derived from the deffn under POINT."
- (interactive)
- (unless (or (featurep 'semantic/db) (semanticdb-minor-mode-p))
- (error "Texinfo updating only works when `semanticdb' is being used"))
- (semantic-fetch-tags)
- (unless tag
- (beginning-of-line)
- (setq tag (semantic-current-tag)))
- (unless (semantic-tag-of-class-p tag 'def)
- (error "Only deffns (or defun or defvar) can be updated"))
- (let* ((name (semantic-tag-name tag))
- (tags (semanticdb-fast-strip-find-results
- (semanticdb-with-match-any-mode
- (semanticdb-brute-deep-find-tags-by-name name nil 'name))
- ))
-
- (done nil)
- )
- (save-excursion
- (while (and tags (not done))
- (set-buffer (semantic-tag-buffer (car tags)))
- (unless (eq major-mode 'texinfo-mode)
- (switch-to-buffer (semantic-tag-buffer (car tags)))
- (goto-char (semantic-tag-start (car tags)))
- (setq done t))
- (setq tags (cdr tags)))
- (if (not done)
- (error "Could not find tag for %s" (semantic-tag-name tag)))
- )))
-
-(provide 'semantic/texi)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/texi"
-;; End:
-
-;;; semantic/texi.el ends here
+++ /dev/null
-;;; semantic/util-modes.el --- Semantic minor modes -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2000-2005, 2007-2024 Free Software Foundation, Inc.
-
-;; Authors: Eric M. Ludlam <zappo@gnu.org>
-;; David Ponce <david@dponce.com>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic utility minor modes.
-;;
-
-;;; Code:
-
-;; FIXME: compiling util-modes.el seems to require loading util-modes.el,
-;; so if the previous compilation generated a file that fails to load,
-;; recompiling fails to fix the problem.
-(require 'semantic)
-
-;;; Group for all semantic enhancing modes
-(defgroup semantic-modes nil
- "Minor modes associated with the Semantic architecture."
- :group 'semantic)
-
-;;;;
-;;;; Semantic minor modes stuff
-;;;;
-(defcustom semantic-update-mode-line t
- "If non-nil, show enabled minor modes in the mode line.
-Only minor modes that are not turned on globally are shown in the mode
-line."
- :group 'semantic
- :type 'boolean
- :require 'semantic/util-modes
- :initialize #'custom-initialize-default
- :set (lambda (sym val)
- (set-default sym val)
- ;; Update status of all Semantic enabled buffers
- (semantic-mode-line-update)))
-
-(defcustom semantic-mode-line-prefix
- (propertize "S" 'face 'bold)
- "Prefix added to minor mode indicators in the mode line."
- :group 'semantic
- :type 'string
- :require 'semantic/util-modes
- :initialize #'custom-initialize-default)
-
-(defvar semantic-minor-modes-format nil
- "Mode line format showing Semantic minor modes which are locally enabled.
-It is displayed in the mode line.")
-(put 'semantic-minor-modes-format 'risky-local-variable t)
-
-(defvar semantic-minor-mode-alist nil
- "Alist saying how to show Semantic minor modes in the mode line.
-Like variable `minor-mode-alist'.")
-
-(defun semantic-mode-line-update ()
- "Update mode line format of Semantic minor modes.
-Only minor modes that are locally enabled are shown in the mode line."
- (setq semantic-minor-modes-format nil)
- (dolist (x semantic-minor-mode-alist)
- (setq minor-mode-alist (delq (assq (car x) minor-mode-alist)
- minor-mode-alist)))
- (when semantic-update-mode-line
- (let ((locals '()))
- ;; Select the minor modes that aren't enabled globally and who
- ;; have a non-empty "name".
- (dolist (x semantic-minor-mode-alist)
- (unless (or (memq (car x) semantic-init-hook)
- (not (string-match "^[ ]*\\(.+\\)" (cadr x))))
- (push (list (car x) (concat "/" (match-string 1 (cadr x)))) locals)))
- ;; Then build the format spec.
- (when locals
- (let ((prefix (if (string-match "^[ ]*\\(.+\\)"
- semantic-mode-line-prefix)
- (match-string 1 semantic-mode-line-prefix)
- "S")))
- (setq semantic-minor-modes-format
- `((:eval (if (or ,@(mapcar #'car locals))
- ,(concat " " prefix)))))
- ;; It would be easier to just put `locals' inside
- ;; semantic-minor-modes-format, but then things like
- ;; mode-line-minor-mode-help can't find the right major mode
- ;; any more. So instead, we carefully put the minor modes
- ;; in minor-mode-alist.
- (let* ((elem (or (assq 'semantic-minor-modes-format
- minor-mode-alist)
- ;; FIXME: This entry is meaningless for
- ;; mode-line-minor-mode-help.
- '(semantic-minor-modes-format
- semantic-minor-modes-format)))
- (tail (or (memq elem minor-mode-alist)
- (setq minor-mode-alist
- (cons elem minor-mode-alist)))))
- (setcdr tail (nconc locals (cdr tail)))))))))
-
-(defun semantic-desktop-ignore-this-minor-mode (_buffer)
- "Installed as a minor-mode initializer for Desktop mode.
-BUFFER is the buffer to not initialize a Semantic minor mode in."
- nil)
-
-(defun semantic-add-minor-mode (toggle name)
- "Register a new Semantic minor mode.
-TOGGLE is a symbol which is the name of a buffer-local variable that
-is toggled on or off to say whether the minor mode is active or not.
-It is also an interactive function to toggle the mode.
-
-NAME specifies what will appear in the mode line when the minor mode
-is active. NAME should be either a string starting with a space, or a
-symbol whose value is such a string."
- ;; Record how to display this minor mode in the mode line
- (let ((mm (assq toggle semantic-minor-mode-alist)))
- (if mm
- (setcdr mm (list name))
- (setq semantic-minor-mode-alist (cons (list toggle name)
- semantic-minor-mode-alist))))
- (semantic-mode-line-update)
-
- ;; Semantic minor modes don't work with Desktop restore.
- ;; This line will disable this minor mode from being restored
- ;; by Desktop.
- (when (boundp 'desktop-minor-mode-handlers)
- (add-to-list 'desktop-minor-mode-handlers
- (cons toggle 'semantic-desktop-ignore-this-minor-mode))))
-
-(defun semantic-toggle-minor-mode-globally (mode &optional arg)
- "Toggle minor mode MODE in every Semantic enabled buffer.
-Return non-nil if MODE is turned on in every Semantic enabled buffer.
-If ARG is positive, enable, if it is negative, disable.
-MODE must be a valid minor mode defined in `minor-mode-alist' and must be
-too an interactive function used to toggle the mode."
- ;; FIXME: All callers should pass a -1 or +1 argument.
- (or (and (fboundp mode) (or (assq mode minor-mode-alist) ;Needed?
- (assq mode semantic-minor-mode-alist)))
- (error "Semantic minor mode %s not found" mode))
- ;; Add or remove the MODE toggle function from `semantic-init-hook'.
- (cond
- ;; Turn off if ARG < 0
- ((< arg 0) (remove-hook 'semantic-init-hook mode))
- ;; Turn on if ARG > 0
- ((> arg 0) (add-hook 'semantic-init-hook mode))
- ;; Otherwise just check MODE state
- (t
- (error "semantic-toggle-minor-mode-globally: arg should be -1 or 1")))
- ;; Update the minor mode format.
- (semantic-mode-line-update)
- ;; Then turn MODE on or off in every Semantic enabled buffer.
- (semantic-map-buffers (lambda () (funcall mode arg))))
-\f
-;;;;
-;;;; Minor mode to highlight areas that a user edits.
-;;;;
-
-;;;###autoload
-(define-minor-mode global-semantic-highlight-edits-mode
- "Toggle global use of option `semantic-highlight-edits-mode'."
- :global t :group 'semantic :group 'semantic-modes
- (semantic-toggle-minor-mode-globally
- 'semantic-highlight-edits-mode
- (if global-semantic-highlight-edits-mode 1 -1)))
-
-(defcustom semantic-highlight-edits-mode-hook nil
- "Hook run at the end of function `semantic-highlight-edits-mode'."
- :group 'semantic
- :type 'hook)
-
-(defface semantic-highlight-edits-face
- '((((class color) (background dark))
- ;; Put this back to something closer to black later.
- (:background "gray20"))
- (((class color) (background light))
- (:background "gray90")))
- "Face used to show dirty tokens in `semantic-highlight-edits-mode'."
- :group 'semantic-faces)
-
-(defun semantic-highlight-edits-new-change-hook-fcn (overlay)
- "Function set into `semantic-edits-new-change-hook'.
-Argument OVERLAY is the overlay created to mark the change.
-This function will set the face property on this overlay."
- (overlay-put overlay 'face 'semantic-highlight-edits-face))
-
-(defvar-keymap semantic-highlight-edits-mode-map
- :doc "Keymap for highlight-edits minor mode.")
-
-;;;###autoload
-(define-minor-mode semantic-highlight-edits-mode
- "Minor mode for highlighting changes made in a buffer.
-Changes are tracked by semantic so that the incremental parser can work
-properly.
-This mode will highlight those changes as they are made, and clear them
-when the incremental parser accounts for those edits.
-
-The minor mode can be turned on only if semantic feature is
-available and the current buffer was set up for parsing. Return
-non-nil if the minor mode is enabled."
- :keymap semantic-highlight-edits-mode-map
- (if semantic-highlight-edits-mode
- (if (not (and (featurep 'semantic) (semantic-active-p)))
- (progn
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-highlight-edits-mode nil)
- (error "Buffer %s was not set up for parsing"
- (buffer-name)))
- (add-hook 'semantic-edits-new-change-functions
- #'semantic-highlight-edits-new-change-hook-fcn nil t))
- ;; Remove hooks
- (remove-hook 'semantic-edits-new-change-functions
- #'semantic-highlight-edits-new-change-hook-fcn t)))
-
-(semantic-add-minor-mode 'semantic-highlight-edits-mode
- "e")
-\f
-;;;;
-;;;; Minor mode to show unmatched-syntax elements
-;;;;
-
-;;;###autoload
-(define-minor-mode global-semantic-show-unmatched-syntax-mode
- "Toggle global use of option `semantic-show-unmatched-syntax-mode'."
- :global t :group 'semantic :group 'semantic-modes
- ;; Not needed because it's autoloaded instead.
- ;; :require 'semantic/util-modes
- (semantic-toggle-minor-mode-globally
- 'semantic-show-unmatched-syntax-mode
- (if global-semantic-show-unmatched-syntax-mode 1 -1)))
-
-(defcustom semantic-show-unmatched-syntax-mode-hook nil
- "Hook run at the end of function `semantic-show-unmatched-syntax-mode'."
- :group 'semantic
- :type 'hook)
-
-(defface semantic-unmatched-syntax-face
- '((((class color) (background dark))
- (:underline "red"))
- (((class color) (background light))
- (:underline "red")))
- "Face used to show unmatched syntax in.
-The face is used in `semantic-show-unmatched-syntax-mode'."
- :group 'semantic-faces)
-
-(defsubst semantic-unmatched-syntax-overlay-p (overlay)
- "Return non-nil if OVERLAY is an unmatched syntax one."
- (eq (overlay-get overlay 'semantic) 'unmatched))
-
-(defun semantic-showing-unmatched-syntax-p ()
- "Return non-nil if an unmatched syntax overlay was found in buffer."
- (let ((ol (overlays-in (point-min) (point-max)))
- found)
- (while (and ol (not found))
- (setq found (semantic-unmatched-syntax-overlay-p (car ol))
- ol (cdr ol)))
- found))
-
-(defun semantic-show-unmatched-lex-tokens-fetch ()
- "Fetch a list of unmatched lexical tokens from the current buffer.
-Uses the overlays which have accurate bounds, and rebuilds what was
-originally passed in."
- (let ((ol (overlays-in (point-min) (point-max)))
- (ustc nil))
- (while ol
- (if (semantic-unmatched-syntax-overlay-p (car ol))
- (setq ustc (cons (cons 'thing
- (cons (overlay-start (car ol))
- (overlay-end (car ol))))
- ustc)))
- (setq ol (cdr ol)))
- (nreverse ustc))
- )
-
-(defun semantic-clean-unmatched-syntax-in-region (beg end)
- "Remove all unmatched syntax overlays between BEG and END."
- (let ((ol (overlays-in beg end)))
- (while ol
- (if (semantic-unmatched-syntax-overlay-p (car ol))
- (delete-overlay (car ol)))
- (setq ol (cdr ol)))))
-
-(defsubst semantic-clean-unmatched-syntax-in-buffer ()
- "Remove all unmatched syntax overlays found in current buffer."
- (semantic-clean-unmatched-syntax-in-region
- (point-min) (point-max)))
-
-(defsubst semantic-clean-token-of-unmatched-syntax (token)
- "Clean the area covered by TOKEN of unmatched syntax markers."
- (semantic-clean-unmatched-syntax-in-region
- (semantic-tag-start token) (semantic-tag-end token)))
-
-(defun semantic-show-unmatched-syntax (syntax)
- "Function set into `semantic-unmatched-syntax-hook'.
-This will highlight elements in SYNTAX as unmatched syntax."
- ;; This is called when `semantic-show-unmatched-syntax-mode' is
- ;; enabled. Highlight the unmatched syntax, and then add a semantic
- ;; property to that overlay so we can add it to the official list of
- ;; semantic supported overlays. This gets it cleaned up for errors,
- ;; buffer cleaning, and the like.
- (semantic-clean-unmatched-syntax-in-buffer) ;Clear previous highlighting
- (if syntax
- (let (o)
- (while syntax
- (setq o (make-overlay (semantic-lex-token-start (car syntax))
- (semantic-lex-token-end (car syntax))))
- (overlay-put o 'semantic 'unmatched)
- (overlay-put o 'face 'semantic-unmatched-syntax-face)
- (setq syntax (cdr syntax))))
- ))
-
-(defun semantic-next-unmatched-syntax (point &optional bound)
- "Find the next overlay for unmatched syntax after POINT.
-Do not search past BOUND if non-nil."
- (save-excursion
- (goto-char point)
- (let ((os point) (ol nil))
- (while (and os (< os (or bound (point-max))) (not ol))
- (setq os (next-overlay-change os))
- (when os
- ;; Get overlays at position
- (setq ol (overlays-at os))
- ;; find the overlay that belongs to semantic
- ;; and starts at the found position.
- (while (and ol (listp ol))
- (and (semantic-unmatched-syntax-overlay-p (car ol))
- (setq ol (car ol)))
- (if (listp ol)
- (setq ol (cdr ol))))))
- ol)))
-
-(defvar-keymap semantic-show-unmatched-syntax-mode-map
- :doc "Keymap for command `semantic-show-unmatched-syntax-mode'."
- "C-c , `" #'semantic-show-unmatched-syntax-next)
-
-;;;###autoload
-(define-minor-mode semantic-show-unmatched-syntax-mode
- "Minor mode to highlight unmatched lexical syntax tokens.
-When a parser executes, some elements in the buffer may not match any
-parser rules. These text characters are considered unmatched syntax.
-Often time, the display of unmatched syntax can expose coding
-problems before the compiler is run.
-
-The minor mode can be turned on only if semantic feature is
-available and the current buffer was set up for parsing. Return
-non-nil if the minor mode is enabled.
-
-\\{semantic-show-unmatched-syntax-mode-map}"
- :keymap semantic-show-unmatched-syntax-mode-map
- (if semantic-show-unmatched-syntax-mode
- (if (not (and (featurep 'semantic) (semantic-active-p)))
- (progn
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-show-unmatched-syntax-mode nil)
- (error "Buffer %s was not set up for parsing"
- (buffer-name)))
- ;; Add hooks
- (add-hook 'semantic-unmatched-syntax-hook
- #'semantic-show-unmatched-syntax nil t)
- (add-hook 'semantic-pre-clean-token-hooks
- #'semantic-clean-token-of-unmatched-syntax nil t)
- ;; Show unmatched syntax elements
- (if (not (semantic--umatched-syntax-needs-refresh-p))
- (semantic-show-unmatched-syntax
- (semantic-unmatched-syntax-tokens))))
- ;; Remove hooks
- (remove-hook 'semantic-unmatched-syntax-hook
- #'semantic-show-unmatched-syntax t)
- (remove-hook 'semantic-pre-clean-token-hooks
- #'semantic-clean-token-of-unmatched-syntax t)
- ;; Cleanup unmatched-syntax highlighting
- (semantic-clean-unmatched-syntax-in-buffer)))
-
-(semantic-add-minor-mode 'semantic-show-unmatched-syntax-mode
- "u")
-
-(defun semantic-show-unmatched-syntax-next ()
- "Move forward to the next occurrence of unmatched syntax."
- (interactive)
- (let ((o (semantic-next-unmatched-syntax (point))))
- (if o
- (goto-char (overlay-start o)))))
-
-\f
-;;;;
-;;;; Minor mode to display the parser state in the modeline.
-;;;;
-
-;;;###autoload
-(define-minor-mode global-semantic-show-parser-state-mode
- "Toggle global use of option `semantic-show-parser-state-mode'."
- :global t :group 'semantic
- ;; Not needed because it's autoloaded instead.
- ;; :require 'semantic/util-modes
- (semantic-toggle-minor-mode-globally
- 'semantic-show-parser-state-mode
- (if global-semantic-show-parser-state-mode 1 -1)))
-
-(defcustom semantic-show-parser-state-mode-hook nil
- "Hook run at the end of function `semantic-show-parser-state-mode'."
- :group 'semantic
- :type 'hook)
-
-(defvar-keymap semantic-show-parser-state-mode-map
- :doc "Keymap for show-parser-state minor mode.")
-
-;;;###autoload
-(define-minor-mode semantic-show-parser-state-mode
- "Minor mode for displaying parser cache state in the modeline.
-The cache can be in one of three states. They are
-Up to date, Partial reparse needed, and Full reparse needed.
-The state is indicated in the modeline with the following characters:
- `-' -> The cache is up to date.
- `!' -> The cache requires a full update.
- `~' -> The cache needs to be incrementally parsed.
- `%' -> The cache is not currently parsable.
- `@' -> Auto-parse in progress (not set here.)
-
-The minor mode can be turned on only if semantic feature is
-available and the current buffer was set up for parsing. Return
-non-nil if the minor mode is enabled."
- :keymap semantic-show-parser-state-mode-map
- (if semantic-show-parser-state-mode
- (if (not (and (featurep 'semantic) (semantic-active-p)))
- (progn
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-show-parser-state-mode nil)
- (error "Buffer %s was not set up for parsing"
- (buffer-name)))
- ;; Set up mode line
-
- (when (not
- (memq 'semantic-show-parser-state-string mode-line-modified))
- (setq mode-line-modified
- (append mode-line-modified
- '(semantic-show-parser-state-string))))
- ;; Add hooks
- (add-hook 'semantic-edits-new-change-functions
- #'semantic-show-parser-state-marker nil t)
- (add-hook 'semantic-edits-incremental-reparse-failed-hook
- #'semantic-show-parser-state-marker nil t)
- (add-hook 'semantic-after-partial-cache-change-hook
- #'semantic-show-parser-state-marker nil t)
- (add-hook 'semantic-after-toplevel-cache-change-hook
- #'semantic-show-parser-state-marker nil t)
- (semantic-show-parser-state-marker)
-
- (add-hook 'semantic-before-auto-parse-hooks
- #'semantic-show-parser-state-auto-marker nil t)
- (add-hook 'semantic-after-auto-parse-hooks
- #'semantic-show-parser-state-marker nil t)
-
- (add-hook 'semantic-before-idle-scheduler-reparse-hook
- #'semantic-show-parser-state-auto-marker nil t)
- (add-hook 'semantic-after-idle-scheduler-reparse-hook
- #'semantic-show-parser-state-marker nil t))
- ;; Remove parts of mode line
- (setq mode-line-modified
- (delq 'semantic-show-parser-state-string mode-line-modified))
- ;; Remove hooks
- (remove-hook 'semantic-edits-new-change-functions
- #'semantic-show-parser-state-marker t)
- (remove-hook 'semantic-edits-incremental-reparse-failed-hook
- #'semantic-show-parser-state-marker t)
- (remove-hook 'semantic-after-partial-cache-change-hook
- #'semantic-show-parser-state-marker t)
- (remove-hook 'semantic-after-toplevel-cache-change-hook
- #'semantic-show-parser-state-marker t)
-
- (remove-hook 'semantic-before-auto-parse-hooks
- #'semantic-show-parser-state-auto-marker t)
- (remove-hook 'semantic-after-auto-parse-hooks
- #'semantic-show-parser-state-marker t)
-
- (remove-hook 'semantic-before-idle-scheduler-reparse-hook
- #'semantic-show-parser-state-auto-marker t)
- (remove-hook 'semantic-after-idle-scheduler-reparse-hook
- #'semantic-show-parser-state-marker t)))
-
-(semantic-add-minor-mode 'semantic-show-parser-state-mode
- "")
-
-(defvar-local semantic-show-parser-state-string nil
- "String showing the parser state for this buffer.
-See `semantic-show-parser-state-marker' for details.")
-
-(defun semantic-show-parser-state-marker (&rest _ignore)
- "Set `semantic-show-parser-state-string' to indicate parser state.
-This marker is one of the following:
- `-' -> The cache is up to date.
- `!' -> The cache requires a full update.
- `~' -> The cache needs to be incrementally parsed.
- `%' -> The cache is not currently parsable.
- `@' -> Auto-parse in progress (not set here.)
-Arguments IGNORE are ignored, and accepted so this can be used as a hook
-in many situations."
- (setq semantic-show-parser-state-string
- (cond ((semantic-parse-tree-needs-rebuild-p)
- "!")
- ((semantic-parse-tree-needs-update-p)
- "^")
- ((semantic-parse-tree-unparseable-p)
- "%")
- (t
- "-")))
- ;;(message "Setup mode line indicator to [%s]" semantic-show-parser-state-string)
- )
-
-(defun semantic-show-parser-state-auto-marker ()
- "Hook function run before an autoparse.
-Set up `semantic-show-parser-state-marker' to show `@'
-to indicate a parse in progress."
- (unless (semantic-parse-tree-up-to-date-p)
- (setq semantic-show-parser-state-string "@")
- ;; For testing.
- ;;(sit-for 1)
- ))
-
-\f
-;;;;
-;;;; Minor mode to make function decls sticky.
-;;;;
-
-;;;###autoload
-(define-minor-mode global-semantic-stickyfunc-mode
- "Toggle global use of option `semantic-stickyfunc-mode'."
- :global t :group 'semantic :group 'semantic-modes
- ;; Not needed because it's autoloaded instead.
- ;; :require 'semantic/util-modes
- (semantic-toggle-minor-mode-globally
- 'semantic-stickyfunc-mode (if global-semantic-stickyfunc-mode 1 -1)))
-
-(defcustom semantic-stickyfunc-mode-hook nil
- "Hook run at the end of function `semantic-stickyfunc-mode'."
- :group 'semantic
- :type 'hook)
-
-(defvar-keymap semantic-stickyfunc-mode-map
- :doc "Keymap for stickyfunc minor mode."
- "<header-line> <down-mouse-1>" #'semantic-stickyfunc-menu)
-
-(defvar semantic-stickyfunc-popup-menu nil
- "Menu used if the user clicks on the header line used by stickyfunc mode.")
-
-(easy-menu-define
- semantic-stickyfunc-popup-menu
- semantic-stickyfunc-mode-map
- "Stickyfunc Menu."
- '("Stickyfunc Mode" :visible (progn nil)
- [ "Copy Headerline Tag" senator-copy-tag
- :active (semantic-current-tag)
- :help "Copy the current tag to the tag ring"]
- [ "Kill Headerline Tag" senator-kill-tag
- :active (semantic-current-tag)
- :help "Kill tag text to the kill ring, and copy the tag to the tag ring"
- ]
- [ "Copy Headerline Tag to Register" senator-copy-tag-to-register
- :active (semantic-current-tag)
- :help "Copy the current tag to a register"
- ]
- [ "Narrow To Headerline Tag" senator-narrow-to-defun
- :active (semantic-current-tag)
- :help "Narrow to the bounds of the current tag"]
- [ "Fold Headerline Tag" senator-fold-tag-toggle
- :active (semantic-current-tag)
- :style toggle
- :selected (let ((tag (semantic-current-tag)))
- (and tag (semantic-tag-folded-p tag)))
- :help "Fold the current tag to one line"
- ]
- "---"
- [ "About This Header Line"
- (lambda () (interactive)
- (describe-function 'semantic-stickyfunc-mode)) t])
- )
-
-(defcustom semantic-stickyfunc-indent-string
- (if window-system
- (concat
- (condition-case nil
- ;; Test scroll bar location
- (let ((charwidth (frame-char-width))
- (scrollpos (frame-parameter (selected-frame)
- 'vertical-scroll-bars))
- )
- (if (or (eq scrollpos 'left)
- ;; Now wait a minute. If you turn scroll-bar-mode
- ;; on, then off, the new value is t, not left.
- ;; Will this mess up older emacs where the default
- ;; was on the right? I don't think so since they don't
- ;; support a header line.
- (eq scrollpos t))
- (let ((w (when (boundp 'scroll-bar-width)
- (symbol-value 'scroll-bar-width))))
-
- (if (not w)
- (setq w (frame-parameter (selected-frame)
- 'scroll-bar-width)))
-
- ;; in 21.2, the frame parameter is sometimes empty
- ;; so we need to get the value here.
- (if (not w)
- (setq w (+ (get 'scroll-bar-width 'x-frame-parameter)
- ;; In 21.4, or perhaps 22.1 the x-frame
- ;; parameter is different from the frame
- ;; parameter by only 1 pixel.
- 1)))
-
- (if (not w)
- " "
- (setq w (+ 2 w)) ; Some sort of border around
- ; the scrollbar.
- (make-string (/ w charwidth) ? )))
- ""))
- (error ""))
- (condition-case nil
- ;; Test fringe size.
- (let* ((f (window-fringes))
- (fw (car f))
- (numspace (/ fw (frame-char-width)))
- )
- (make-string numspace ? ))
- (error
- ;; Well, the fancy new Emacs functions failed. Try older
- ;; tricks.
- (condition-case nil
- ;; I'm not so sure what's up with the 21.1-21.3 fringe.
- ;; It looks to be about 1 space wide.
- (if (get 'fringe 'face)
- " "
- "")
- (error ""))))
- )
- ;; Not Emacs or a window system means no scrollbar or fringe,
- ;; and perhaps not even a header line to worry about.
- "")
- "String used to indent the stickyfunc header.
-Customize this string to match the space used by scrollbars and
-fringe so it does not appear that the code is moving left/right
-when it lands in the sticky line."
- :group 'semantic
- :type 'string)
-
-(defvar semantic-stickyfunc-old-hlf nil
- "Value of the header line when entering stickyfunc mode.")
-
-(defconst semantic-stickyfunc-header-line-format
- '(:eval (list
- ;; Magic bit I found on emacswiki.
- (propertize " " 'display '((space :align-to 0)))
- (semantic-stickyfunc-fetch-stickyline)))
- "The header line format used by stickyfunc mode.")
-
-;;;###autoload
-(define-minor-mode semantic-stickyfunc-mode
- "Minor mode to show the title of a tag in the header line.
-Enables/disables making the header line of functions sticky.
-A function (or other tag class specified by
-`semantic-stickyfunc-sticky-classes') has a header line, meaning the
-first line which describes the rest of the construct. This first
-line is what is displayed in the header line.
-
-The minor mode can be turned on only if semantic feature is
-available and the current buffer was set up for parsing. Return
-non-nil if the minor mode is enabled."
- ;; Don't need indicator. It's quite visible
- :keymap semantic-stickyfunc-mode-map
- (if semantic-stickyfunc-mode
- (progn
- (unless (and (featurep 'semantic) (semantic-active-p))
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-stickyfunc-mode nil)
- (error "Buffer %s was not set up for parsing" (buffer-name)))
- ;; Enable the mode
- ;; Save previous buffer local value of header line format.
- (when (and (local-variable-p 'header-line-format (current-buffer))
- (not (eq header-line-format
- semantic-stickyfunc-header-line-format)))
- (setq-local semantic-stickyfunc-old-hlf
- header-line-format))
- (setq header-line-format semantic-stickyfunc-header-line-format))
- ;; Disable sticky func mode
- ;; Restore previous buffer local value of header line format if
- ;; the current one is the sticky func one.
- (when (eq header-line-format semantic-stickyfunc-header-line-format)
- (kill-local-variable 'header-line-format)
- (when (local-variable-p 'semantic-stickyfunc-old-hlf (current-buffer))
- (setq header-line-format semantic-stickyfunc-old-hlf)
- (kill-local-variable 'semantic-stickyfunc-old-hlf)))))
-
-(defvar-local semantic-stickyfunc-sticky-classes
- '(function type)
- "List of tag classes which stickyfunc will display in the header line.")
-
-(defcustom semantic-stickyfunc-show-only-functions-p nil
- "Non-nil means don't show lines that aren't part of a tag.
-If this is nil, then comments or other text between tags that is
-1 line above the top of the current window will be shown."
- :group 'semantic
- :type 'boolean)
-
-(defun semantic-stickyfunc-tag-to-stick ()
- "Return the tag to stick at the current point."
- (let ((tags (nreverse (semantic-find-tag-by-overlay (point)))))
- ;; Get rid of non-matching tags.
- (while (and tags
- (not (member
- (semantic-tag-class (car tags))
- semantic-stickyfunc-sticky-classes))
- )
- (setq tags (cdr tags)))
- (car tags)))
-
-(defun semantic-stickyfunc-fetch-stickyline ()
- "Make the function at the top of the current window sticky.
-Capture its function declaration, and place it in the header line.
-If there is no function, disable the header line."
- (save-excursion
- (goto-char (window-start (selected-window)))
- (let* ((noshow (bobp))
- (str
- (progn
- (forward-line -1)
- (end-of-line)
- ;; Capture this function
- (let* ((tag (semantic-stickyfunc-tag-to-stick)))
- ;; TAG is nil if there was nothing of the appropriate type there.
- (if (not tag)
- ;; Set it to be the text under the header line
- (if noshow
- ""
- (if semantic-stickyfunc-show-only-functions-p ""
- (buffer-substring (line-beginning-position) (line-end-position))
- ))
- ;; Go get the first line of this tag.
- (goto-char (semantic-tag-start tag))
- ;; Klaus Berndl <klaus.berndl@sdm.de>:
- ;; goto the tag name; this is especially needed for languages
- ;; like c++ where an often used style is like:
- ;; void
- ;; ClassX::methodM(arg1...)
- ;; {
- ;; ...
- ;; }
- ;; Without going to the tag-name we would get"void" in the
- ;; header line which is IMHO not really useful
- (search-forward (semantic-tag-name tag) nil t)
- (buffer-substring (line-beginning-position) (line-end-position))
- ))))
- (start 0))
- (while (string-match "%" str start)
- (setq str (replace-match "%%" t t str 0)
- start (1+ (match-end 0)))
- )
- ;; In 21.4 (or 22.1) the header doesn't expand tabs. Hmmmm.
- ;; We should replace them here.
- ;;
- ;; This hack assumes that tabs are kept smartly at tab boundaries
- ;; instead of in a tab boundary where it might only represent 4 spaces.
- (while (string-match "\t" str start)
- (setq str (replace-match " " t t str 0)))
- str)))
-
-(defun semantic-stickyfunc-menu (event)
- "Popup a menu that can help a user understand stickyfunc-mode.
-Argument EVENT describes the event that caused this function to be called."
- (interactive "e")
- (let* ((startwin (selected-window))
- (win (car (car (cdr event))))
- )
- (select-window win t)
- (save-excursion
- (goto-char (window-start win))
- (sit-for 0)
- (popup-menu semantic-stickyfunc-popup-menu event)
- )
- (select-window startwin)))
-
-
-(semantic-add-minor-mode 'semantic-stickyfunc-mode
- "") ;; Don't need indicator. It's quite visible
-
-
-\f
-;;;;
-;;;; Minor mode to make highlight the current function
-;;;;
-
-;; Highlight the first like of the function we are in if it is different
-;; from the tag going off the top of the screen.
-
-;;;###autoload
-(define-minor-mode global-semantic-highlight-func-mode
- "Toggle global use of option `semantic-highlight-func-mode'."
- :global t :group 'semantic :group 'semantic-modes
- ;; Not needed because it's autoloaded instead.
- ;; :require 'semantic/util-modes
- (semantic-toggle-minor-mode-globally
- 'semantic-highlight-func-mode
- (if global-semantic-highlight-func-mode 1 -1)))
-
-(defcustom semantic-highlight-func-mode-hook nil
- "Hook run at the end of function `semantic-highlight-func-mode'."
- :group 'semantic
- :type 'hook)
-
-(defvar-keymap semantic-highlight-func-mode-map
- :doc "Keymap for highlight-func minor mode."
- "<mouse-3>" #'semantic-highlight-func-menu)
-
-(defvar semantic-highlight-func-popup-menu nil
- "Menu used if the user clicks on the header line.
-Used by `semantic-highlight-func-mode'.")
-
-(easy-menu-define
- semantic-highlight-func-popup-menu
- semantic-highlight-func-mode-map
- "Highlight-Func Menu."
- '("Highlight-Func Mode" :visible (progn nil)
- [ "Copy Tag" senator-copy-tag
- :active (semantic-current-tag)
- :help "Copy the current tag to the tag ring"]
- [ "Kill Tag" senator-kill-tag
- :active (semantic-current-tag)
- :help "Kill tag text to the kill ring, and copy the tag to the tag ring"
- ]
- [ "Copy Tag to Register" senator-copy-tag-to-register
- :active (semantic-current-tag)
- :help "Copy the current tag to a register"
- ]
- [ "Narrow To Tag" senator-narrow-to-defun
- :active (semantic-current-tag)
- :help "Narrow to the bounds of the current tag"]
- [ "Fold Tag" senator-fold-tag-toggle
- :active (semantic-current-tag)
- :style toggle
- :selected (let ((tag (semantic-stickyfunc-tag-to-stick)))
- (and tag (semantic-tag-folded-p tag)))
- :help "Fold the current tag to one line"
- ]
- "---"
- [ "About This Tag" semantic-describe-tag t])
- )
-
-(defun semantic-highlight-func-menu (event)
- "Popup a menu that displays things to do to the current tag.
-Argument EVENT describes the event that caused this function to be called."
- (interactive "e")
- (let* ((startwin (selected-window))
- (win (semantic-event-window event))
- )
- (select-window win t)
- (save-excursion
- ;(goto-char (window-start win))
- (mouse-set-point event)
- (sit-for 0)
- (popup-menu semantic-highlight-func-popup-menu)
- )
- (select-window startwin)))
-
-(defvar-local semantic-highlight-func-ct-overlay nil
- "Overlay used to highlight the tag the cursor is in.")
-
-(defface semantic-highlight-func-current-tag-face
- '((((class color) (background dark))
- ;; Put this back to something closer to black later.
- (:background "gray20"))
- (((class color) (background light))
- (:background "gray90")))
- "Face used to show the top of current function."
- :group 'semantic-faces)
-
-;;;###autoload
-(define-minor-mode semantic-highlight-func-mode
- "Minor mode to highlight the first line of the current tag.
-Enables/disables making the current function's first line light up.
-A function (or other tag class specified by
-`semantic-stickyfunc-sticky-classes') is highlighted, meaning the
-first line which describes the rest of the construct.
-
-See `semantic-stickyfunc-mode' for putting a function in the
-header line. This mode recycles the stickyfunc configuration
-classes list.
-
-The minor mode can be turned on only if semantic feature is
-available and the current buffer was set up for parsing. Return
-non-nil if the minor mode is enabled."
- :lighter nil ;; Don't need indicator. It's quite visible.
- (if semantic-highlight-func-mode
- (progn
- (unless (and (featurep 'semantic) (semantic-active-p))
- ;; Disable minor mode if semantic stuff not available
- (setq semantic-highlight-func-mode nil)
- (error "Buffer %s was not set up for parsing" (buffer-name)))
- ;; Setup our hook
- (add-hook 'post-command-hook
- #'semantic-highlight-func-highlight-current-tag nil t))
- ;; Disable highlight func mode
- (remove-hook 'post-command-hook
- #'semantic-highlight-func-highlight-current-tag t)
- (semantic-highlight-func-highlight-current-tag t)))
-
-(defun semantic-highlight-func-highlight-current-tag (&optional disable)
- "Highlight the current tag under point.
-Optional argument DISABLE will turn off any active highlight.
-If the current tag for this buffer is different from the last time this
-function was called, move the overlay."
- (when (and (not (minibufferp))
- (or (not semantic-highlight-func-ct-overlay)
- (eq (overlay-buffer
- semantic-highlight-func-ct-overlay)
- (current-buffer))))
- (let* ((tag (semantic-stickyfunc-tag-to-stick))
- (ol semantic-highlight-func-ct-overlay))
- (when (not ol)
- ;; No overlay in this buffer. Make one.
- (setq ol (make-overlay (point-min) (point-min)
- (current-buffer) t nil))
- (overlay-put ol 'highlight-func t)
- (overlay-put ol 'face 'semantic-highlight-func-current-tag-face)
- (overlay-put ol 'keymap semantic-highlight-func-mode-map)
- (overlay-put ol 'help-echo
- "Current Function : mouse-3 - Context menu")
- (setq semantic-highlight-func-ct-overlay ol)
- )
-
- ;; TAG is nil if there was nothing of the appropriate type there.
- (if (or (not tag) disable)
- ;; No tag, make the overlay go away.
- (progn
- (overlay-put ol 'tag nil)
- (move-overlay ol (point-min) (point-min) (current-buffer)))
-
- ;; We have a tag, if it is the same, do nothing.
- (unless (eq (overlay-get ol 'tag) tag)
- (save-excursion
- (goto-char (semantic-tag-start tag))
- (search-forward (semantic-tag-name tag) nil t)
- (overlay-put ol 'tag tag)
- (move-overlay ol (line-beginning-position) (line-end-position)))))))
- nil)
-
-(semantic-add-minor-mode 'semantic-highlight-func-mode
- "") ;; Don't need indicator. It's quite visible
-
-(provide 'semantic/util-modes)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "semantic/util-modes"
-;; End:
-
-;;; semantic/util-modes.el ends here
+++ /dev/null
-;;; semantic/util.el --- Utilities for use with semantic tag tables -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1999-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic utility API for use with semantic tag tables.
-;;
-
-(require 'semantic)
-
-(eval-when-compile
- (require 'semantic/db-find)
- ;; For semantic-find-tags-by-class, semantic--find-tags-by-function,
- ;; and semantic-brute-find-tag-standard:
- (require 'semantic/find))
-
-(declare-function data-debug-insert-stuff-list "data-debug")
-(declare-function data-debug-insert-thing "data-debug")
-(declare-function semantic-ctxt-current-symbol-and-bounds "semantic/ctxt")
-
-;;; Code:
-
-(defvar-local semantic-type-relation-separator-character '(".")
- "Character strings used to separate a parent/child relationship.
-This list of strings are used for displaying or finding separators
-in variable field dereferencing. The first character will be used for
-display. In C, a type field is separated like this: \"type.field\"
-thus, the character is a \".\". In C, and additional value of \"->\"
-would be in the list, so that \"type->field\" could be found.")
-
-(defvar-local semantic-equivalent-major-modes nil
- "List of major modes which are considered equivalent.
-Equivalent modes share a parser, and a set of override methods.
-A value of nil means that the current major mode is the only one.")
-
-(declare-function semanticdb-file-stream "semantic/db" (file))
-
-;; These semanticdb calls will throw warnings in the byte compiler.
-;; Doing the right thing to make them available at compile time
-;; really messes up the compilation sequence.
-(defun semantic-file-tag-table (file)
- "Return a tag table for FILE.
-If it is loaded, return the stream after making sure it's ok.
-If FILE is not loaded, check to see if `semanticdb' feature exists,
- and use it to get tags from files not in memory.
-If FILE is not loaded, and semanticdb is not available, find the file
- and parse it."
- (save-match-data
- (if (find-buffer-visiting file)
- (with-current-buffer (find-buffer-visiting file)
- (semantic-fetch-tags))
- ;; File not loaded
- (if (and (require 'semantic/db-mode)
- (semanticdb-minor-mode-p))
- ;; semanticdb is around, use it.
- (semanticdb-file-stream file)
- ;; Get the stream ourselves.
- (with-current-buffer (find-file-noselect file)
- (semantic-fetch-tags))))))
-
-(declare-function semanticdb-refresh-table "semantic/db")
-(declare-function semanticdb-get-tags "semantic/db" (arg &rest args) t)
-(declare-function semanticdb-find-results-p "semantic/db-find" (resultp))
-
-(defun semantic-something-to-tag-table (something)
- "Convert SOMETHING into a semantic tag table.
-Something can be a tag with a valid BUFFER property, a tag table, a
-buffer, or a filename. If SOMETHING is nil return nil."
- (cond
- ;; A list of tags
- ((and (listp something)
- (semantic-tag-p (car something)))
- something)
- ;; A buffer
- ((bufferp something)
- (with-current-buffer something
- (semantic-fetch-tags)))
- ;; A Tag: Get that tag's buffer
- ((and (semantic-tag-with-position-p something)
- (semantic-tag-in-buffer-p something))
- (with-current-buffer (semantic-tag-buffer something)
- (semantic-fetch-tags)))
- ;; Tag with a file name in it
- ((and (semantic-tag-p something)
- (semantic-tag-file-name something)
- (file-exists-p (semantic-tag-file-name something)))
- (semantic-file-tag-table
- (semantic-tag-file-name something)))
- ;; A file name
- ((and (stringp something)
- (file-exists-p something))
- (semantic-file-tag-table something))
- ;; A Semanticdb table
- ((and (featurep 'semantic/db)
- (require 'semantic/db-mode)
- (semanticdb-minor-mode-p)
- (progn
- (cl-typep something 'semanticdb-abstract-table)))
- (semanticdb-refresh-table something)
- (semanticdb-get-tags something))
- ;; Semanticdb find-results
- ((and (featurep 'semantic/db)
- (require 'semantic/db-mode)
- (semanticdb-minor-mode-p)
- (require 'semantic/db-find)
- (semanticdb-find-results-p something))
- (semanticdb-strip-find-results something))
- ;; NOTE: This commented out since if a search result returns
- ;; empty, that empty would turn into everything on the next search.
- ;; Use the current buffer for nil
-;; ((null something)
-;; (semantic-fetch-tags))
- ;; don't know what it is
- (t nil)))
-
-;;; Completion APIs
-;;
-;; These functions provide minibuffer reading/completion for lists of
-;; nonterminals.
-(defvar semantic-read-symbol-history nil
- "History for a symbol read.")
-
-(declare-function semantic-brute-find-tag-by-function
- "semantic/find"
- (function streamorbuffer
- &optional search-parts search-includes))
-
-(defun semantic-read-symbol (prompt &optional default stream filter)
- "Read a symbol name from the user for the current buffer.
-PROMPT is the prompt to use.
-Optional arguments:
-DEFAULT is the default choice. If no default is given, one is read
-from under point.
-STREAM is the list of tokens to complete from.
-FILTER is provides a filter on the types of things to complete.
-FILTER must be a function to call on each element."
- (if (not default) (setq default (thing-at-point 'symbol)))
- (if (not stream) (setq stream (semantic-fetch-tags)))
- (setq stream
- (if filter
- (semantic--find-tags-by-function filter stream)
- (require 'semantic/find)
- (semantic-brute-find-tag-standard stream)))
- (if (and default (string-match ":" prompt))
- (setq prompt
- (concat (substring prompt 0 (match-end 0))
- " (default: " default ") ")))
- (completing-read prompt stream nil t ""
- 'semantic-read-symbol-history
- default))
-
-(defun semantic-read-variable (prompt &optional default stream)
- "Read a variable name from the user for the current buffer.
-PROMPT is the prompt to use.
-Optional arguments:
-DEFAULT is the default choice. If no default is given, one is read
-from under point.
-STREAM is the list of tokens to complete from."
- (semantic-read-symbol
- prompt default
- (or (semantic-find-tags-by-class
- 'variable (or stream (current-buffer)))
- (error "No local variables"))))
-
-(defun semantic-read-function (prompt &optional default stream)
- "Read a function name from the user for the current buffer.
-PROMPT is the prompt to use.
-Optional arguments:
-DEFAULT is the default choice. If no default is given, one is read
-from under point.
-STREAM is the list of tags to complete from."
- (semantic-read-symbol
- prompt default
- (or (semantic-find-tags-by-class
- 'function (or stream (current-buffer)))
- (error "No local functions"))))
-
-(defun semantic-read-type (prompt &optional default stream)
- "Read a type name from the user for the current buffer.
-PROMPT is the prompt to use.
-Optional arguments:
-DEFAULT is the default choice. If no default is given, one is read
-from under point.
-STREAM is the list of tags to complete from."
- (semantic-read-symbol
- prompt default
- (or (semantic-find-tags-by-class
- 'type (or stream (current-buffer)))
- (error "No local types"))))
-
-\f
-;;; Interactive Functions for
-;;
-(defun semantic-describe-tag (&optional tag)
- "Describe TAG in the minibuffer.
-If TAG is nil, describe the tag under the cursor."
- (interactive)
- (if (not tag) (setq tag (semantic-current-tag)))
- (semantic-fetch-tags)
- (if tag (message (semantic-format-tag-summarize tag))))
-
-\f
-;;; Putting keys on tags.
-;;
-(defun semantic-add-label (label value &optional tag)
- "Add a LABEL with VALUE on TAG.
-If TAG is not specified, use the tag at point."
- (interactive "sLabel: \nXValue (eval): ")
- (if (not tag)
- (progn
- (semantic-fetch-tags)
- (setq tag (semantic-current-tag))))
- (semantic--tag-put-property tag (intern label) value)
- (message "Added label %s with value %S" label value))
-
-(defun semantic-show-label (label &optional tag)
- "Show the value of LABEL on TAG.
-If TAG is not specified, use the tag at point."
- (interactive "sLabel: ")
- (if (not tag)
- (progn
- (semantic-fetch-tags)
- (setq tag (semantic-current-tag))))
- (message "%s: %S" label (semantic--tag-get-property tag (intern label))))
-
-\f
-;;; Hacks
-;;
-;; Some hacks to help me test these functions
-(defun semantic-describe-buffer-var-helper (varsym buffer)
- "Display to standard out the value of VARSYM in BUFFER."
- (require 'data-debug)
- (let ((value (with-current-buffer buffer
- (symbol-value varsym))))
- (cond
- ((and (consp value)
- (< (length value) 10))
- ;; Draw the list of things in the list.
- (princ (format " %s: #<list of %d items>\n"
- varsym (length value)))
- (data-debug-insert-stuff-list
- value " " )
- )
- (t
- ;; Else do a one-liner.
- (data-debug-insert-thing
- value " " (concat " " (symbol-name varsym) ": "))
- ))))
-
-(defun semantic-describe-buffer ()
- "Describe the semantic environment for the current buffer."
- (interactive)
- (let ((buff (current-buffer))
- )
-
- (with-output-to-temp-buffer (help-buffer)
- (help-setup-xref (list #'semantic-describe-buffer)
- (called-interactively-p 'interactive))
- (with-current-buffer standard-output
- (princ "Semantic Configuration in ")
- (princ (buffer-name buff))
- (princ "\n\n")
-
- (princ "Buffer specific configuration items:\n")
- (let ((vars '(major-mode
- semantic-case-fold
- semantic-tag-expand-function
- semantic-parser-name
- semantic-parse-tree-state
- semantic-lex-analyzer
- semantic-lex-reset-functions
- semantic-lex-syntax-modifications
- )))
- (dolist (V vars)
- (semantic-describe-buffer-var-helper V buff)))
-
- (princ "\nGeneral configuration items:\n")
- (let ((vars '(semantic-inhibit-functions
- semantic-init-hook
- semantic-init-db-hook
- semantic-unmatched-syntax-hook
- semantic--before-fetch-tags-hook
- semantic-after-toplevel-cache-change-hook
- semantic-before-toplevel-cache-flush-hook
- semantic-dump-parse
- semantic-type-relation-separator-character
- semantic-command-separation-character
- semantic-new-buffer-fcn-was-run
- )))
- (dolist (V vars)
- (semantic-describe-buffer-var-helper V buff)))
-
- (princ "\n\n")
- (mode-local-describe-bindings-2 buff)
- )))
- )
-
-(defun semantic-assert-valid-token (tok)
- "Assert that TOK is a valid token."
- (if (semantic-tag-p tok)
- (if (semantic-tag-with-position-p tok)
- (let ((o (semantic-tag-overlay tok)))
- (if (and (overlayp o)
- (not (overlay-buffer o)))
- (let ((debug-on-error t))
- (error "Tag %s is invalid!" (semantic-tag-name tok)))
- ;; else, tag is OK.
- ))
- ;; Positionless tags are also ok.
- )
- (let ((debug-on-error t))
- (error "Not a semantic tag: %S" tok))))
-
-(defun semantic-sanity-check (&optional cache over notfirst)
- "Perform a sanity check on the current buffer.
-The buffer's set of overlays, and those overlays found via the cache
-are verified against each other.
-CACHE, and OVER are the semantic cache, and the overlay list.
-NOTFIRST indicates that this was not the first call in the recursive use."
- (interactive)
- (if (and (not cache) (not over) (not notfirst))
- (setq cache semantic--buffer-cache
- over (overlays-in (point-min) (point-max))))
- (while cache
- (let ((chil (semantic-tag-components-with-overlays (car cache))))
- (if (not (memq (semantic-tag-overlay (car cache)) over))
- (message "Tag %s not in buffer overlay list."
- (semantic-format-tag-concise-prototype (car cache))))
- (setq over (delq (semantic-tag-overlay (car cache)) over))
- (setq over (semantic-sanity-check chil over t))
- (setq cache (cdr cache))))
- (if (not notfirst)
- ;; Strip out all overlays which aren't semantic overlays
- (let ((o nil))
- (while over
- (when (and (overlay-get (car over) 'semantic)
- (not (eq (overlay-get (car over) 'semantic)
- 'unmatched)))
- (setq o (cons (car over) o)))
- (setq over (cdr over)))
- (when (called-interactively-p 'any)
- (message "Remaining overlays: %S" o))))
- over)
-
-;;; Interactive commands (from Senator).
-
-;; The Senator library from upstream CEDET is not included in the
-;; built-in version of Emacs. The plan is to fold it into the
-;; different parts of CEDET and Emacs, so that it works
-;; "transparently". Here are some interactive commands based on
-;; Senator.
-
-;; Symbol completion
-
-(declare-function semanticdb-fast-strip-find-results
- "semantic/db-find" (results))
-(declare-function semanticdb-deep-find-tags-for-completion
- "semantic/db-find" (prefix &optional path find-file-match))
-
-(defun semantic-find-tag-for-completion (prefix)
- "Find all tags with name starting with PREFIX.
-This uses `semanticdb' when available."
- (let (result ctxt)
- ;; Try the Semantic analyzer
- (condition-case nil
- (and (featurep 'semantic/analyze)
- (setq ctxt (semantic-analyze-current-context))
- (setq result (semantic-analyze-possible-completions ctxt)))
- (error nil))
- (or result
- ;; If the analyzer fails, then go into boring completion.
- (if (and (featurep 'semantic/db)
- (semanticdb-minor-mode-p)
- (require 'semantic/db-find))
- (semanticdb-fast-strip-find-results
- (semanticdb-deep-find-tags-for-completion prefix))
- (semantic-deep-find-tags-for-completion prefix (current-buffer))))))
-
-(defun semantic-complete-symbol (&optional predicate)
- "Complete the symbol under point, using Semantic facilities.
-When called from a program, optional arg PREDICATE is a predicate
-determining which symbols are considered."
- (interactive)
- (require 'semantic/ctxt)
- (let* ((start (car (nth 2 (semantic-ctxt-current-symbol-and-bounds
- (point)))))
- (pattern (regexp-quote (buffer-substring start (point))))
- collection completion)
- (when start
- (if (and semantic--completion-cache
- (eq (nth 0 semantic--completion-cache) (current-buffer))
- (= (nth 1 semantic--completion-cache) start)
- (save-excursion
- (goto-char start)
- (looking-at (nth 3 semantic--completion-cache))))
- ;; Use cached value.
- (setq collection (nthcdr 4 semantic--completion-cache))
- ;; Perform new query.
- (setq collection (semantic-find-tag-for-completion pattern))
- (setq semantic--completion-cache
- (append (list (current-buffer) start 0 pattern)
- collection))))
- (if (null collection)
- (let ((str (if pattern (format " for \"%s\"" pattern) "")))
- (if (window-minibuffer-p (selected-window))
- (minibuffer-message (format " [No completions%s]" str))
- (message "Can't find completion%s" str)))
- (setq completion (try-completion pattern collection predicate))
- (if (string= pattern completion)
- (let ((list (all-completions pattern collection predicate)))
- (setq list (sort list))
- (if (> (length list) 1)
- (with-output-to-temp-buffer "*Completions*"
- (display-completion-list
- (completion-hilit-commonality list (length pattern) nil)))
- ;; Bury any out-of-date completions buffer.
- (let ((win (get-buffer-window "*Completions*" 0)))
- (if win (with-selected-window win (bury-buffer))))))
- ;; Exact match
- (delete-region start (point))
- (insert completion)
- ;; Bury any out-of-date completions buffer.
- (let ((win (get-buffer-window "*Completions*" 0)))
- (if win (with-selected-window win (bury-buffer))))))))
-
-(provide 'semantic/util)
-
-;;; Minor modes
-;;
-(require 'semantic/util-modes)
-
-;;; semantic/util.el ends here
+++ /dev/null
-;;; semantic/wisent.el --- Wisent - Semantic gateway -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2001-2007, 2009-2024 Free Software Foundation, Inc.
-
-;; Author: David Ponce <david@dponce.com>
-;; Created: 30 Aug 2001
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Here are functions necessary to use the Wisent LALR parser from
-;; Semantic environment.
-
-;;; Code:
-
-(require 'semantic)
-(require 'semantic/wisent/wisent)
-\f
-;;; Lexical analysis
-;;
-(defvar wisent-lex-istream nil
- "Input stream of `semantic-lex' syntactic tokens.")
-
-(defvar wisent-lex-lookahead nil
- "Extra lookahead token.
-When non-nil it is directly returned by `wisent-lexer-function'.")
-
-(defmacro wisent-lex-eoi ()
- "Return an End-Of-Input lexical token.
-The EOI token is like this: ($EOI \"\" POINT-MAX . POINT-MAX)."
- `(cons ',wisent-eoi-term
- (cons ""
- (cons (point-max) (point-max)))))
-
-(defmacro define-wisent-lexer (name doc &rest body)
- "Create a new lexical analyzer with NAME.
-DOC is a documentation string describing this analyzer.
-When a token is available in `wisent-lex-istream', eval BODY forms
-sequentially. BODY must return a lexical token for the LALR parser.
-
-Each token in input was produced by `semantic-lex', it is a list:
-
- (TOKSYM START . END)
-
-TOKSYM is a terminal symbol used in the grammar.
-START and END mark boundary in the current buffer of that token's
-value.
-
-Returned tokens must have the form:
-
- (TOKSYM VALUE START . END)
-
-where VALUE is the buffer substring between START and END positions."
- (declare (debug (&define name stringp def-body)) (indent 1))
- `(defun
- ,name () ,doc
- (cond
- (wisent-lex-lookahead
- (prog1 wisent-lex-lookahead
- (setq wisent-lex-lookahead nil)))
- (wisent-lex-istream
- ,@body)
- ((wisent-lex-eoi)))))
-
-(define-wisent-lexer wisent-lex
- "Return the next available lexical token in Wisent's form.
-The variable `wisent-lex-istream' contains the list of lexical tokens
-produced by `semantic-lex'. Pop the next token available and convert
-it to a form suitable for the Wisent's parser."
- (let* ((tk (car wisent-lex-istream)))
- ;; Eat input stream
- (setq wisent-lex-istream (cdr wisent-lex-istream))
- (cons (semantic-lex-token-class tk)
- (cons (semantic-lex-token-text tk)
- (semantic-lex-token-bounds tk)))))
-\f
-;;; Syntax analysis
-;;
-(defvar-local wisent-error-function nil
- "Function used to report parse error.
-By default use the function `wisent-message'.")
-
-(defvar-local wisent-lexer-function 'wisent-lex
- "Function used to obtain the next lexical token in input.
-Should be a lexical analyzer created with `define-wisent-lexer'.")
-
-;; Tag production
-;;
-(defsubst wisent-raw-tag (semantic-tag)
- "Return raw form of given Semantic tag SEMANTIC-TAG.
-Should be used in semantic actions, in grammars, to build a Semantic
-parse tree."
- (nconc semantic-tag
- (if (or $region
- (setq $region (nthcdr 2 wisent-input)))
- (list (car $region) (cdr $region))
- (list (point-max) (point-max)))))
-
-(defsubst wisent-cook-tag (raw-tag)
- "From raw form of Semantic tag RAW-TAG, return a list of cooked tags.
-Should be used in semantic actions, in grammars, to build a Semantic
-parse tree."
- (let* ((cooked (semantic--tag-expand raw-tag))
- (l cooked))
- (while l
- (semantic--tag-put-property (car l) 'reparse-symbol $nterm)
- (setq l (cdr l)))
- cooked))
-
-;; Unmatched syntax collector
-;;
-(defun wisent-collect-unmatched-syntax (nomatch)
- "Add lexical token NOMATCH to the cache of unmatched tokens.
-See also the variable `semantic-unmatched-syntax-cache'.
-
-NOMATCH is in Wisent's form: (SYMBOL VALUE START . END)
-and will be collected in `semantic-lex' form: (SYMBOL START . END)."
- (let ((region (cddr nomatch)))
- (and (number-or-marker-p (car region))
- (number-or-marker-p (cdr region))
- (setq semantic-unmatched-syntax-cache
- (cons (cons (car nomatch) region)
- semantic-unmatched-syntax-cache)))))
-
-;; Parser plug-ins
-;;
-;; The following functions permit plugging the Wisent LALR parser in
-;; Semantic toolkit. They use the standard API provided by Semantic
-;; to plug parsers in.
-;;
-;; Two plug-ins are available, BUT ONLY ONE MUST BE USED AT A TIME:
-;;
-;; - `wisent-parse-stream' designed to override the standard function
-;; `semantic-parse-stream'.
-;;
-;; - `wisent-parse-region' designed to override the standard function
-;; `semantic-parse-region'.
-;;
-;; Maybe the latter is faster because it eliminates a lot of function
-;; call.
-;;
-(defun wisent-parse-stream (stream goal)
- "Parse STREAM using the Wisent LALR parser.
-GOAL is a nonterminal symbol to start parsing at.
-Return the list (STREAM SEMANTIC-STREAM) where STREAM are those
-elements of STREAM that have not been used. SEMANTIC-STREAM is the
-list of semantic tags found.
-The LALR parser automaton must be available in buffer local variable
-`semantic--parse-table'.
-
-Must be installed by `semantic-install-function-overrides' to override
-the standard function `semantic-parse-stream'."
- (let (wisent-lex-istream wisent-lex-lookahead la-elt cache)
-
- ;; IMPLEMENTATION NOTES:
- ;; `wisent-parse' returns a lookahead token when it stopped
- ;; parsing before encountering the end of input. To re-enter the
- ;; parser it is necessary to push back in the lexical input stream
- ;; the last lookahead token issued. Because the format of
- ;; lookahead tokens and tokens in STREAM can be different the
- ;; lookahead token is put in the variable `wisent-lex-lookahead'
- ;; before calling `wisent-parse'. Wisent's lexers always pop the
- ;; next lexical token from that variable when non-nil, then from
- ;; the lexical input stream.
- ;;
- ;; The first element of STREAM is used to keep lookahead tokens
- ;; across successive calls to `wisent-parse-stream'. In fact
- ;; what is kept is a stack of lookaheads encountered so far. It
- ;; is cleared when `wisent-parse' returns a valid semantic tag,
- ;; or twice the same lookahead token! The latter indicates that
- ;; there is a syntax error on that token. If so, tokens currently
- ;; in the lookahead stack have not been used, and are moved into
- ;; `semantic-unmatched-syntax-cache'. When the parser will be
- ;; re-entered, a new lexical token will be read from STREAM.
- ;;
- ;; The first element of STREAM that contains the lookahead stack
- ;; has this format (compatible with the format of `semantic-lex'
- ;; tokens):
- ;;
- ;; (LOOKAHEAD-STACK START . END)
- ;;
- ;; where LOOKAHEAD-STACK is a list of lookahead tokens. And
- ;; START/END are the bounds of the lookahead at top of stack.
-
- ;; Retrieve lookahead token from stack
- (setq la-elt (car stream))
- (if (consp (car la-elt))
- ;; The first elt of STREAM contains a lookahead stack
- (setq wisent-lex-lookahead (caar la-elt)
- stream (cdr stream))
- (setq la-elt nil))
- ;; Parse
- (setq wisent-lex-istream stream
- cache (semantic-safe "wisent-parse-stream: %s"
- (condition-case error-to-filter
- (wisent-parse semantic--parse-table
- wisent-lexer-function
- wisent-error-function
- goal)
- (args-out-of-range
- (if (and (not debug-on-error)
- (= wisent-parse-max-stack-size
- (nth 2 error-to-filter)))
- (progn
- (message "wisent-parse-stream: %s"
- (error-message-string error-to-filter))
- (message "wisent-parse-max-stack-size \
-might need to be increased"))
- (apply #'signal error-to-filter))))))
- ;; Manage returned lookahead token
- (if wisent-lookahead
- (if (eq (caar la-elt) wisent-lookahead)
- ;; It is already at top of lookahead stack
- (progn
- (setq cache nil
- la-elt (car la-elt))
- (while la-elt
- ;; Collect unmatched tokens from the stack
- (run-hook-with-args
- 'wisent-discarding-token-functions (car la-elt))
- (setq la-elt (cdr la-elt))))
- ;; New lookahead token
- (if (or (consp cache) ;; Clear the stack if parse succeeded
- (null la-elt))
- (setq la-elt (cons nil nil)))
- ;; Push it into the stack
- (setcar la-elt (cons wisent-lookahead (car la-elt)))
- ;; Update START/END
- (setcdr la-elt (cddr wisent-lookahead))
- ;; Push (LOOKAHEAD-STACK START . END) in STREAM
- (setq wisent-lex-istream (cons la-elt wisent-lex-istream))))
- ;; Return (STREAM SEMANTIC-STREAM)
- (list wisent-lex-istream
- (if (consp cache) cache '(nil))
- )))
-
-(defmacro wisent-compiled-grammar (grammar &optional start-list)
- "Return a compiled form of the LALR(1) Wisent GRAMMAR.
-See `wisent--compile-grammar' for a description of the arguments
-and return value."
- ;; Ensure that the grammar compiler is available.
- (require 'semantic/wisent/comp)
- (declare-function wisent-automaton-lisp-form "semantic/wisent/comp" (x))
- (declare-function wisent--compile-grammar "semantic/wisent/comp" (grm st))
- (wisent-automaton-lisp-form
- (wisent--compile-grammar grammar start-list)))
-
-(defun wisent-parse-region (start end &optional goal depth returnonerror)
- "Parse the area between START and END using the Wisent LALR parser.
-Return the list of semantic tags found.
-Optional arguments GOAL is a nonterminal symbol to start parsing at,
-DEPTH is the lexical depth to scan, and RETURNONERROR is a flag to
-stop parsing on syntax error, when non-nil.
-The LALR parser automaton must be available in buffer local variable
-`semantic--parse-table'.
-
-Must be installed by `semantic-install-function-overrides' to override
-the standard function `semantic-parse-region'."
- (if (or (< start (point-min)) (> end (point-max)) (< end start))
- (error "Invalid bounds [%s %s] passed to `wisent-parse-region'"
- start end))
- (let* ((case-fold-search semantic-case-fold)
- (wisent-lex-istream (semantic-lex start end depth))
- ptree tag cooked lstack wisent-lex-lookahead)
- ;; Loop while there are lexical tokens available
- (while wisent-lex-istream
- ;; Parse
- (setq wisent-lex-lookahead (car lstack)
- tag (semantic-safe "wisent-parse-region: %s"
- (wisent-parse semantic--parse-table
- wisent-lexer-function
- wisent-error-function
- goal)))
- ;; Manage returned lookahead token
- (if wisent-lookahead
- (if (eq (car lstack) wisent-lookahead)
- ;; It is already at top of lookahead stack
- (progn
- (setq tag nil)
- (while lstack
- ;; Collect unmatched tokens from lookahead stack
- (run-hook-with-args
- 'wisent-discarding-token-functions (car lstack))
- (setq lstack (cdr lstack))))
- ;; Push new lookahead token into the stack
- (setq lstack (cons wisent-lookahead lstack))))
- ;; Manage the parser result
- (cond
- ;; Parse succeeded, cook result
- ((consp tag)
- (setq lstack nil ;; Clear the lookahead stack
- cooked (semantic--tag-expand tag)
- ptree (append cooked ptree))
- (while cooked
- (setq tag (car cooked)
- cooked (cdr cooked))
- (or (semantic--tag-get-property tag 'reparse-symbol)
- (semantic--tag-put-property tag 'reparse-symbol goal)))
- )
- ;; Return on error if requested
- (returnonerror
- (setq wisent-lex-istream nil)
- ))
- ;; Work in progress...
- (if wisent-lex-istream
- (and (eq semantic-working-type 'percent)
- (boundp 'semantic--progress-reporter)
- semantic--progress-reporter
- (progress-reporter-update
- semantic--progress-reporter
- (floor (* 100.0 (semantic-lex-token-start
- (car wisent-lex-istream)))
- (point-max))))))
- ;; Return parse tree
- (nreverse ptree)))
-
-(provide 'semantic/wisent)
-
-;;; semantic/wisent.el ends here
+++ /dev/null
-;;; semantic/wisent/comp.el --- GNU Bison for Emacs - Grammar compiler -*- lexical-binding: t; -*-
-
-;; Copyright (C) 1984, 1986, 1989, 1992, 1995, 2000-2007, 2009-2024 Free
-;; Software Foundation, Inc.
-
-;; Author: David Ponce <david@dponce.com>
-;; Created: 30 January 2002
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Grammar compiler that produces Wisent's LALR automatons.
-;;
-;; Wisent (the European Bison ;-) is an Elisp implementation of the
-;; GNU Compiler Compiler Bison. The Elisp code is a port of the C
-;; code of GNU Bison 1.28 & 1.31.
-;;
-;; For more details on the basic concepts for understanding Wisent,
-;; read the Bison manual ;)
-;;
-;; For more details on Wisent itself read the Wisent manual.
-
-;;; Code:
-(require 'semantic/wisent)
-(eval-when-compile (require 'cl-lib))
-(require 'subr-x) ; `string-pad'
-\f
-;;;; -------------------
-;;;; Misc. useful things
-;;;; -------------------
-
-;; As much as possible I would like to keep the name of global
-;; variables used in Bison without polluting too much the Elisp global
-;; name space. Elisp dynamic binding allows that ;-)
-
-;; Here are simple macros to easily define and use set of variables
-;; bound locally, without all these "reference to free variable"
-;; compiler warnings!
-
-(eval-when-compile
- (defun wisent-context-name (name)
- "Return the context name from NAME."
- (if (and name (symbolp name))
- (intern (format "wisent-context-%s" name))
- (error "Invalid context name: %S" name)))
-
- (defun wisent-context-bindings (name)
- "Return the variables in context NAME."
- (symbol-value (wisent-context-name name))))
-
-(defmacro wisent-defcontext (name &rest vars)
- "Define a context NAME that will bind variables VARS."
- (declare (indent 1))
- (declare-function wisent-context-name nil (name))
- (let* ((context (wisent-context-name name))
- (declarations (mapcar (lambda (v) (list 'defvar v)) vars)))
- `(progn
- ,@declarations
- (eval-when-compile
- (defvar ,context ',vars)))))
-
-(defmacro wisent-with-context (name &rest body)
- "Bind variables in context NAME then eval BODY."
- (declare (indent 1))
- (declare-function wisent-context-bindings nil (name))
- `(dlet ,(wisent-context-bindings name)
- ,@body))
-
-(defsubst wisent-pad-string (s n &optional left)
- "Fill string S with spaces.
-Return a new string of at least N characters. Insert spaces on right.
-If optional LEFT is non-nil insert spaces on left."
- (declare (obsolete string-pad "29.1"))
- (string-pad s n nil left))
-
-\f
-;;;; ------------------------
-;;;; Environment dependencies
-;;;; ------------------------
-
-;; FIXME: Use bignums or bool-vectors?
-
-(defconst wisent-BITS-PER-WORD (logcount most-positive-fixnum))
-
-(defsubst wisent-WORDSIZE (n)
- "(N + BITS-PER-WORD - 1) / BITS-PER-WORD."
- (/ (1- (+ n wisent-BITS-PER-WORD)) wisent-BITS-PER-WORD))
-
-(defsubst wisent-SETBIT (x i)
- "X[I/BITS-PER-WORD] |= 1 << (I % BITS-PER-WORD)."
- (let ((k (/ i wisent-BITS-PER-WORD)))
- (aset x k (logior (aref x k)
- (ash 1 (% i wisent-BITS-PER-WORD))))))
-
-(defsubst wisent-RESETBIT (x i)
- "X[I/BITS-PER-WORD] &= ~(1 << (I % BITS-PER-WORD))."
- (let ((k (/ i wisent-BITS-PER-WORD)))
- (aset x k (logand (aref x k)
- (lognot (ash 1 (% i wisent-BITS-PER-WORD)))))))
-
-(defsubst wisent-BITISSET (x i)
- "(X[I/BITS-PER-WORD] & (1 << (I % BITS-PER-WORD))) != 0."
- (not (zerop (logand (aref x (/ i wisent-BITS-PER-WORD))
- (ash 1 (% i wisent-BITS-PER-WORD))))))
-
-(defvar wisent-debug-flag nil
- "Non-nil means enable some debug stuff.")
-\f
-;;;; --------------
-;;;; Logging/Output
-;;;; --------------
-(defconst wisent-log-buffer-name "*wisent-log*"
- "Name of the log buffer.")
-
-(defvar wisent-new-log-flag nil
- "Non-nil means to start a new report.")
-
-(defcustom wisent-verbose-flag nil
- "Non-nil means to report verbose information on generated parser."
- :group 'wisent
- :type 'boolean)
-
-(defun wisent-toggle-verbose-flag ()
- "Toggle whether to report verbose information on generated parser."
- (interactive)
- (setq wisent-verbose-flag (not wisent-verbose-flag))
- (when (called-interactively-p 'interactive)
- (message "Verbose report %sabled"
- (if wisent-verbose-flag "en" "dis"))))
-
-(defmacro wisent-log-buffer ()
- "Return the log buffer.
-Its name is defined in constant `wisent-log-buffer-name'."
- '(get-buffer-create wisent-log-buffer-name))
-
-(defmacro wisent-clear-log ()
- "Delete the entire contents of the log buffer."
- '(with-current-buffer (wisent-log-buffer)
- (erase-buffer)))
-
-(defun wisent-source ()
- "Return the current source file name or nil."
- (let ((source (macroexp-file-name)))
- (if source
- (file-relative-name source))))
-
-(defun wisent-new-log ()
- "Start a new entry into the log buffer."
- (setq wisent-new-log-flag nil)
- (let ((text (format "\n\n*** Wisent %s - %s\n\n"
- (or (wisent-source) (buffer-name))
- (format-time-string "%Y-%m-%d %R"))))
- (with-current-buffer (wisent-log-buffer)
- (goto-char (point-max))
- (insert text))))
-
-(defsubst wisent-log (&rest args)
- "Insert text into the log buffer.
-`format-message' is applied to ARGS and the result string is inserted into the
-log buffer returned by the function `wisent-log-buffer'."
- (and wisent-new-log-flag (wisent-new-log))
- (with-current-buffer (wisent-log-buffer)
- (insert (apply #'format-message args))))
-
-(defconst wisent-log-file "wisent.output"
- "The log file.
-Used when running without interactive terminal.")
-
-(defun wisent-append-to-log-file ()
- "Append contents of logging buffer to `wisent-log-file'."
- (if (get-buffer wisent-log-buffer-name)
- (condition-case err
- (with-current-buffer (wisent-log-buffer)
- (widen)
- (if (> (point-max) (point-min))
- (write-region (point-min) (point-max)
- wisent-log-file t)))
- (error
- (message "*** %s" (error-message-string err))))))
-\f
-;;;; -----------------------------------
-;;;; Representation of the grammar rules
-;;;; -----------------------------------
-
-;; ntokens is the number of tokens, and nvars is the number of
-;; variables (nonterminals). nsyms is the total number, ntokens +
-;; nvars.
-
-;; Each symbol (either token or variable) receives a symbol number.
-;; Numbers 0 to ntokens-1 are for tokens, and ntokens to nsyms-1 are
-;; for variables. Symbol number zero is the end-of-input token. This
-;; token is counted in ntokens.
-
-;; The rules receive rule numbers 1 to nrules in the order they are
-;; written. Actions and guards are accessed via the rule number.
-
-;; The rules themselves are described by three arrays: rrhs, rlhs and
-;; ritem. rlhs[R] is the symbol number of the left hand side of rule
-;; R. The right hand side is stored as symbol numbers in a portion of
-;; ritem. rrhs[R] contains the index in ritem of the beginning of the
-;; portion for rule R.
-
-;; The length of the portion is one greater than the number of symbols
-;; in the rule's right hand side. The last element in the portion
-;; contains minus R, which identifies it as the end of a portion and
-;; says which rule it is for.
-
-;; The portions of ritem come in order of increasing rule number and
-;; are followed by an element which is nil to mark the end. nitems is
-;; the total length of ritem, not counting the final nil. Each
-;; element of ritem is called an "item" and its index in ritem is an
-;; item number.
-
-;; Item numbers are used in the finite state machine to represent
-;; places that parsing can get to.
-
-;; The vector rprec contains for each rule, the item number of the
-;; symbol giving its precedence level to this rule. The precedence
-;; level and associativity of each symbol is recorded in respectively
-;; the properties 'wisent--prec and 'wisent--assoc.
-
-;; Precedence levels are assigned in increasing order starting with 1
-;; so that numerically higher precedence values mean tighter binding
-;; as they ought to. nil as a symbol or rule's precedence means none
-;; is assigned.
-
-(defcustom wisent-state-table-size 1009
- "The size of the state table."
- :type 'integer
- :group 'wisent)
-
-;; These variables only exist locally in the function
-;; `wisent-compile-grammar' and are shared by all other nested
-;; callees.
-(wisent-defcontext compile-grammar
- F LA LAruleno accessing-symbol conflicts consistent default-prec
- derives err-table fderives final-state first-reduction first-shift
- first-state firsts from-state goto-map includes itemset nitemset
- kernel-base kernel-end kernel-items last-reduction last-shift
- last-state lookaheads lookaheadset lookback maxrhs ngotos nitems
- nrules nshifts nstates nsyms ntokens nullable nvars rassoc redset
- reduction-table ritem rlhs rprec rrc-count rrc-total rrhs ruseful
- rcode ruleset rulesetsize shift-symbol shift-table shiftset
- src-count src-total start-table state-table tags this-state to-state
- tokensetsize ;; nb of words req. to hold a bit for each rule
- varsetsize ;; nb of words req. to hold a bit for each variable
- error-token-number start-symbol token-list var-list
- N P V V1 nuseless-nonterminals nuseless-productions
- ptable ;; symbols & characters properties
- )
-
-(defmacro wisent-ISTOKEN (s)
- "Return non-nil if item number S defines a token (terminal).
-That is if S < `ntokens'."
- `(< ,s ntokens))
-
-(defmacro wisent-ISVAR(s)
- "Return non-nil if item number S defines a nonterminal.
-That is if S >= `ntokens'."
- `(>= ,s ntokens))
-
-(defsubst wisent-tag (s)
- "Return printable form of item number S."
- (wisent-item-to-string (aref tags s)))
-
-;; Symbol and character properties
-
-(defsubst wisent-put (object propname value)
- "Store OBJECT's PROPNAME property with value VALUE.
-Use `eq' to locate OBJECT."
- (let ((entry (assq object ptable)))
- (or entry (setq entry (list object) ptable (cons entry ptable)))
- (setcdr entry (plist-put (cdr entry) propname value))))
-
-(defsubst wisent-get (object propname)
- "Return the value of OBJECT's PROPNAME property.
-Use `eq' to locate OBJECT."
- (plist-get (cdr (assq object ptable)) propname))
-
-(defsubst wisent-item-number (x)
- "Return the item number of symbol X."
- (wisent-get x 'wisent--item-no))
-
-(defsubst wisent-set-item-number (x n)
- "Set the item number of symbol X to N."
- (wisent-put x 'wisent--item-no n))
-
-(defsubst wisent-assoc (x)
- "Return the associativity of symbol X."
- (wisent-get x 'wisent--assoc))
-
-(defsubst wisent-set-assoc (x a)
- "Set the associativity of symbol X to A."
- (wisent-put x 'wisent--assoc a))
-
-(defsubst wisent-prec (x)
- "Return the precedence level of symbol X."
- (wisent-get x 'wisent--prec))
-
-(defsubst wisent-set-prec (x p)
- "Set the precedence level of symbol X to P."
- (wisent-put x 'wisent--prec p))
-\f
-;;;; ----------------------------------------------------------
-;;;; Type definitions for nondeterministic finite state machine
-;;;; ----------------------------------------------------------
-
-;; These type definitions are used to represent a nondeterministic
-;; finite state machine that parses the specified grammar. This
-;; information is generated by the function `wisent-generate-states'.
-
-;; Each state of the machine is described by a set of items --
-;; particular positions in particular rules -- that are the possible
-;; places where parsing could continue when the machine is in this
-;; state. These symbols at these items are the allowable inputs that
-;; can follow now.
-
-;; A core represents one state. States are numbered in the number
-;; field. When `wisent-generate-states' is finished, the starting
-;; state is state 0 and `nstates' is the number of states. (A
-;; transition to a state whose state number is `nstates' indicates
-;; termination.) All the cores are chained together and `first-state'
-;; points to the first one (state 0).
-
-;; For each state there is a particular symbol which must have been
-;; the last thing accepted to reach that state. It is the
-;; accessing-symbol of the core.
-
-;; Each core contains a vector of `nitems' items which are the indices
-;; in the `ritems' vector of the items that are selected in this
-;; state.
-
-;; The link field is used for chaining buckets that hash states by
-;; their itemsets. This is for recognizing equivalent states and
-;; combining them when the states are generated.
-
-;; The two types of transitions are shifts (push the lookahead token
-;; and read another) and reductions (combine the last n things on the
-;; stack via a rule, replace them with the symbol that the rule
-;; derives, and leave the lookahead token alone). When the states are
-;; generated, these transitions are represented in two other lists.
-
-;; Each shifts structure describes the possible shift transitions out
-;; of one state, the state whose number is in the number field. The
-;; shifts structures are linked through next and first-shift points to
-;; them. Each contains a vector of numbers of the states that shift
-;; transitions can go to. The accessing-symbol fields of those
-;; states' cores say what kind of input leads to them.
-
-;; A shift to state zero should be ignored. Conflict resolution
-;; deletes shifts by changing them to zero.
-
-;; Each reductions structure describes the possible reductions at the
-;; state whose number is in the number field. The data is a list of
-;; nreds rules, represented by their rule numbers. `first-reduction'
-;; points to the list of these structures.
-
-;; Conflict resolution can decide that certain tokens in certain
-;; states should explicitly be errors (for implementing %nonassoc).
-;; For each state, the tokens that are errors for this reason are
-;; recorded in an errs structure, which has the state number in its
-;; number field. The rest of the errs structure is full of token
-;; numbers.
-
-;; There is at least one shift transition present in state zero. It
-;; leads to a next-to-final state whose accessing-symbol is the
-;; grammar's start symbol. The next-to-final state has one shift to
-;; the final state, whose accessing-symbol is zero (end of input).
-;; The final state has one shift, which goes to the termination state
-;; (whose number is `nstates'-1).
-;; The reason for the extra state at the end is to placate the
-;; parser's strategy of making all decisions one token ahead of its
-;; actions.
-
-;; FIXME: Use `wisent-' prefix to fix namespace pollution!
-
-(cl-defstruct (core
- (:constructor make-core ()))
- next ; -> core
- link ; -> core
- (number 0)
- (accessing-symbol 0)
- (nitems 0)
- (items [0]))
-
-(cl-defstruct (shifts
- (:constructor make-shifts ()))
- next ; -> shifts
- (number 0)
- (nshifts 0)
- (shifts [0]))
-
-(cl-defstruct (reductions
- (:constructor make-reductions ()))
- next ; -> reductions
- (number 0)
- (nreds 0)
- (rules [0]))
-
-(cl-defstruct (errs
- (:constructor make-errs ()))
- (nerrs 0)
- (errs [0]))
-\f
-;;;; --------------------------------------------------------
-;;;; Find unreachable terminals, nonterminals and productions
-;;;; --------------------------------------------------------
-
-(defun wisent-bits-equal (L R n)
- "Visit L and R and return non-nil if their first N elements are `='.
-L and R must be vectors of integers."
- (let* ((i (1- n))
- (iseq t))
- (while (and iseq (natnump i))
- (setq iseq (= (aref L i) (aref R i))
- i (1- i)))
- iseq))
-
-(defun wisent-nbits (i)
- "Return number of bits set in integer I."
- (let ((count 0))
- (while (not (zerop i))
- ;; i ^= (i & ((unsigned) (-(int) i)))
- (setq i (logxor i (logand i (- i)))
- count (1+ count)))
- count))
-
-(defun wisent-bits-size (S n)
- "In vector S count the total of bits set in first N elements.
-S must be a vector of integers."
- (let* ((i (1- n))
- (count 0))
- (while (natnump i)
- (setq count (+ count (wisent-nbits (aref S i)))
- i (1- i)))
- count))
-
-(defun wisent-useful-production (i N0)
- "Return non-nil if production I is in useful set N0."
- (let* ((useful t)
- (r (aref rrhs i))
- n)
- (while (and useful (> (setq n (aref ritem r)) 0))
- (if (wisent-ISVAR n)
- (setq useful (wisent-BITISSET N0 (- n ntokens))))
- (setq r (1+ r)))
- useful))
-
-(defun wisent-useless-nonterminals ()
- "Find out which nonterminals are used."
- (let (Np Ns i n break)
- ;; N is set as built. Np is set being built this iteration. P is
- ;; set of all productions which have a RHS all in N.
- (setq n (wisent-WORDSIZE nvars)
- Np (make-vector n 0))
-
- ;; The set being computed is a set of nonterminals which can
- ;; derive the empty string or strings consisting of all
- ;; terminals. At each iteration a nonterminal is added to the set
- ;; if there is a production with that nonterminal as its LHS for
- ;; which all the nonterminals in its RHS are already in the set.
- ;; Iterate until the set being computed remains unchanged. Any
- ;; nonterminals not in the set at that point are useless in that
- ;; they will never be used in deriving a sentence of the language.
-
- ;; This iteration doesn't use any special traversal over the
- ;; productions. A set is kept of all productions for which all
- ;; the nonterminals in the RHS are in useful. Only productions
- ;; not in this set are scanned on each iteration. At the end,
- ;; this set is saved to be used when finding useful productions:
- ;; only productions in this set will appear in the final grammar.
-
- (while (not break)
- (setq i (1- n))
- (while (natnump i)
- ;; Np[i] = N[i]
- (aset Np i (aref N i))
- (setq i (1- i)))
-
- (setq i 1)
- (while (<= i nrules)
- (if (not (wisent-BITISSET P i))
- (when (wisent-useful-production i N)
- (wisent-SETBIT Np (- (aref rlhs i) ntokens))
- (wisent-SETBIT P i)))
- (setq i (1+ i)))
- (if (wisent-bits-equal N Np n)
- (setq break t)
- (setq Ns Np
- Np N
- N Ns)))
- (setq N Np)))
-
-(defun wisent-inaccessible-symbols ()
- "Find out which productions are reachable and which symbols are used."
- ;; Starting with an empty set of productions and a set of symbols
- ;; which only has the start symbol in it, iterate over all
- ;; productions until the set of productions remains unchanged for an
- ;; iteration. For each production which has a LHS in the set of
- ;; reachable symbols, add the production to the set of reachable
- ;; productions, and add all of the nonterminals in the RHS of the
- ;; production to the set of reachable symbols.
-
- ;; Consider only the (partially) reduced grammar which has only
- ;; nonterminals in N and productions in P.
-
- ;; The result is the set P of productions in the reduced grammar,
- ;; and the set V of symbols in the reduced grammar.
-
- ;; Although this algorithm also computes the set of terminals which
- ;; are reachable, no terminal will be deleted from the grammar. Some
- ;; terminals might not be in the grammar but might be generated by
- ;; semantic routines, and so the user might want them available with
- ;; specified numbers. (Is this true?) However, the non reachable
- ;; terminals are printed (if running in verbose mode) so that the
- ;; user can know.
- (let (Vp Vs Pp i tt r n m break)
- (setq n (wisent-WORDSIZE nsyms)
- m (wisent-WORDSIZE (1+ nrules))
- Vp (make-vector n 0)
- Pp (make-vector m 0))
-
- ;; If the start symbol isn't useful, then nothing will be useful.
- (when (wisent-BITISSET N (- start-symbol ntokens))
- (wisent-SETBIT V start-symbol)
- (while (not break)
- (setq i (1- n))
- (while (natnump i)
- (aset Vp i (aref V i))
- (setq i (1- i)))
- (setq i 1)
- (while (<= i nrules)
- (when (and (not (wisent-BITISSET Pp i))
- (wisent-BITISSET P i)
- (wisent-BITISSET V (aref rlhs i)))
- (setq r (aref rrhs i))
- (while (natnump (setq tt (aref ritem r)))
- (if (or (wisent-ISTOKEN tt)
- (wisent-BITISSET N (- tt ntokens)))
- (wisent-SETBIT Vp tt))
- (setq r (1+ r)))
- (wisent-SETBIT Pp i))
- (setq i (1+ i)))
- (if (wisent-bits-equal V Vp n)
- (setq break t)
- (setq Vs Vp
- Vp V
- V Vs))))
- (setq V Vp)
-
- ;; Tokens 0, 1 are internal to Wisent. Consider them useful.
- (wisent-SETBIT V 0) ;; end-of-input token
- (wisent-SETBIT V 1) ;; error token
- (setq P Pp)
-
- (setq nuseless-productions (- nrules (wisent-bits-size P m))
- nuseless-nonterminals nvars
- i ntokens)
- (while (< i nsyms)
- (if (wisent-BITISSET V i)
- (setq nuseless-nonterminals (1- nuseless-nonterminals)))
- (setq i (1+ i)))
-
- ;; A token that was used in %prec should not be warned about.
- (setq i 1)
- (while (<= i nrules)
- (if (aref rprec i)
- (wisent-SETBIT V1 (aref rprec i)))
- (setq i (1+ i)))
- ))
-
-(defun wisent-reduce-grammar-tables ()
- "Disable useless productions."
- (if (> nuseless-productions 0)
- (let ((pn 1))
- (while (<= pn nrules)
- (aset ruseful pn (wisent-BITISSET P pn))
- (setq pn (1+ pn))))))
-
-(defun wisent-nonterminals-reduce ()
- "Remove useless nonterminals."
- (let (i n r item nontermmap tags-sorted)
- ;; Map the nonterminals to their new index: useful first, useless
- ;; afterwards. Kept for later report.
- (setq nontermmap (make-vector nvars 0)
- n ntokens
- i ntokens)
- (while (< i nsyms)
- (when (wisent-BITISSET V i)
- (aset nontermmap (- i ntokens) n)
- (setq n (1+ n)))
- (setq i (1+ i)))
- (setq i ntokens)
- (while (< i nsyms)
- (unless (wisent-BITISSET V i)
- (aset nontermmap (- i ntokens) n)
- (setq n (1+ n)))
- (setq i (1+ i)))
- ;; Shuffle elements of tables indexed by symbol number
- (setq tags-sorted (make-vector nvars nil)
- i ntokens)
- (while (< i nsyms)
- (setq n (aref nontermmap (- i ntokens)))
- (aset tags-sorted (- n ntokens) (aref tags i))
- (setq i (1+ i)))
- (setq i ntokens)
- (while (< i nsyms)
- (aset tags i (aref tags-sorted (- i ntokens)))
- (setq i (1+ i)))
- ;; Replace all symbol numbers in valid data structures.
- (setq i 1)
- (while (<= i nrules)
- (aset rlhs i (aref nontermmap (- (aref rlhs i) ntokens)))
- (setq i (1+ i)))
- (setq r 0)
- (while (setq item (aref ritem r))
- (if (wisent-ISVAR item)
- (aset ritem r (aref nontermmap (- item ntokens))))
- (setq r (1+ r)))
- (setq start-symbol (aref nontermmap (- start-symbol ntokens))
- nsyms (- nsyms nuseless-nonterminals)
- nvars (- nvars nuseless-nonterminals))
- ))
-
-(defun wisent-total-useless ()
- "Report number of useless nonterminals and productions."
- (let* ((src (wisent-source))
- (src (if src (concat " in " src) ""))
- (msg (format "Grammar%s contains" src)))
- (if (> nuseless-nonterminals 0)
- (setq msg (format "%s %d useless nonterminal%s"
- msg nuseless-nonterminals
- (if (> nuseless-nonterminals 0) "s" ""))))
- (if (and (> nuseless-nonterminals 0) (> nuseless-productions 0))
- (setq msg (format "%s and" msg)))
- (if (> nuseless-productions 0)
- (setq msg (format "%s %d useless rule%s"
- msg nuseless-productions
- (if (> nuseless-productions 0) "s" ""))))
- (message msg)))
-
-(defun wisent-reduce-grammar ()
- "Find unreachable terminals, nonterminals and productions."
- ;; Allocate the global sets used to compute the reduced grammar
- (setq N (make-vector (wisent-WORDSIZE nvars) 0)
- P (make-vector (wisent-WORDSIZE (1+ nrules)) 0)
- V (make-vector (wisent-WORDSIZE nsyms) 0)
- V1 (make-vector (wisent-WORDSIZE nsyms) 0)
- nuseless-nonterminals 0
- nuseless-productions 0)
-
- (wisent-useless-nonterminals)
- (wisent-inaccessible-symbols)
-
- (when (> (+ nuseless-nonterminals nuseless-productions) 0)
- (wisent-total-useless)
- (or (wisent-BITISSET N (- start-symbol ntokens))
- (error "Start symbol `%s' does not derive any sentence"
- (wisent-tag start-symbol)))
- (wisent-reduce-grammar-tables)
- (if (> nuseless-nonterminals 0)
- (wisent-nonterminals-reduce))))
-
-(defun wisent-print-useless ()
- "Output the detailed results of the reductions."
- (let (i b r)
- (when (> nuseless-nonterminals 0)
- ;; Useless nonterminals have been moved after useful ones.
- (wisent-log "\n\nUseless nonterminals:\n\n")
- (setq i 0)
- (while (< i nuseless-nonterminals)
- (wisent-log " %s\n" (wisent-tag (+ nsyms i)))
- (setq i (1+ i))))
- (setq b nil
- i 0)
- (while (< i ntokens)
- (unless (or (wisent-BITISSET V i) (wisent-BITISSET V1 i))
- (or b
- (wisent-log "\n\nTerminals which are not used:\n\n"))
- (setq b t)
- (wisent-log " %s\n" (wisent-tag i)))
- (setq i (1+ i)))
- (when (> nuseless-productions 0)
- (wisent-log "\n\nUseless rules:\n\n")
- (setq i 1)
- (while (<= i nrules)
- (unless (aref ruseful i)
- (wisent-log "#%s " (string-pad (format "%d" i) 4))
- (wisent-log "%s:" (wisent-tag (aref rlhs i)))
- (setq r (aref rrhs i))
- (while (natnump (aref ritem r))
- (wisent-log " %s" (wisent-tag (aref ritem r)))
- (setq r (1+ r)))
- (wisent-log ";\n"))
- (setq i (1+ i))))
- (if (or b (> nuseless-nonterminals 0) (> nuseless-productions 0))
- (wisent-log "\n\n"))
- ))
-\f
-;;;; -----------------------------
-;;;; Match rules with nonterminals
-;;;; -----------------------------
-
-(defun wisent-set-derives ()
- "Find, for each variable (nonterminal), which rules can derive it.
-It sets up the value of DERIVES so that DERIVES[i - NTOKENS] points to
-a list of rule numbers, terminated with -1."
- (let (i lhs p q dset delts)
- (setq dset (make-vector nvars nil)
- delts (make-vector (1+ nrules) 0))
- (setq p 0 ;; p = delts
- i nrules)
- (while (> i 0)
- (when (aref ruseful i)
- (setq lhs (aref rlhs i))
- ;; p->next = dset[lhs];
- ;; p->value = i;
- (aset delts p (cons i (aref dset (- lhs ntokens)))) ;; (value . next)
- (aset dset (- lhs ntokens) p) ;; dset[lhs] = p
- (setq p (1+ p)) ;; p++
- )
- (setq i (1- i)))
-
- (setq derives (make-vector nvars nil)
- i ntokens)
-
- (while (< i nsyms)
- (setq q nil
- p (aref dset (- i ntokens))) ;; p = dset[i]
-
- (while p
- (setq p (aref delts p)
- q (cons (car p) q) ;;q++ = p->value
- p (cdr p))) ;; p = p->next
- (setq q (nreverse (cons -1 q))) ;; *q++ = -1
- (aset derives (- i ntokens) q) ;; derives[i] = q
- (setq i (1+ i)))
- ))
-\f
-;;;; --------------------------------------------------------
-;;;; Find which nonterminals can expand into the null string.
-;;;; --------------------------------------------------------
-
-(defun wisent-print-nullable ()
- "Print NULLABLE."
- (let (i)
- (wisent-log "NULLABLE\n")
- (setq i ntokens)
- (while (< i nsyms)
- (wisent-log "\t%s: %s\n" (wisent-tag i)
- (if (aref nullable (- i ntokens))
- "yes" : "no"))
- (setq i (1+ i)))
- (wisent-log "\n\n")))
-
-(defun wisent-set-nullable ()
- "Set up NULLABLE.
-A vector saying which nonterminals can expand into the null string.
-NULLABLE[i - NTOKENS] is nil if symbol I can do so."
- (let (ruleno s1 s2 p r squeue rcount rsets relts item any-tokens)
- (setq squeue (make-vector nvars 0)
- rcount (make-vector (1+ nrules) 0)
- rsets (make-vector nvars nil) ;; - ntokens
- relts (make-vector (+ nitems nvars 1) nil)
- nullable (make-vector nvars nil)) ;; - ntokens
- (setq s1 0 s2 0 ;; s1 = s2 = squeue
- p 0 ;; p = relts
- ruleno 1)
- (while (<= ruleno nrules)
- (when (aref ruseful ruleno)
- (if (> (aref ritem (aref rrhs ruleno)) 0)
- (progn
- ;; This rule has a non empty RHS.
- (setq any-tokens nil
- r (aref rrhs ruleno))
- (while (> (aref ritem r) 0)
- (if (wisent-ISTOKEN (aref ritem r))
- (setq any-tokens t))
- (setq r (1+ r)))
-
- ;; This rule has only nonterminals: schedule it for the
- ;; second pass.
- (unless any-tokens
- (setq r (aref rrhs ruleno))
- (while (> (setq item (aref ritem r)) 0)
- (aset rcount ruleno (1+ (aref rcount ruleno)))
- ;; p->next = rsets[item];
- ;; p->value = ruleno;
- (aset relts p (cons ruleno (aref rsets (- item ntokens))))
- ;; rsets[item] = p;
- (aset rsets (- item ntokens) p)
- (setq p (1+ p)
- r (1+ r)))))
- ;; This rule has an empty RHS.
- ;; assert (ritem[rrhs[ruleno]] == -ruleno)
- (when (and (aref ruseful ruleno)
- (setq item (aref rlhs ruleno))
- (not (aref nullable (- item ntokens))))
- (aset nullable (- item ntokens) t)
- (aset squeue s2 item)
- (setq s2 (1+ s2)))
- )
- )
- (setq ruleno (1+ ruleno)))
-
- (while (< s1 s2)
- ;; p = rsets[*s1++]
- (setq p (aref rsets (- (aref squeue s1) ntokens))
- s1 (1+ s1))
- (while p
- (setq p (aref relts p)
- ruleno (car p)
- p (cdr p)) ;; p = p->next
- ;; if (--rcount[ruleno] == 0)
- (when (zerop (aset rcount ruleno (1- (aref rcount ruleno))))
- (setq item (aref rlhs ruleno))
- (aset nullable (- item ntokens) t)
- (aset squeue s2 item)
- (setq s2 (1+ s2)))))
-
- (if wisent-debug-flag
- (wisent-print-nullable))
- ))
-\f
-;;;; -----------
-;;;; Subroutines
-;;;; -----------
-
-(defun wisent-print-fderives ()
- "Print FDERIVES."
- (let (i j rp)
- (wisent-log "\n\n\nFDERIVES\n")
- (setq i ntokens)
- (while (< i nsyms)
- (wisent-log "\n\n%s derives\n\n" (wisent-tag i))
- (setq rp (aref fderives (- i ntokens))
- j 0)
- (while (<= j nrules)
- (if (wisent-BITISSET rp j)
- (wisent-log " %d\n" j))
- (setq j (1+ j)))
- (setq i (1+ i)))))
-
-(defun wisent-set-fderives ()
- "Set up FDERIVES.
-An NVARS by NRULES matrix of bits indicating which rules can help
-derive the beginning of the data for each nonterminal. For example,
-if symbol 5 can be derived as the sequence of symbols 8 3 20, and one
-of the rules for deriving symbol 8 is rule 4, then the
-[5 - NTOKENS, 4] bit in FDERIVES is set."
- (let (i j k)
- (setq fderives (make-vector nvars nil))
- (setq i 0)
- (while (< i nvars)
- (aset fderives i (make-vector rulesetsize 0))
- (setq i (1+ i)))
-
- (wisent-set-firsts)
-
- (setq i ntokens)
- (while (< i nsyms)
- (setq j ntokens)
- (while (< j nsyms)
- ;; if (BITISSET (FIRSTS (i), j - ntokens))
- (when (wisent-BITISSET (aref firsts (- i ntokens)) (- j ntokens))
- (setq k (aref derives (- j ntokens)))
- (while (> (car k) 0) ;; derives[j][k] > 0
- ;; SETBIT (FDERIVES (i), derives[j][k]);
- (wisent-SETBIT (aref fderives (- i ntokens)) (car k))
- (setq k (cdr k))))
- (setq j (1+ j)))
- (setq i (1+ i)))
-
- (if wisent-debug-flag
- (wisent-print-fderives))
- ))
-
-(defun wisent-print-firsts ()
- "Print FIRSTS."
- (let (i j v)
- (wisent-log "\n\n\nFIRSTS\n\n")
- (setq i ntokens)
- (while (< i nsyms)
- (wisent-log "\n\n%s firsts\n\n" (wisent-tag i))
- (setq v (aref firsts (- i ntokens))
- j 0)
- (while (< j nvars)
- (if (wisent-BITISSET v j)
- (wisent-log "\t\t%d (%s)\n"
- (+ j ntokens) (wisent-tag (+ j ntokens))))
- (setq j (1+ j)))
- (setq i (1+ i)))))
-
-(defun wisent-TC (R n)
- "Transitive closure.
-Given R an N by N matrix of bits, modify its contents to be the
-transitive closure of what was given."
- (let (i j k)
- ;; R (J, I) && R (I, K) => R (J, K).
- ;; I *must* be the outer loop.
- (setq i 0)
- (while (< i n)
- (setq j 0)
- (while (< j n)
- (when (wisent-BITISSET (aref R j) i)
- (setq k 0)
- (while (< k n)
- (if (wisent-BITISSET (aref R i) k)
- (wisent-SETBIT (aref R j) k))
- (setq k (1+ k))))
- (setq j (1+ j)))
- (setq i (1+ i)))))
-
-(defun wisent-RTC (R n)
- "Reflexive Transitive Closure.
-Same as `wisent-TC' and then set all the bits on the diagonal of R, an
-N by N matrix of bits."
- (let (i)
- (wisent-TC R n)
- (setq i 0)
- (while (< i n)
- (wisent-SETBIT (aref R i) i)
- (setq i (1+ i)))))
-
-(defun wisent-set-firsts ()
- "Set up FIRSTS.
-An NVARS by NVARS bit matrix indicating which items can represent the
-beginning of the input corresponding to which other items. For
-example, if some rule expands symbol 5 into the sequence of symbols 8
-3 20, the symbol 8 can be the beginning of the data for symbol 5, so
-the bit [8 - NTOKENS, 5 - NTOKENS] in FIRSTS is set."
- (let (row symbol sp rowsize i)
- (setq rowsize (wisent-WORDSIZE nvars)
- varsetsize rowsize
- firsts (make-vector nvars nil)
- i 0)
- (while (< i nvars)
- (aset firsts i (make-vector rowsize 0))
- (setq i (1+ i)))
-
- (setq row 0 ;; row = firsts
- i ntokens)
- (while (< i nsyms)
- (setq sp (aref derives (- i ntokens)))
- (while (>= (car sp) 0)
- (setq symbol (aref ritem (aref rrhs (car sp)))
- sp (cdr sp))
- (when (wisent-ISVAR symbol)
- (setq symbol (- symbol ntokens))
- (wisent-SETBIT (aref firsts row) symbol)
- ))
- (setq row (1+ row)
- i (1+ i)))
-
- (wisent-RTC firsts nvars)
-
- (if wisent-debug-flag
- (wisent-print-firsts))
- ))
-
-(defun wisent-initialize-closure (n)
- "Allocate the ITEMSET and RULESET vectors.
-And precompute useful data so that `wisent-closure' can be called.
-N is the number of elements to allocate for ITEMSET."
- (setq itemset (make-vector n 0)
- rulesetsize (wisent-WORDSIZE (1+ nrules))
- ruleset (make-vector rulesetsize 0))
-
- (wisent-set-fderives))
-
-(defun wisent-print-closure ()
- "Print ITEMSET."
- (let (i)
- (wisent-log "\n\nclosure n = %d\n\n" nitemset)
- (setq i 0) ;; isp = itemset
- (while (< i nitemset)
- (wisent-log " %d\n" (aref itemset i))
- (setq i (1+ i)))))
-
-(defun wisent-closure (core n)
- "Set up RULESET and ITEMSET for the transitions out of CORE state.
-Given a vector of item numbers items, of length N, set up RULESET and
-ITEMSET to indicate what rules could be run and which items could be
-accepted when those items are the active ones.
-
-RULESET contains a bit for each rule. `wisent-closure' sets the bits
-for all rules which could potentially describe the next input to be
-read.
-
-ITEMSET is a vector of item numbers; NITEMSET is the number of items
-in ITEMSET. `wisent-closure' places there the indices of all items
-which represent units of input that could arrive next."
- (let (c r v symbol ruleno itemno)
- (if (zerop n)
- (progn
- (setq r 0
- v (aref fderives (- start-symbol ntokens)))
- (while (< r rulesetsize)
- ;; ruleset[r] = FDERIVES (start-symbol)[r];
- (aset ruleset r (aref v r))
- (setq r (1+ r)))
- )
- (fillarray ruleset 0)
- (setq c 0)
- (while (< c n)
- (setq symbol (aref ritem (aref core c)))
- (when (wisent-ISVAR symbol)
- (setq r 0
- v (aref fderives (- symbol ntokens)))
- (while (< r rulesetsize)
- ;; ruleset[r] |= FDERIVES (ritem[core[c]])[r];
- (aset ruleset r (logior (aref ruleset r) (aref v r)))
- (setq r (1+ r))))
- (setq c (1+ c)))
- )
- (setq nitemset 0
- c 0
- ruleno 0
- r (* rulesetsize wisent-BITS-PER-WORD))
- (while (< ruleno r)
- (when (wisent-BITISSET ruleset ruleno)
- (setq itemno (aref rrhs ruleno))
- (while (and (< c n) (< (aref core c) itemno))
- (aset itemset nitemset (aref core c))
- (setq nitemset (1+ nitemset)
- c (1+ c)))
- (aset itemset nitemset itemno)
- (setq nitemset (1+ nitemset)))
- (setq ruleno (1+ ruleno)))
-
- (while (< c n)
- (aset itemset nitemset (aref core c))
- (setq nitemset (1+ nitemset)
- c (1+ c)))
-
- (if wisent-debug-flag
- (wisent-print-closure))
- ))
-\f
-;;;; --------------------------------------------------
-;;;; Generate the nondeterministic finite state machine
-;;;; --------------------------------------------------
-
-(defun wisent-allocate-itemsets ()
- "Allocate storage for itemsets."
- (let (symbol i count symbol-count)
- ;; Count the number of occurrences of all the symbols in RITEMS.
- ;; Note that useless productions (hence useless nonterminals) are
- ;; browsed too, hence we need to allocate room for _all_ the
- ;; symbols.
- (setq count 0
- symbol-count (make-vector (+ nsyms nuseless-nonterminals) 0)
- i 0)
- (while (setq symbol (aref ritem i))
- (when (> symbol 0)
- (setq count (1+ count))
- (aset symbol-count symbol (1+ (aref symbol-count symbol))))
- (setq i (1+ i)))
- ;; See comments before `wisent-new-itemsets'. All the vectors of
- ;; items live inside kernel-items. The number of active items
- ;; after some symbol cannot be more than the number of times that
- ;; symbol appears as an item, which is symbol-count[symbol]. We
- ;; allocate that much space for each symbol.
- (setq kernel-base (make-vector nsyms nil)
- kernel-items (make-vector count 0)
- count 0
- i 0)
- (while (< i nsyms)
- (aset kernel-base i count)
- (setq count (+ count (aref symbol-count i))
- i (1+ i)))
- (setq shift-symbol symbol-count
- kernel-end (make-vector nsyms nil))
- ))
-
-(defun wisent-allocate-storage ()
- "Allocate storage for the state machine."
- (wisent-allocate-itemsets)
- (setq shiftset (make-vector nsyms 0)
- redset (make-vector (1+ nrules) 0)
- state-table (make-vector wisent-state-table-size nil)))
-
-(defun wisent-new-itemsets ()
- "Find which symbols can be shifted in the current state.
-And for each one record which items would be active after that shift.
-Uses the contents of ITEMSET. SHIFT-SYMBOL is set to a vector of the
-symbols that can be shifted. For each symbol in the grammar,
-KERNEL-BASE[symbol] points to a vector of item numbers activated if
-that symbol is shifted, and KERNEL-END[symbol] points after the end of
-that vector."
- (let (i shiftcount isp ksp symbol)
- (fillarray kernel-end nil)
- (setq shiftcount 0
- isp 0)
- (while (< isp nitemset)
- (setq i (aref itemset isp)
- isp (1+ isp)
- symbol (aref ritem i))
- (when (> symbol 0)
- (setq ksp (aref kernel-end symbol))
- (when (not ksp)
- ;; shift-symbol[shiftcount++] = symbol;
- (aset shift-symbol shiftcount symbol)
- (setq shiftcount (1+ shiftcount)
- ksp (aref kernel-base symbol)))
- ;; *ksp++ = i + 1;
- (aset kernel-items ksp (1+ i))
- (setq ksp (1+ ksp))
- (aset kernel-end symbol ksp)))
- (setq nshifts shiftcount)))
-
-(defun wisent-new-state (symbol)
- "Create a new state for those items, if necessary.
-SYMBOL is the core accessing-symbol.
-Subroutine of `wisent-get-state'."
- (let (n p isp1 isp2 iend items)
- (setq isp1 (aref kernel-base symbol)
- iend (aref kernel-end symbol)
- n (- iend isp1)
- p (make-core)
- items (make-vector n 0))
- (setf (core-accessing-symbol p) symbol)
- (setf (core-number p) nstates)
- (setf (core-nitems p) n)
- (setf (core-items p) items)
- (setq isp2 0) ;; isp2 = p->items
- (while (< isp1 iend)
- ;; *isp2++ = *isp1++;
- (aset items isp2 (aref kernel-items isp1))
- (setq isp1 (1+ isp1)
- isp2 (1+ isp2)))
- (setf (core-next last-state) p)
- (setq last-state p
- nstates (1+ nstates))
- p))
-
-(defun wisent-get-state (symbol)
- "Find the state we would get to by shifting SYMBOL.
-Return the state number for the state we would get to (from the
-current state) by shifting SYMBOL. Create a new state if no
-equivalent one exists already. Used by `wisent-append-states'."
- (let (key isp1 isp2 iend sp sp2 found n)
- (setq isp1 (aref kernel-base symbol)
- iend (aref kernel-end symbol)
- n (- iend isp1)
- key 0)
- ;; Add up the target state's active item numbers to get a hash key
- (while (< isp1 iend)
- (setq key (+ key (aref kernel-items isp1))
- isp1 (1+ isp1)))
- (setq key (% key wisent-state-table-size)
- sp (aref state-table key))
- (if sp
- (progn
- (setq found nil)
- (while (not found)
- (when (= (core-nitems sp) n)
- (setq found t
- isp1 (aref kernel-base symbol)
- ;; isp2 = sp->items;
- sp2 (core-items sp)
- isp2 0)
-
- (while (and found (< isp1 iend))
- ;; if (*isp1++ != *isp2++)
- (if (not (= (aref kernel-items isp1)
- (aref sp2 isp2)))
- (setq found nil))
- (setq isp1 (1+ isp1)
- isp2 (1+ isp2))))
- (if (not found)
- (if (core-link sp)
- (setq sp (core-link sp))
- ;; sp = sp->link = new-state(symbol)
- (setq sp (setf (core-link sp) (wisent-new-state symbol))
- found t)))))
- ;; bucket is empty
- ;; state-table[key] = sp = new-state(symbol)
- (setq sp (wisent-new-state symbol))
- (aset state-table key sp))
- ;; return (sp->number);
- (core-number sp)))
-
-(defun wisent-append-states ()
- "Find or create the core structures for states.
-Use the information computed by `wisent-new-itemsets' to find the
-state numbers reached by each shift transition from the current state.
-SHIFTSET is set up as a vector of state numbers of those states."
- (let (i j symbol)
- ;; First sort shift-symbol into increasing order
- (setq i 1)
- (while (< i nshifts)
- (setq symbol (aref shift-symbol i)
- j i)
- (while (and (> j 0) (> (aref shift-symbol (1- j)) symbol))
- (aset shift-symbol j (aref shift-symbol (1- j)))
- (setq j (1- j)))
- (aset shift-symbol j symbol)
- (setq i (1+ i)))
- (setq i 0)
- (while (< i nshifts)
- (setq symbol (aref shift-symbol i))
- (aset shiftset i (wisent-get-state symbol))
- (setq i (1+ i)))
- ))
-
-(defun wisent-initialize-states ()
- "Initialize states."
- (let ((p (make-core)))
- (setq first-state p
- last-state p
- this-state p
- nstates 1)))
-
-(defun wisent-save-shifts ()
- "Save the NSHIFTS of SHIFTSET into the current linked list."
- (let (p i shifts)
- (setq p (make-shifts)
- shifts (make-vector nshifts 0)
- i 0)
- (setf (shifts-number p) (core-number this-state))
- (setf (shifts-nshifts p) nshifts)
- (setf (shifts-shifts p) shifts)
- (while (< i nshifts)
- ;; (p->shifts)[i] = shiftset[i];
- (aset shifts i (aref shiftset i))
- (setq i (1+ i)))
-
- (setf (if last-shift
- (shifts-next last-shift)
- first-shift)
- p)
- (setq last-shift p)))
-
-(defun wisent-insert-start-shift ()
- "Create the next-to-final state.
-That is the state to which a shift has already been made in the
-initial state. Subroutine of `wisent-augment-automaton'."
- (let (statep sp)
- (setq statep (make-core))
- (setf (core-number statep) nstates)
- (setf (core-accessing-symbol statep) start-symbol)
- (setf (core-next last-state) statep)
- (setq last-state statep)
- ;; Make a shift from this state to (what will be) the final state.
- (setq sp (make-shifts))
- (setf (shifts-number sp) nstates)
- (setq nstates (1+ nstates))
- (setf (shifts-nshifts sp) 1)
- (setf (shifts-shifts sp) (vector nstates))
- (setf (shifts-next last-shift) sp)
- (setq last-shift sp)))
-
-(defun wisent-augment-automaton ()
- "Set up initial and final states as parser wants them.
-Make sure that the initial state has a shift that accepts the
-grammar's start symbol and goes to the next-to-final state, which has
-a shift going to the final state, which has a shift to the termination
-state. Create such states and shifts if they don't happen to exist
-already."
- (let (i k statep sp sp2 sp1 shifts)
- (setq sp first-shift)
- (if sp
- (progn
- (if (zerop (shifts-number sp))
- (progn
- (setq k (shifts-nshifts sp)
- statep (core-next first-state))
- ;; The states reached by shifts from first-state are
- ;; numbered 1...K. Look for one reached by
- ;; START-SYMBOL.
- (while (and (< (core-accessing-symbol statep) start-symbol)
- (< (core-number statep) k))
- (setq statep (core-next statep)))
- (if (= (core-accessing-symbol statep) start-symbol)
- (progn
- ;; We already have a next-to-final state. Make
- ;; sure it has a shift to what will be the final
- ;; state.
- (setq k (core-number statep))
- (while (and sp (< (shifts-number sp) k))
- (setq sp1 sp
- sp (shifts-next sp)))
- (if (and sp (= (shifts-number sp) k))
- (progn
- (setq i (shifts-nshifts sp)
- sp2 (make-shifts)
- shifts (make-vector (1+ i) 0))
- (setf (shifts-number sp2) k)
- (setf (shifts-nshifts sp2) (1+ i))
- (setf (shifts-shifts sp2) shifts)
- (aset shifts 0 nstates)
- (while (> i 0)
- ;; sp2->shifts[i] = sp->shifts[i - 1];
- (aset shifts i (aref (shifts-shifts sp) (1- i)))
- (setq i (1- i)))
- ;; Patch sp2 into the chain of shifts in
- ;; place of sp, following sp1.
- (setf (shifts-next sp2) (shifts-next sp))
- (setf (shifts-next sp1) sp2)
- (if (eq sp last-shift)
- (setq last-shift sp2))
- )
- (setq sp2 (make-shifts))
- (setf (shifts-number sp2) k)
- (setf (shifts-nshifts sp2) 1)
- (setf (shifts-shifts sp2) (vector nstates))
- ;; Patch sp2 into the chain of shifts between
- ;; sp1 and sp.
- (setf (shifts-next sp2) sp)
- (setf (shifts-next sp1) sp2)
- (if (not sp)
- (setq last-shift sp2))
- )
- )
- ;; There is no next-to-final state as yet.
- ;; Add one more shift in FIRST-SHIFT, going to the
- ;; next-to-final state (yet to be made).
- (setq sp first-shift
- sp2 (make-shifts)
- i (shifts-nshifts sp)
- shifts (make-vector (1+ i) 0))
- (setf (shifts-nshifts sp2) (1+ i))
- (setf (shifts-shifts sp2) shifts)
- ;; Stick this shift into the vector at the proper place.
- (setq statep (core-next first-state)
- k 0
- i 0)
- (while (< i (shifts-nshifts sp))
- (when (and (> (core-accessing-symbol statep) start-symbol)
- (= i k))
- (aset shifts k nstates)
- (setq k (1+ k)))
- (aset shifts k (aref (shifts-shifts sp) i))
- (setq statep (core-next statep))
- (setq i (1+ i)
- k (1+ k)))
- (when (= i k)
- (aset shifts k nstates)
- (setq k (1+ k)))
- ;; Patch sp2 into the chain of shifts in place of
- ;; sp, at the beginning.
- (setf (shifts-next sp2) (shifts-next sp))
- (setq first-shift sp2)
- (if (eq last-shift sp)
- (setq last-shift sp2))
- ;; Create the next-to-final state, with shift to
- ;; what will be the final state.
- (wisent-insert-start-shift)))
- ;; The initial state didn't even have any shifts. Give it
- ;; one shift, to the next-to-final state.
- (setq sp (make-shifts))
- (setf (shifts-nshifts sp) 1)
- (setf (shifts-shifts sp) (vector nstates))
- ;; Patch sp into the chain of shifts at the beginning.
- (setf (shifts-next sp) first-shift)
- (setq first-shift sp)
- ;; Create the next-to-final state, with shift to what will
- ;; be the final state.
- (wisent-insert-start-shift)))
- ;; There are no shifts for any state. Make one shift, from the
- ;; initial state to the next-to-final state.
- (setq sp (make-shifts))
- (setf (shifts-nshifts sp) 1)
- (setf (shifts-shifts sp) (vector nstates))
- ;; Initialize the chain of shifts with sp.
- (setq first-shift sp
- last-shift sp)
- ;; Create the next-to-final state, with shift to what will be
- ;; the final state.
- (wisent-insert-start-shift))
- ;; Make the final state--the one that follows a shift from the
- ;; next-to-final state. The symbol for that shift is 0
- ;; (end-of-file).
- (setq statep (make-core))
- (setf (core-number statep) nstates)
- (setf (core-next last-state) statep)
- (setq last-state statep)
- ;; Make the shift from the final state to the termination state.
- (setq sp (make-shifts))
- (setf (shifts-number sp) nstates)
- (setq nstates (1+ nstates))
- (setf (shifts-nshifts sp) 1)
- (setf (shifts-shifts sp) (vector nstates))
- (setf (shifts-next last-shift) sp)
- (setq last-shift sp)
- ;; Note that the variable FINAL-STATE refers to what we sometimes
- ;; call the termination state.
- (setq final-state nstates)
- ;; Make the termination state.
- (setq statep (make-core))
- (setf (core-number statep) nstates)
- (setq nstates (1+ nstates))
- (setf (core-next last-state) statep)
- (setq last-state statep)))
-
-(defun wisent-save-reductions ()
- "Make a reductions structure.
-Find which rules can be used for reduction transitions from the
-current state and make a reductions structure for the state to record
-their rule numbers."
- (let (i item count p rules)
- ;; Find and count the active items that represent ends of rules.
- (setq count 0
- i 0)
- (while (< i nitemset)
- (setq item (aref ritem (aref itemset i)))
- (when (< item 0)
- (aset redset count (- item))
- (setq count (1+ count)))
- (setq i (1+ i)))
- ;; Make a reductions structure and copy the data into it.
- (when (> count 0)
- (setq p (make-reductions)
- rules (make-vector count 0))
- (setf (reductions-number p) (core-number this-state))
- (setf (reductions-nreds p) count)
- (setf (reductions-rules p) rules)
- (setq i 0)
- (while (< i count)
- ;; (p->rules)[i] = redset[i]
- (aset rules i (aref redset i))
- (setq i (1+ i)))
- (setf (if last-reduction
- (reductions-next last-reduction)
- first-reduction)
- p)
- (setq last-reduction p))))
-
-(defun wisent-generate-states ()
- "Compute the nondeterministic finite state machine from the grammar."
- (wisent-allocate-storage)
- (wisent-initialize-closure nitems)
- (wisent-initialize-states)
- (while this-state
- ;; Set up RULESET and ITEMSET for the transitions out of this
- ;; state. RULESET gets a 1 bit for each rule that could reduce
- ;; now. ITEMSET gets a vector of all the items that could be
- ;; accepted next.
- (wisent-closure (core-items this-state) (core-nitems this-state))
- ;; Record the reductions allowed out of this state.
- (wisent-save-reductions)
- ;; Find the itemsets of the states that shifts can reach.
- (wisent-new-itemsets)
- ;; Find or create the core structures for those states.
- (wisent-append-states)
- ;; Create the shifts structures for the shifts to those states,
- ;; now that the state numbers transitioning to are known.
- (if (> nshifts 0)
- (wisent-save-shifts))
- ;; States are queued when they are created; process them all.
- (setq this-state (core-next this-state)))
- ;; Set up initial and final states as parser wants them.
- (wisent-augment-automaton))
-\f
-;;;; ---------------------------
-;;;; Compute look-ahead criteria
-;;;; ---------------------------
-
-;; Compute how to make the finite state machine deterministic; find
-;; which rules need lookahead in each state, and which lookahead
-;; tokens they accept.
-
-;; `wisent-lalr', the entry point, builds these data structures:
-
-;; GOTO-MAP, FROM-STATE and TO-STATE record each shift transition
-;; which accepts a variable (a nonterminal). NGOTOS is the number of
-;; such transitions.
-;; FROM-STATE[t] is the state number which a transition leads from and
-;; TO-STATE[t] is the state number it leads to.
-;; All the transitions that accept a particular variable are grouped
-;; together and GOTO-MAP[i - NTOKENS] is the index in FROM-STATE and
-;; TO-STATE of the first of them.
-
-;; CONSISTENT[s] is non-nil if no lookahead is needed to decide what
-;; to do in state s.
-
-;; LARULENO is a vector which records the rules that need lookahead in
-;; various states. The elements of LARULENO that apply to state s are
-;; those from LOOKAHEADS[s] through LOOKAHEADS[s+1]-1. Each element
-;; of LARULENO is a rule number.
-
-;; If LR is the length of LARULENO, then a number from 0 to LR-1 can
-;; specify both a rule and a state where the rule might be applied.
-;; LA is a LR by NTOKENS matrix of bits.
-;; LA[l, i] is 1 if the rule LARULENO[l] is applicable in the
-;; appropriate state when the next token is symbol i.
-;; If LA[l, i] and LA[l, j] are both 1 for i != j, it is a conflict.
-
-(wisent-defcontext digraph
- INDEX R VERTICES
- infinity top)
-
-(defun wisent-traverse (i)
- "Traverse I."
- (let (j k height Ri Fi break)
- (setq top (1+ top)
- height top)
- (aset VERTICES top i) ;; VERTICES[++top] = i
- (aset INDEX i top) ;; INDEX[i] = height = top
-
- (setq Ri (aref R i))
- (when Ri
- (setq j 0)
- (while (>= (aref Ri j) 0)
- (if (zerop (aref INDEX (aref Ri j)))
- (wisent-traverse (aref Ri j)))
- ;; if (INDEX[i] > INDEX[R[i][j]])
- (if (> (aref INDEX i) (aref INDEX (aref Ri j)))
- ;; INDEX[i] = INDEX[R[i][j]];
- (aset INDEX i (aref INDEX (aref Ri j))))
- (setq Fi (aref F i)
- k 0)
- (while (< k tokensetsize)
- ;; F (i)[k] |= F (R[i][j])[k];
- (aset Fi k (logior (aref Fi k)
- (aref (aref F (aref Ri j)) k)))
- (setq k (1+ k)))
- (setq j (1+ j))))
-
- (when (= (aref INDEX i) height)
- (setq break nil)
- (while (not break)
- (setq j (aref VERTICES top) ;; j = VERTICES[top--]
- top (1- top))
- (aset INDEX j infinity)
- (if (= i j)
- (setq break t)
- (setq k 0)
- (while (< k tokensetsize)
- ;; F (j)[k] = F (i)[k];
- (aset (aref F j) k (aref (aref F i) k))
- (setq k (1+ k))))))
- ))
-
-(defun wisent-digraph (relation)
- "Digraph RELATION."
- (wisent-with-context digraph
- (setq infinity (+ ngotos 2)
- INDEX (make-vector (1+ ngotos) 0)
- VERTICES (make-vector (1+ ngotos) 0)
- top 0
- R relation)
- (let ((i 0))
- (while (< i ngotos)
- (if (and (= (aref INDEX i) 0) (aref R i))
- (wisent-traverse i))
- (setq i (1+ i))))))
-
-(defun wisent-set-state-table ()
- "Build state table."
- (let (sp)
- (setq state-table (make-vector nstates nil)
- sp first-state)
- (while sp
- (aset state-table (core-number sp) sp)
- (setq sp (core-next sp)))))
-
-(defun wisent-set-accessing-symbol ()
- "Build accessing symbol table."
- (let (sp)
- (setq accessing-symbol (make-vector nstates 0)
- sp first-state)
- (while sp
- (aset accessing-symbol (core-number sp) (core-accessing-symbol sp))
- (setq sp (core-next sp)))))
-
-(defun wisent-set-shift-table ()
- "Build shift table."
- (let (sp)
- (setq shift-table (make-vector nstates nil)
- sp first-shift)
- (while sp
- (aset shift-table (shifts-number sp) sp)
- (setq sp (shifts-next sp)))))
-
-(defun wisent-set-reduction-table ()
- "Build reduction table."
- (let (rp)
- (setq reduction-table (make-vector nstates nil)
- rp first-reduction)
- (while rp
- (aset reduction-table (reductions-number rp) rp)
- (setq rp (reductions-next rp)))))
-
-(defun wisent-set-maxrhs ()
- "Setup MAXRHS length."
- (let (i len max)
- (setq len 0
- max 0
- i 0)
- (while (aref ritem i)
- (if (> (aref ritem i) 0)
- (setq len (1+ len))
- (if (> len max)
- (setq max len))
- (setq len 0))
- (setq i (1+ i)))
- (setq maxrhs max)))
-
-(defun wisent-initialize-LA ()
- "Set up LA."
- (let (i j k count rp sp np v)
- (setq consistent (make-vector nstates nil)
- lookaheads (make-vector (1+ nstates) 0)
- count 0
- i 0)
- (while (< i nstates)
- (aset lookaheads i count)
- (setq rp (aref reduction-table i)
- sp (aref shift-table i))
- ;; if (rp &&
- ;; (rp->nreds > 1
- ;; || (sp && ! ISVAR(accessing-symbol[sp->shifts[0]]))))
- (if (and rp
- (or (> (reductions-nreds rp) 1)
- (and sp
- (not (wisent-ISVAR
- (aref accessing-symbol
- (aref (shifts-shifts sp) 0)))))))
- (setq count (+ count (reductions-nreds rp)))
- (aset consistent i t))
-
- (when sp
- (setq k 0
- j (shifts-nshifts sp)
- v (shifts-shifts sp))
- (while (< k j)
- (when (= (aref accessing-symbol (aref v k))
- error-token-number)
- (aset consistent i nil)
- (setq k j)) ;; break
- (setq k (1+ k))))
- (setq i (1+ i)))
-
- (aset lookaheads nstates count)
-
- (if (zerop count)
- (progn
- (setq LA (make-vector 1 nil)
- LAruleno (make-vector 1 0)
- lookback (make-vector 1 nil)))
- (setq LA (make-vector count nil)
- LAruleno (make-vector count 0)
- lookback (make-vector count nil)))
- (setq i 0 j (length LA))
- (while (< i j)
- (aset LA i (make-vector tokensetsize 0))
- (setq i (1+ i)))
-
- (setq np 0
- i 0)
- (while (< i nstates)
- (when (not (aref consistent i))
- (setq rp (aref reduction-table i))
- (when rp
- (setq j 0
- k (reductions-nreds rp)
- v (reductions-rules rp))
- (while (< j k)
- (aset LAruleno np (aref v j))
- (setq np (1+ np)
- j (1+ j)))))
- (setq i (1+ i)))))
-
-(defun wisent-set-goto-map ()
- "Set up GOTO-MAP."
- (let (sp i j symbol k temp-map state1 state2 v)
- (setq goto-map (make-vector (1+ nvars) 0)
- temp-map (make-vector (1+ nvars) 0))
-
- (setq ngotos 0
- sp first-shift)
- (while sp
- (setq i (1- (shifts-nshifts sp))
- v (shifts-shifts sp))
- (while (>= i 0)
- (setq symbol (aref accessing-symbol (aref v i)))
- (if (wisent-ISTOKEN symbol)
- (setq i 0) ;; break
- (setq ngotos (1+ ngotos))
- ;; goto-map[symbol]++;
- (aset goto-map (- symbol ntokens)
- (1+ (aref goto-map (- symbol ntokens)))))
- (setq i (1- i)))
- (setq sp (shifts-next sp)))
-
- (setq k 0
- i ntokens
- j 0)
- (while (< i nsyms)
- (aset temp-map j k)
- (setq k (+ k (aref goto-map j))
- i (1+ i)
- j (1+ j)))
- (setq i ntokens
- j 0)
- (while (< i nsyms)
- (aset goto-map j (aref temp-map j))
- (setq i (1+ i)
- j (1+ j)))
- ;; goto-map[nsyms] = ngotos;
- ;; temp-map[nsyms] = ngotos;
- (aset goto-map j ngotos)
- (aset temp-map j ngotos)
-
- (setq from-state (make-vector ngotos 0)
- to-state (make-vector ngotos 0)
- sp first-shift)
- (while sp
- (setq state1 (shifts-number sp)
- v (shifts-shifts sp)
- i (1- (shifts-nshifts sp)))
- (while (>= i 0)
- (setq state2 (aref v i)
- symbol (aref accessing-symbol state2))
- (if (wisent-ISTOKEN symbol)
- (setq i 0) ;; break
- ;; k = temp-map[symbol]++;
- (setq k (aref temp-map (- symbol ntokens)))
- (aset temp-map (- symbol ntokens) (1+ k))
- (aset from-state k state1)
- (aset to-state k state2))
- (setq i (1- i)))
- (setq sp (shifts-next sp)))
- ))
-
-(defun wisent-map-goto (state symbol)
- "Map a STATE/SYMBOL pair into its numeric representation."
- (let (high low middle s result)
- ;; low = goto-map[symbol];
- ;; high = goto-map[symbol + 1] - 1;
- (setq low (aref goto-map (- symbol ntokens))
- high (1- (aref goto-map (- (1+ symbol) ntokens))))
- (while (and (not result) (<= low high))
- (setq middle (/ (+ low high) 2)
- s (aref from-state middle))
- (cond
- ((= s state)
- (setq result middle))
- ((< s state)
- (setq low (1+ middle)))
- (t
- (setq high (1- middle)))))
- (or result
- (error "Internal error in `wisent-map-goto'"))
- ))
-
-(defun wisent-initialize-F ()
- "Set up F."
- (let (i j k sp edge rowp rp reads nedges stateno symbol v break)
- (setq F (make-vector ngotos nil)
- i 0)
- (while (< i ngotos)
- (aset F i (make-vector tokensetsize 0))
- (setq i (1+ i)))
-
- (setq reads (make-vector ngotos nil)
- edge (make-vector (1+ ngotos) 0)
- nedges 0
- rowp 0 ;; rowp = F
- i 0)
- (while (< i ngotos)
- (setq stateno (aref to-state i)
- sp (aref shift-table stateno))
- (when sp
- (setq k (shifts-nshifts sp)
- v (shifts-shifts sp)
- j 0
- break nil)
- (while (and (not break) (< j k))
- ;; symbol = accessing-symbol[sp->shifts[j]];
- (setq symbol (aref accessing-symbol (aref v j)))
- (if (wisent-ISVAR symbol)
- (setq break t) ;; break
- (wisent-SETBIT (aref F rowp) symbol)
- (setq j (1+ j))))
-
- (while (< j k)
- ;; symbol = accessing-symbol[sp->shifts[j]];
- (setq symbol (aref accessing-symbol (aref v j)))
- (when (aref nullable (- symbol ntokens))
- (aset edge nedges (wisent-map-goto stateno symbol))
- (setq nedges (1+ nedges)))
- (setq j (1+ j)))
-
- (when (> nedges 0)
- ;; reads[i] = rp = NEW2(nedges + 1, short);
- (setq rp (make-vector (1+ nedges) 0)
- j 0)
- (aset reads i rp)
- (while (< j nedges)
- ;; rp[j] = edge[j];
- (aset rp j (aref edge j))
- (setq j (1+ j)))
- (aset rp nedges -1)
- (setq nedges 0)))
- (setq rowp (1+ rowp))
- (setq i (1+ i)))
- (wisent-digraph reads)
- ))
-
-(defun wisent-add-lookback-edge (stateno ruleno gotono)
- "Add a lookback edge.
-STATENO, RULENO, GOTONO are self-explanatory."
- (let (i k found)
- (setq i (aref lookaheads stateno)
- k (aref lookaheads (1+ stateno))
- found nil)
- (while (and (not found) (< i k))
- (if (= (aref LAruleno i) ruleno)
- (setq found t)
- (setq i (1+ i))))
-
- (or found
- (error "Internal error in `wisent-add-lookback-edge'"))
-
- ;; value . next
- ;; lookback[i] = (gotono . lookback[i])
- (aset lookback i (cons gotono (aref lookback i)))))
-
-(defun wisent-transpose (R-arg n)
- "Return the transpose of R-ARG, of size N.
-Destroy R-ARG, as it is replaced with the result. R-ARG[I] is nil or
-a -1 terminated list of numbers. RESULT[NUM] is nil or the -1
-terminated list of the I such as NUM is in R-ARG[I]."
- (let (i j new-R end-R nedges v sp)
- (setq new-R (make-vector n nil)
- end-R (make-vector n nil)
- nedges (make-vector n 0))
-
- ;; Count.
- (setq i 0)
- (while (< i n)
- (setq v (aref R-arg i))
- (when v
- (setq j 0)
- (while (>= (aref v j) 0)
- (aset nedges (aref v j) (1+ (aref nedges (aref v j))))
- (setq j (1+ j))))
- (setq i (1+ i)))
-
- ;; Allocate.
- (setq i 0)
- (while (< i n)
- (when (> (aref nedges i) 0)
- (setq sp (make-vector (1+ (aref nedges i)) 0))
- (aset sp (aref nedges i) -1)
- (aset new-R i sp)
- (aset end-R i 0))
- (setq i (1+ i)))
-
- ;; Store.
- (setq i 0)
- (while (< i n)
- (setq v (aref R-arg i))
- (when v
- (setq j 0)
- (while (>= (aref v j) 0)
- (aset (aref new-R (aref v j)) (aref end-R (aref v j)) i)
- (aset end-R (aref v j) (1+ (aref end-R (aref v j))))
- (setq j (1+ j))))
- (setq i (1+ i)))
-
- new-R))
-
-(defun wisent-build-relations ()
- "Build relations."
- (let (i j k rulep rp sp length nedges done state1 stateno
- symbol1 symbol2 edge states v)
- (setq includes (make-vector ngotos nil)
- edge (make-vector (1+ ngotos) 0)
- states (make-vector (1+ maxrhs) 0)
- i 0)
-
- (while (< i ngotos)
- (setq nedges 0
- state1 (aref from-state i)
- symbol1 (aref accessing-symbol (aref to-state i))
- rulep (aref derives (- symbol1 ntokens)))
-
- (while (> (car rulep) 0)
- (aset states 0 state1)
- (setq length 1
- stateno state1
- rp (aref rrhs (car rulep))) ;; rp = ritem + rrhs[*rulep]
- (while (> (aref ritem rp) 0) ;; *rp > 0
- (setq symbol2 (aref ritem rp)
- sp (aref shift-table stateno)
- k (shifts-nshifts sp)
- v (shifts-shifts sp)
- j 0)
- (while (< j k)
- (setq stateno (aref v j))
- (if (= (aref accessing-symbol stateno) symbol2)
- (setq j k) ;; break
- (setq j (1+ j))))
- ;; states[length++] = stateno;
- (aset states length stateno)
- (setq length (1+ length))
- (setq rp (1+ rp)))
-
- (if (not (aref consistent stateno))
- (wisent-add-lookback-edge stateno (car rulep) i))
-
- (setq length (1- length)
- done nil)
- (while (not done)
- (setq done t
- rp (1- rp))
- (when (and (>= rp 0) (wisent-ISVAR (aref ritem rp)))
- ;; stateno = states[--length];
- (setq length (1- length)
- stateno (aref states length))
- (aset edge nedges (wisent-map-goto stateno (aref ritem rp)))
- (setq nedges (1+ nedges))
- (if (aref nullable (- (aref ritem rp) ntokens))
- (setq done nil))))
- (setq rulep (cdr rulep)))
-
- (when (> nedges 0)
- (setq v (make-vector (1+ nedges) 0)
- j 0)
- (aset includes i v)
- (while (< j nedges)
- (aset v j (aref edge j))
- (setq j (1+ j)))
- (aset v nedges -1))
- (setq i (1+ i)))
-
- (setq includes (wisent-transpose includes ngotos))
- ))
-
-(defun wisent-compute-FOLLOWS ()
- "Compute follows."
- (wisent-digraph includes))
-
-(defun wisent-compute-lookaheads ()
- "Compute lookaheads."
- (let (i j n v1 v2 sp)
- (setq n (aref lookaheads nstates)
- i 0)
- (while (< i n)
- (setq sp (aref lookback i))
- (while sp
- (setq v1 (aref LA i)
- v2 (aref F (car sp))
- j 0)
- (while (< j tokensetsize)
- ;; LA (i)[j] |= F (sp->value)[j]
- (aset v1 j (logior (aref v1 j) (aref v2 j)))
- (setq j (1+ j)))
- (setq sp (cdr sp)))
- (setq i (1+ i)))))
-
-(defun wisent-lalr ()
- "Make the nondeterministic finite state machine deterministic."
- (setq tokensetsize (wisent-WORDSIZE ntokens))
- (wisent-set-state-table)
- (wisent-set-accessing-symbol)
- (wisent-set-shift-table)
- (wisent-set-reduction-table)
- (wisent-set-maxrhs)
- (wisent-initialize-LA)
- (wisent-set-goto-map)
- (wisent-initialize-F)
- (wisent-build-relations)
- (wisent-compute-FOLLOWS)
- (wisent-compute-lookaheads))
-\f
-;;;; -----------------------------------------------
-;;;; Find and resolve or report look-ahead conflicts
-;;;; -----------------------------------------------
-
-(defsubst wisent-log-resolution (state LAno token resolution)
- "Log a shift-reduce conflict resolution.
-In specified STATE between rule pointed by lookahead number LANO and
-TOKEN, resolved as RESOLUTION."
- (if (or wisent-verbose-flag wisent-debug-flag)
- (wisent-log
- "Conflict in state %d between rule %d and token %s resolved as %s.\n"
- state (aref LAruleno LAno) (wisent-tag token) resolution)))
-
-(defun wisent-flush-shift (state token)
- "Turn off the shift recorded in the specified STATE for TOKEN.
-Used when we resolve a shift-reduce conflict in favor of the reduction."
- (let (shiftp i k v)
- (when (setq shiftp (aref shift-table state))
- (setq k (shifts-nshifts shiftp)
- v (shifts-shifts shiftp)
- i 0)
- (while (< i k)
- (if (and (not (zerop (aref v i)))
- (= token (aref accessing-symbol (aref v i))))
- (aset v i 0))
- (setq i (1+ i))))))
-
-(defun wisent-resolve-sr-conflict (state lookaheadnum)
- "Attempt to resolve shift-reduce conflict for one rule.
-Resolve by means of precedence declarations. The conflict occurred in
-specified STATE for the rule pointed by the lookahead symbol
-LOOKAHEADNUM. It has already been checked that the rule has a
-precedence. A conflict is resolved by modifying the shift or reduce
-tables so that there is no longer a conflict."
- (let (i redprec errp errs nerrs token sprec sassoc)
- ;; Find the rule to reduce by to get precedence of reduction
- (setq token (aref tags (aref rprec (aref LAruleno lookaheadnum)))
- redprec (wisent-prec token)
- errp (make-errs)
- errs (make-vector ntokens 0)
- nerrs 0
- i 0)
- (setf (errs-errs errp) errs)
- (while (< i ntokens)
- (setq token (aref tags i))
- (when (and (wisent-BITISSET (aref LA lookaheadnum) i)
- (wisent-BITISSET lookaheadset i)
- (setq sprec (wisent-prec token)))
- ;; Shift-reduce conflict occurs for token number I and it has
- ;; a precedence. The precedence of shifting is that of token
- ;; I.
- (cond
- ((< sprec redprec)
- (wisent-log-resolution state lookaheadnum i "reduce")
- ;; Flush the shift for this token
- (wisent-RESETBIT lookaheadset i)
- (wisent-flush-shift state i)
- )
- ((> sprec redprec)
- (wisent-log-resolution state lookaheadnum i "shift")
- ;; Flush the reduce for this token
- (wisent-RESETBIT (aref LA lookaheadnum) i)
- )
- (t
- ;; Matching precedence levels.
- ;; For left association, keep only the reduction.
- ;; For right association, keep only the shift.
- ;; For nonassociation, keep neither.
- (setq sassoc (wisent-assoc token))
- (cond
- ((eq sassoc 'right)
- (wisent-log-resolution state lookaheadnum i "shift"))
- ((eq sassoc 'left)
- (wisent-log-resolution state lookaheadnum i "reduce"))
- ((eq sassoc 'nonassoc)
- (wisent-log-resolution state lookaheadnum i "an error"))
- )
- (when (not (eq sassoc 'right))
- ;; Flush the shift for this token
- (wisent-RESETBIT lookaheadset i)
- (wisent-flush-shift state i))
- (when (not (eq sassoc 'left))
- ;; Flush the reduce for this token
- (wisent-RESETBIT (aref LA lookaheadnum) i))
- (when (eq sassoc 'nonassoc)
- ;; Record an explicit error for this token
- (aset errs nerrs i)
- (setq nerrs (1+ nerrs)))
- )))
- (setq i (1+ i)))
- (when (> nerrs 0)
- (setf (errs-nerrs errp) nerrs)
- (aset err-table state errp))
- ))
-
-(defun wisent-set-conflicts (state)
- "Find and attempt to resolve conflicts in specified STATE."
- (let (i j k v shiftp symbol)
- (unless (aref consistent state)
- (fillarray lookaheadset 0)
-
- (when (setq shiftp (aref shift-table state))
- (setq k (shifts-nshifts shiftp)
- v (shifts-shifts shiftp)
- i 0)
- (while (and (< i k)
- (wisent-ISTOKEN
- (setq symbol (aref accessing-symbol (aref v i)))))
- (or (zerop (aref v i))
- (wisent-SETBIT lookaheadset symbol))
- (setq i (1+ i))))
-
- ;; Loop over all rules which require lookahead in this state
- ;; first check for shift-reduce conflict, and try to resolve
- ;; using precedence
- (setq i (aref lookaheads state)
- k (aref lookaheads (1+ state)))
- (while (< i k)
- (when (aref rprec (aref LAruleno i))
- (setq v (aref LA i)
- j 0)
- (while (< j tokensetsize)
- (if (zerop (logand (aref v j) (aref lookaheadset j)))
- (setq j (1+ j))
- ;; if (LA (i)[j] & lookaheadset[j])
- (wisent-resolve-sr-conflict state i)
- (setq j tokensetsize)))) ;; break
- (setq i (1+ i)))
-
- ;; Loop over all rules which require lookahead in this state
- ;; Check for conflicts not resolved above.
- (setq i (aref lookaheads state))
- (while (< i k)
- (setq v (aref LA i)
- j 0)
- (while (< j tokensetsize)
- ;; if (LA (i)[j] & lookaheadset[j])
- (if (not (zerop (logand (aref v j) (aref lookaheadset j))))
- (aset conflicts state t))
- (setq j (1+ j)))
- (setq j 0)
- (while (< j tokensetsize)
- ;; lookaheadset[j] |= LA (i)[j];
- (aset lookaheadset j (logior (aref lookaheadset j)
- (aref v j)))
- (setq j (1+ j)))
- (setq i (1+ i)))
- )))
-
-(defun wisent-resolve-conflicts ()
- "Find and resolve conflicts."
- (let (i)
- (setq conflicts (make-vector nstates nil)
- shiftset (make-vector tokensetsize 0)
- lookaheadset (make-vector tokensetsize 0)
- err-table (make-vector nstates nil)
- i 0)
- (while (< i nstates)
- (wisent-set-conflicts i)
- (setq i (1+ i)))))
-
-(defun wisent-count-sr-conflicts (state)
- "Count the number of shift/reduce conflicts in specified STATE."
- (let (i j k shiftp symbol v)
- (setq src-count 0
- shiftp (aref shift-table state))
- (when shiftp
- (fillarray shiftset 0)
- (fillarray lookaheadset 0)
- (setq k (shifts-nshifts shiftp)
- v (shifts-shifts shiftp)
- i 0)
- (while (< i k)
- (when (not (zerop (aref v i)))
- (setq symbol (aref accessing-symbol (aref v i)))
- (if (wisent-ISVAR symbol)
- (setq i k) ;; break
- (wisent-SETBIT shiftset symbol)))
- (setq i (1+ i)))
-
- (setq k (aref lookaheads (1+ state))
- i (aref lookaheads state))
- (while (< i k)
- (setq v (aref LA i)
- j 0)
- (while (< j tokensetsize)
- ;; lookaheadset[j] |= LA (i)[j]
- (aset lookaheadset j (logior (aref lookaheadset j)
- (aref v j)))
- (setq j (1+ j)))
- (setq i (1+ i)))
-
- (setq k 0)
- (while (< k tokensetsize)
- ;; lookaheadset[k] &= shiftset[k];
- (aset lookaheadset k (logand (aref lookaheadset k)
- (aref shiftset k)))
- (setq k (1+ k)))
-
- (setq i 0)
- (while (< i ntokens)
- (if (wisent-BITISSET lookaheadset i)
- (setq src-count (1+ src-count)))
- (setq i (1+ i))))
- src-count))
-
-(defun wisent-count-rr-conflicts (state)
- "Count the number of reduce/reduce conflicts in specified STATE."
- (let (i j count n m)
- (setq rrc-count 0
- m (aref lookaheads state)
- n (aref lookaheads (1+ state)))
- (when (>= (- n m) 2)
- (setq i 0)
- (while (< i ntokens)
- (setq count 0
- j m)
- (while (< j n)
- (if (wisent-BITISSET (aref LA j) i)
- (setq count (1+ count)))
- (setq j (1+ j)))
-
- (if (>= count 2)
- (setq rrc-count (1+ rrc-count)))
- (setq i (1+ i))))
- rrc-count))
-
-(defcustom wisent-expected-conflicts nil
- "If non-nil suppress the warning about shift/reduce conflicts.
-It is a decimal integer N that says there should be no warning if
-there are N shift/reduce conflicts and no reduce/reduce conflicts. A
-warning is given if there are either more or fewer conflicts, or if
-there are any reduce/reduce conflicts."
- :group 'wisent
- :type '(choice (const nil) integer))
-(make-obsolete-variable 'wisent-expected-conflicts
- "use %expectedconflicts in the .wy file instead"
- "27.1")
-
-(defun wisent-total-conflicts ()
- "Report the total number of conflicts."
- (let* ((src (wisent-source))
- (symbol
- ;; Source files may specify how many expected conflicts
- ;; there are. If the number is the expected number, don't
- ;; output warnings.
- (and src
- (intern (format "wisent-%s--expected-conflicts"
- (replace-regexp-in-string "\\.el\\'" "" src))))))
- (when (or (not (zerop rrc-total))
- (and (not (zerop src-total))
- (not (= src-total (or wisent-expected-conflicts 0)))
- (or (null symbol)
- (not (boundp symbol))
- (not (equal (symbol-value symbol) src-total)))))
- (let* ((src (if src (concat " in " src) ""))
- (msg (format "Grammar%s contains" src)))
- (when (and (> src-total 0))
- (setq msg (format "%s %d shift/reduce conflict%s"
- msg src-total (if (> src-total 1)
- "s" ""))))
- (if (and (> src-total 0) (> rrc-total 0))
- (setq msg (format "%s and" msg)))
- (if (> rrc-total 0)
- (setq msg (format "%s %d reduce/reduce conflict%s"
- msg rrc-total (if (> rrc-total 1)
- "s" ""))))
- (message msg)))))
-
-(defun wisent-print-conflicts ()
- "Report conflicts."
- (let (i)
- (setq src-total 0
- rrc-total 0
- i 0)
- (while (< i nstates)
- (when (aref conflicts i)
- (wisent-count-sr-conflicts i)
- (wisent-count-rr-conflicts i)
- (setq src-total (+ src-total src-count)
- rrc-total (+ rrc-total rrc-count))
- (when (or wisent-verbose-flag wisent-debug-flag)
- (wisent-log "State %d contains" i)
- (if (> src-count 0)
- (wisent-log " %d shift/reduce conflict%s"
- src-count (if (> src-count 1) "s" "")))
-
- (if (and (> src-count 0) (> rrc-count 0))
- (wisent-log " and"))
-
- (if (> rrc-count 0)
- (wisent-log " %d reduce/reduce conflict%s"
- rrc-count (if (> rrc-count 1) "s" "")))
-
- (wisent-log ".\n")))
- (setq i (1+ i)))
- (wisent-total-conflicts)))
-\f
-;;;; --------------------------------------
-;;;; Report information on generated parser
-;;;; --------------------------------------
-(defun wisent-print-grammar ()
- "Print grammar."
- (let (i j r break left-count right-count)
-
- (wisent-log "\n\nGrammar\n\n Number, Rule\n")
- (setq i 1)
- (while (<= i nrules)
- ;; Don't print rules disabled in `wisent-reduce-grammar-tables'.
- (when (aref ruseful i)
- (wisent-log " %s %s ->"
- (string-pad (number-to-string i) 6)
- (wisent-tag (aref rlhs i)))
- (setq r (aref rrhs i))
- (if (> (aref ritem r) 0)
- (while (> (aref ritem r) 0)
- (wisent-log " %s" (wisent-tag (aref ritem r)))
- (setq r (1+ r)))
- (wisent-log " /* empty */"))
- (wisent-log "\n"))
- (setq i (1+ i)))
-
- (wisent-log "\n\nTerminals, with rules where they appear\n\n")
- (wisent-log "%s (-1)\n" (wisent-tag 0))
- (setq i 1)
- (while (< i ntokens)
- (wisent-log "%s (%d)" (wisent-tag i) i)
- (setq j 1)
- (while (<= j nrules)
- (setq r (aref rrhs j)
- break nil)
- (while (and (not break) (> (aref ritem r) 0))
- (if (setq break (= (aref ritem r) i))
- (wisent-log " %d" j)
- (setq r (1+ r))))
- (setq j (1+ j)))
- (wisent-log "\n")
- (setq i (1+ i)))
-
- (wisent-log "\n\nNonterminals, with rules where they appear\n\n")
- (setq i ntokens)
- (while (< i nsyms)
- (setq left-count 0
- right-count 0
- j 1)
- (while (<= j nrules)
- (if (= (aref rlhs j) i)
- (setq left-count (1+ left-count)))
- (setq r (aref rrhs j)
- break nil)
- (while (and (not break) (> (aref ritem r) 0))
- (if (= (aref ritem r) i)
- (setq right-count (1+ right-count)
- break t)
- (setq r (1+ r))))
- (setq j (1+ j)))
- (wisent-log "%s (%d)\n " (wisent-tag i) i)
- (when (> left-count 0)
- (wisent-log " on left:")
- (setq j 1)
- (while (<= j nrules)
- (if (= (aref rlhs j) i)
- (wisent-log " %d" j))
- (setq j (1+ j))))
- (when (> right-count 0)
- (if (> left-count 0)
- (wisent-log ","))
- (wisent-log " on right:")
- (setq j 1)
- (while (<= j nrules)
- (setq r (aref rrhs j)
- break nil)
- (while (and (not break) (> (aref ritem r) 0))
- (if (setq break (= (aref ritem r) i))
- (wisent-log " %d" j)
- (setq r (1+ r))))
- (setq j (1+ j))))
- (wisent-log "\n")
- (setq i (1+ i)))
- ))
-
-(defun wisent-print-reductions (state)
- "Print reductions on STATE."
- (let (i j k v symbol m n defaulted
- default-LA default-rule cmax count shiftp errp nodefault)
- (setq nodefault nil
- i 0)
- (fillarray shiftset 0)
-
- (setq shiftp (aref shift-table state))
- (when shiftp
- (setq k (shifts-nshifts shiftp)
- v (shifts-shifts shiftp)
- i 0)
- (while (< i k)
- (when (not (zerop (aref v i)))
- (setq symbol (aref accessing-symbol (aref v i)))
- (if (wisent-ISVAR symbol)
- (setq i k) ;; break
- ;; If this state has a shift for the error token, don't
- ;; use a default rule.
- (if (= symbol error-token-number)
- (setq nodefault t))
- (wisent-SETBIT shiftset symbol)))
- (setq i (1+ i))))
-
- (setq errp (aref err-table state))
- (when errp
- (setq k (errs-nerrs errp)
- v (errs-errs errp)
- i 0)
- (while (< i k)
- (if (not (zerop (setq symbol (aref v i))))
- (wisent-SETBIT shiftset symbol))
- (setq i (1+ i))))
-
- (setq m (aref lookaheads state)
- n (aref lookaheads (1+ state)))
-
- (cond
- ((and (= (- n m) 1) (not nodefault))
- (setq default-rule (aref LAruleno m)
- v (aref LA m)
- k 0)
- (while (< k tokensetsize)
- (aset lookaheadset k (logand (aref v k)
- (aref shiftset k)))
- (setq k (1+ k)))
-
- (setq i 0)
- (while (< i ntokens)
- (if (wisent-BITISSET lookaheadset i)
- (wisent-log " %s\t[reduce using rule %d (%s)]\n"
- (wisent-tag i) default-rule
- (wisent-tag (aref rlhs default-rule))))
- (setq i (1+ i)))
- (wisent-log " $default\treduce using rule %d (%s)\n\n"
- default-rule
- (wisent-tag (aref rlhs default-rule)))
- )
- ((>= (- n m) 1)
- (setq cmax 0
- default-LA -1
- default-rule 0)
- (when (not nodefault)
- (setq i m)
- (while (< i n)
- (setq v (aref LA i)
- count 0
- k 0)
- (while (< k tokensetsize)
- ;; lookaheadset[k] = LA (i)[k] & ~shiftset[k]
- (aset lookaheadset k
- (logand (aref v k)
- (lognot (aref shiftset k))))
- (setq k (1+ k)))
- (setq j 0)
- (while (< j ntokens)
- (if (wisent-BITISSET lookaheadset j)
- (setq count (1+ count)))
- (setq j (1+ j)))
- (if (> count cmax)
- (setq cmax count
- default-LA i
- default-rule (aref LAruleno i)))
- (setq k 0)
- (while (< k tokensetsize)
- (aset shiftset k (logior (aref shiftset k)
- (aref lookaheadset k)))
- (setq k (1+ k)))
- (setq i (1+ i))))
-
- (fillarray shiftset 0)
-
- (when shiftp
- (setq k (shifts-nshifts shiftp)
- v (shifts-shifts shiftp)
- i 0)
- (while (< i k)
- (when (not (zerop (aref v i)))
- (setq symbol (aref accessing-symbol (aref v i)))
- (if (wisent-ISVAR symbol)
- (setq i k) ;; break
- (wisent-SETBIT shiftset symbol)))
- (setq i (1+ i))))
-
- (setq i 0)
- (while (< i ntokens)
- (setq defaulted nil
- count (if (wisent-BITISSET shiftset i) 1 0)
- j m)
- (while (< j n)
- (when (wisent-BITISSET (aref LA j) i)
- (if (zerop count)
- (progn
- (if (not (= j default-LA))
- (wisent-log
- " %s\treduce using rule %d (%s)\n"
- (wisent-tag i) (aref LAruleno j)
- (wisent-tag (aref rlhs (aref LAruleno j))))
- (setq defaulted t))
- (setq count (1+ count)))
- (if defaulted
- (wisent-log
- " %s\treduce using rule %d (%s)\n"
- (wisent-tag i) (aref LAruleno default-LA)
- (wisent-tag (aref rlhs (aref LAruleno default-LA)))))
- (setq defaulted nil)
- (wisent-log
- " %s\t[reduce using rule %d (%s)]\n"
- (wisent-tag i) (aref LAruleno j)
- (wisent-tag (aref rlhs (aref LAruleno j))))))
- (setq j (1+ j)))
- (setq i (1+ i)))
-
- (if (>= default-LA 0)
- (wisent-log
- " $default\treduce using rule %d (%s)\n"
- default-rule
- (wisent-tag (aref rlhs default-rule))))
- ))))
-
-(defun wisent-print-actions (state)
- "Print actions on STATE."
- (let (i j k v state1 symbol shiftp errp redp rule nerrs break)
- (setq shiftp (aref shift-table state)
- redp (aref reduction-table state)
- errp (aref err-table state))
- (if (and (not shiftp) (not redp))
- (if (= final-state state)
- (wisent-log " $default\taccept\n")
- (wisent-log " NO ACTIONS\n"))
- (if (not shiftp)
- (setq i 0
- k 0)
- (setq k (shifts-nshifts shiftp)
- v (shifts-shifts shiftp)
- i 0
- break nil)
- (while (and (not break) (< i k))
- (if (zerop (setq state1 (aref v i)))
- (setq i (1+ i))
- (setq symbol (aref accessing-symbol state1))
- ;; The following line used to be turned off.
- (if (wisent-ISVAR symbol)
- (setq break t) ;; break
- (wisent-log " %s\tshift, and go to state %d\n"
- (wisent-tag symbol) state1)
- (setq i (1+ i)))))
- (if (> i 0)
- (wisent-log "\n")))
-
- (when errp
- (setq nerrs (errs-nerrs errp)
- v (errs-errs errp)
- j 0)
- (while (< j nerrs)
- (if (aref v j)
- (wisent-log " %s\terror (nonassociative)\n"
- (wisent-tag (aref v j))))
- (setq j (1+ j)))
- (if (> j 0)
- (wisent-log "\n")))
-
- (cond
- ((and (aref consistent state) redp)
- (setq rule (aref (reductions-rules redp) 0)
- symbol (aref rlhs rule))
- (wisent-log " $default\treduce using rule %d (%s)\n\n"
- rule (wisent-tag symbol))
- )
- (redp
- (wisent-print-reductions state)
- ))
-
- (when (< i k)
- (setq v (shifts-shifts shiftp))
- (while (< i k)
- (when (setq state1 (aref v i))
- (setq symbol (aref accessing-symbol state1))
- (wisent-log " %s\tgo to state %d\n"
- (wisent-tag symbol) state1))
- (setq i (1+ i)))
- (wisent-log "\n"))
- )))
-
-(defun wisent-print-core (state)
- "Print STATE core."
- (let (i k rule statep sp sp1)
- (setq statep (aref state-table state)
- k (core-nitems statep))
- (when (> k 0)
- (setq i 0)
- (while (< i k)
- ;; sp1 = sp = ritem + statep->items[i];
- (setq sp1 (aref (core-items statep) i)
- sp sp1)
- (while (> (aref ritem sp) 0)
- (setq sp (1+ sp)))
-
- (setq rule (- (aref ritem sp)))
- (wisent-log " %s -> " (wisent-tag (aref rlhs rule)))
-
- (setq sp (aref rrhs rule))
- (while (< sp sp1)
- (wisent-log "%s " (wisent-tag (aref ritem sp)))
- (setq sp (1+ sp)))
- (wisent-log ".")
- (while (> (aref ritem sp) 0)
- (wisent-log " %s" (wisent-tag (aref ritem sp)))
- (setq sp (1+ sp)))
- (wisent-log " (rule %d)\n" rule)
- (setq i (1+ i)))
- (wisent-log "\n"))))
-
-(defun wisent-print-state (state)
- "Print information on STATE."
- (wisent-log "\n\nstate %d\n\n" state)
- (wisent-print-core state)
- (wisent-print-actions state))
-
-(defun wisent-print-states ()
- "Print information on states."
- (let ((i 0))
- (while (< i nstates)
- (wisent-print-state i)
- (setq i (1+ i)))))
-
-(defun wisent-print-results ()
- "Print information on generated parser.
-Report detailed information if `wisent-verbose-flag' or
-`wisent-debug-flag' are non-nil."
- (when (or wisent-verbose-flag wisent-debug-flag)
- (wisent-print-useless))
- (wisent-print-conflicts)
- (when (or wisent-verbose-flag wisent-debug-flag)
- (wisent-print-grammar)
- (wisent-print-states))
- ;; Append output to log file when running in batch mode
- (when noninteractive
- (wisent-append-to-log-file)
- (wisent-clear-log)))
-\f
-;;;; ---------------------------------
-;;;; Build the generated parser tables
-;;;; ---------------------------------
-
-(defun wisent-action-row (state actrow)
- "Figure out the actions for the specified STATE.
-Decide what to do for each type of token if seen as the lookahead
-token in specified state. The value returned is used as the default
-action for the state. In addition, ACTROW is filled with what to do
-for each kind of token, index by symbol number, with nil meaning do
-the default action. The value `error', means this situation is an
-error. The parser recognizes this value specially.
-
-This is where conflicts are resolved. The loop over lookahead rules
-considered lower-numbered rules last, and the last rule considered
-that likes a token gets to handle it."
- (let (i j k m n v default-rule nreds rule max count
- shift-state symbol redp shiftp errp nodefault)
-
- (fillarray actrow nil)
-
- (setq default-rule 0
- nodefault nil ;; nil inhibit having any default reduction
- nreds 0
- m 0
- n 0
- redp (aref reduction-table state))
-
- (when redp
- (setq nreds (reductions-nreds redp))
- (when (>= nreds 1)
- ;; loop over all the rules available here which require
- ;; lookahead
- (setq m (aref lookaheads state)
- n (aref lookaheads (1+ state))
- i (1- n))
- (while (>= i m)
- ;; and find each token which the rule finds acceptable to
- ;; come next
- (setq j 0)
- (while (< j ntokens)
- ;; and record this rule as the rule to use if that token
- ;; follows.
- (if (wisent-BITISSET (aref LA i) j)
- (aset actrow j (- (aref LAruleno i)))
- )
- (setq j (1+ j)))
- (setq i (1- i)))))
-
- ;; Now see which tokens are allowed for shifts in this state. For
- ;; them, record the shift as the thing to do. So shift is
- ;; preferred to reduce.
- (setq shiftp (aref shift-table state))
- (when shiftp
- (setq k (shifts-nshifts shiftp)
- v (shifts-shifts shiftp)
- i 0)
- (while (< i k)
- (setq shift-state (aref v i))
- (if (zerop shift-state)
- nil ;; continue
- (setq symbol (aref accessing-symbol shift-state))
- (if (wisent-ISVAR symbol)
- (setq i k) ;; break
- (aset actrow symbol shift-state)
- ;; Do not use any default reduction if there is a shift
- ;; for error
- (if (= symbol error-token-number)
- (setq nodefault t))))
- (setq i (1+ i))))
-
- ;; See which tokens are an explicit error in this state (due to
- ;; %nonassoc). For them, record error as the action.
- (setq errp (aref err-table state))
- (when errp
- (setq k (errs-nerrs errp)
- v (errs-errs errp)
- i 0)
- (while (< i k)
- (aset actrow (aref v i) wisent-error-tag)
- (setq i (1+ i))))
-
- ;; Now find the most common reduction and make it the default
- ;; action for this state.
- (when (and (>= nreds 1) (not nodefault))
- (if (aref consistent state)
- (setq default-rule (- (aref (reductions-rules redp) 0)))
- (setq max 0
- i m)
- (while (< i n)
- (setq count 0
- rule (- (aref LAruleno i))
- j 0)
- (while (< j ntokens)
- (if (and (numberp (aref actrow j))
- (= (aref actrow j) rule))
- (setq count (1+ count)))
- (setq j (1+ j)))
- (if (> count max)
- (setq max count
- default-rule rule))
- (setq i (1+ i)))
- ;; actions which match the default are replaced with zero,
- ;; which means "use the default"
- (when (> max 0)
- (setq j 0)
- (while (< j ntokens)
- (if (and (numberp (aref actrow j))
- (= (aref actrow j) default-rule))
- (aset actrow j nil))
- (setq j (1+ j)))
- )))
-
- ;; If have no default rule, if this is the final state the default
- ;; is accept else it is an error. So replace any action which
- ;; says "error" with "use default".
- (when (zerop default-rule)
- (if (= final-state state)
- (setq default-rule wisent-accept-tag)
- (setq j 0)
- (while (< j ntokens)
- (if (eq (aref actrow j) wisent-error-tag)
- (aset actrow j nil))
- (setq j (1+ j)))
- (setq default-rule wisent-error-tag)))
- default-rule))
-
-(defconst wisent-default-tag 'default
- "Tag used in an action table to indicate a default action.")
-
-;; These variables only exist locally in the function
-;; `wisent-state-actions' and are shared by all other nested callees.
-(wisent-defcontext semantic-actions
- ;; Uninterned symbols used in code generation.
- stack sp gotos state
- ;; Name of the current semantic action
- NAME)
-
-(defun wisent-state-actions ()
- "Figure out the actions for every state.
-Return the action table."
- ;; Store the semantic action obarray in (unused) RCODE[0].
- (aset rcode 0 (obarray-make 13))
- (let (i j action-table actrow action)
- (setq action-table (make-vector nstates nil)
- actrow (make-vector ntokens nil)
- i 0)
- (wisent-with-context semantic-actions
- (setq stack (make-symbol "stack")
- sp (make-symbol "sp")
- gotos (make-symbol "gotos")
- state (make-symbol "state"))
- (while (< i nstates)
- (setq action (wisent-action-row i actrow))
- ;; Translate a reduction into semantic action
- (and (integerp action) (< action 0)
- (setq action (wisent-semantic-action (- action))))
- (aset action-table i (list (cons wisent-default-tag action)))
- (setq j 0)
- (while (< j ntokens)
- (when (setq action (aref actrow j))
- ;; Translate a reduction into semantic action
- (and (integerp action) (< action 0)
- (setq action (wisent-semantic-action (- action))))
- (aset action-table i (cons (cons (aref tags j) action)
- (aref action-table i)))
- )
- (setq j (1+ j)))
- (aset action-table i (nreverse (aref action-table i)))
- (setq i (1+ i)))
- action-table)))
-
-(defun wisent-goto-actions ()
- "Figure out what to do after reducing with each rule.
-Depending on the saved state from before the beginning of parsing the
-data that matched this rule. Return the goto table."
- (let (i j m n symbol state goto-table)
- (setq goto-table (make-vector nstates nil)
- i ntokens)
- (while (< i nsyms)
- (setq symbol (- i ntokens)
- m (aref goto-map symbol)
- n (aref goto-map (1+ symbol))
- j m)
- (while (< j n)
- (setq state (aref from-state j))
- (aset goto-table state
- (cons (cons (aref tags i) (aref to-state j))
- (aref goto-table state)))
- (setq j (1+ j)))
- (setq i (1+ i)))
- goto-table))
-
-(defsubst wisent-quote-p (sym)
- "Return non-nil if SYM is bound to the `quote' function."
- (condition-case nil
- (eq (indirect-function sym)
- (indirect-function 'quote))
- (error nil)))
-
-(defsubst wisent-backquote-p (sym)
- "Return non-nil if SYM is bound to the `backquote' function."
- (condition-case nil
- (eq (indirect-function sym)
- (indirect-function 'backquote))
- (error nil)))
-
-(defun wisent-check-$N (x m)
- "Return non-nil if X is a valid $N or $regionN symbol.
-That is if X is a $N or $regionN symbol with N >= 1 and N <= M.
-Also warn if X is a $N or $regionN symbol with N < 1 or N > M."
- (when (symbolp x)
- (let* ((n (symbol-name x))
- (i (and (string-match "\\`\\$\\(region\\)?\\([0-9]+\\)\\'" n)
- (string-to-number (match-string 2 n)))))
- (when i
- (if (and (>= i 1) (<= i m))
- t
- (message
- "*** In %s, %s might be a free variable (rule has %s)"
- NAME x (format (cond ((< m 1) "no component")
- ((= m 1) "%d component")
- ("%d components"))
- m))
- nil)))))
-
-(defun wisent-semantic-action-expand-body (body n &optional found)
- "Parse BODY of semantic action.
-N is the maximum number of $N variables that can be referenced in
-BODY. Warn on references out of permitted range.
-Optional argument FOUND is the accumulated list of $N references
-encountered so far.
-Return a cons (FOUND . XBODY), where FOUND is the list of $N
-references found in BODY, and XBODY is BODY expression with
-`backquote' forms expanded."
- (if (not (listp body))
- ;; BODY is an atom, no expansion needed
- (progn
- (if (wisent-check-$N body n)
- ;; Accumulate $i symbol
- (cl-pushnew body found :test #'equal))
- (cons found body))
- ;; BODY is a list, expand inside it
- (let (xbody sexpr)
- ;; If backquote expand it first
- (if (wisent-backquote-p (car body))
- (setq body (macroexpand body)))
- (while body
- (setq sexpr (car body)
- body (cdr body))
- (cond
- ;; Function call excepted quote expression
- ((and (consp sexpr)
- (not (wisent-quote-p (car sexpr))))
- (setq sexpr (wisent-semantic-action-expand-body sexpr n found)
- found (car sexpr)
- sexpr (cdr sexpr)))
- ;; $i symbol
- ((wisent-check-$N sexpr n)
- ;; Accumulate $i symbol
- (cl-pushnew sexpr found :test #'equal))
- )
- ;; Accumulate expanded forms
- (setq xbody (nconc xbody (list sexpr))))
- (cons found xbody))))
-
-(defun wisent-semantic-action (r)
- "Set up the Elisp function for semantic action at rule R.
-On entry RCODE[R] contains a vector [BODY N (NTERM I)] where BODY is the
-body of the semantic action, N is the maximum number of values
-available in the parser's stack, NTERM is the nonterminal the semantic
-action belongs to, and I is the index of the semantic action inside
-NTERM definition. Return the semantic action symbol.
-The semantic action function accepts three arguments:
-
-- the state/value stack
-- the top-of-stack index
-- the goto table
-
-And returns the updated top-of-stack index."
- (if (not (aref ruseful r))
- (aset rcode r nil)
- (let* ((actn (aref rcode r))
- (n (aref actn 1)) ; nb of val avail. in stack
- (NAME (apply #'format "%s:%d" (aref actn 2)))
- (form (wisent-semantic-action-expand-body (aref actn 0) n))
- ($l (car form)) ; list of $vars used in body
- (form (cdr form)) ; expanded form of body
- (nt (aref rlhs r)) ; nonterminal item no.
- (bl nil) ; `let*' binding list
- $v i j)
-
- ;; Compute $N and $regionN bindings
- (setq i n)
- (while (> i 0)
- (setq j (1+ (* 2 (- n i))))
- ;; Only bind $regionI if used in action
- (setq $v (intern (format "$region%d" i)))
- (if (memq $v $l)
- (setq bl (cons `(,$v (cdr (aref ,stack (- ,sp ,j)))) bl)))
- ;; Only bind $I if used in action
- (setq $v (intern (format "$%d" i)))
- (if (memq $v $l)
- (setq bl (cons `(,$v (car (aref ,stack (- ,sp ,j)))) bl)))
- (setq i (1- i)))
-
- ;; Compute J, the length of rule's RHS. It will give the
- ;; current parser state at STACK[SP - 2*J], and where to push
- ;; the new semantic value and the next state, respectively at:
- ;; STACK[SP - 2*J + 1] and STACK[SP - 2*J + 2]. Generally N,
- ;; the maximum number of values available in the stack, is equal
- ;; to J. But, for mid-rule actions, N is the number of rule
- ;; elements before the action and J is always 0 (empty rule).
- (setq i (aref rrhs r)
- j 0)
- (while (> (aref ritem i) 0)
- (setq j (1+ j)
- i (1+ i)))
-
- ;; Create the semantic action symbol.
- (setq actn (intern NAME (aref rcode 0)))
-
- ;; Store source code in function cell of the semantic action
- ;; symbol. It will be byte-compiled at automaton's compilation
- ;; time. Using a byte-compiled automaton can significantly
- ;; speed up parsing!
- (fset actn
- `(lambda (,stack ,sp ,gotos)
- (let* (,@bl
- ($region
- ,(cond
- ((= n 1)
- (if (assq '$region1 bl)
- '$region1
- `(cdr (aref ,stack (1- ,sp)))))
- ((> n 1)
- `(wisent-production-bounds
- ,stack (- ,sp ,(1- (* 2 n))) (1- ,sp)))))
- ($action ,NAME)
- ($nterm ',(aref tags nt))
- ,@(and (> j 0) `((,sp (- ,sp ,(* j 2)))))
- (,state (cdr (assq $nterm
- (aref ,gotos
- (aref ,stack ,sp))))))
- (setq ,sp (+ ,sp 2))
- ;; push semantic value
- (aset ,stack (1- ,sp) (cons ,form $region))
- ;; push next state
- (aset ,stack ,sp ,state)
- ;; return new top of stack
- ,sp)))
-
- ;; Return the semantic action symbol
- actn)))
-\f
-;;;; ----------------------------
-;;;; Build parser LALR automaton.
-;;;; ----------------------------
-
-(defun wisent-parser-automaton ()
- "Compute and return LALR(1) automaton from GRAMMAR.
-GRAMMAR is in internal format. GRAM/ACTS are grammar rules
-in internal format. STARTS defines the start symbols."
- ;; Check for useless stuff
- (wisent-reduce-grammar)
-
- (wisent-set-derives)
- (wisent-set-nullable)
- ;; convert to nondeterministic finite state machine.
- (wisent-generate-states)
- ;; make it deterministic.
- (wisent-lalr)
- ;; Find and record any conflicts: places where one token of
- ;; lookahead is not enough to disambiguate the parsing. Also
- ;; resolve s/r conflicts based on precedence declarations.
- (wisent-resolve-conflicts)
- (wisent-print-results)
-
- (vector (wisent-state-actions) ; action table
- (wisent-goto-actions) ; goto table
- start-table ; start symbols
- (aref rcode 0) ; sem. action symbol obarray
- )
- )
-\f
-;;;; -------------------
-;;;; Parse input grammar
-;;;; -------------------
-
-(defconst wisent-reserved-symbols (list wisent-error-term)
- "The list of reserved symbols.
-Also all symbols starting with a character defined in
-`wisent-reserved-capitals' are reserved for internal use.")
-
-(defconst wisent-reserved-capitals '(?\$ ?\@)
- "The list of reserved capital letters.
-All symbol starting with one of these letters are reserved for
-internal use.")
-
-(defconst wisent-starts-nonterm '$STARTS
- "Main start symbol.
-It gives the rules for start symbols.")
-
-(defvar wisent-single-start-flag nil
- "Non-nil means allows only one start symbol like in Bison.
-That is don't add extra start rules to the grammar. This is
-useful to compare the Wisent's generated automaton with the Bison's
-one.")
-
-(defsubst wisent-ISVALID-VAR (x)
- "Return non-nil if X is a character or an allowed symbol."
- (and x (symbolp x)
- (not (memq (aref (symbol-name x) 0) wisent-reserved-capitals))
- (not (memq x wisent-reserved-symbols))))
-
-(defsubst wisent-ISVALID-TOKEN (x)
- "Return non-nil if X is a character or an allowed symbol."
- (or (characterp x)
- (wisent-ISVALID-VAR x)))
-
-(defun wisent-push-token (symbol &optional nocheck)
- "Push a new SYMBOL in the list of tokens.
-Bypass checking if NOCHECK is non-nil."
- ;; Check
- (or nocheck (wisent-ISVALID-TOKEN symbol)
- (error "Invalid terminal symbol: %S" symbol))
- (if (memq symbol token-list)
- (message "*** duplicate terminal `%s' ignored" symbol)
- ;; Set up properties
- (wisent-set-prec symbol nil)
- (wisent-set-assoc symbol nil)
- (wisent-set-item-number symbol ntokens)
- ;; Add
- (setq ntokens (1+ ntokens)
- token-list (cons symbol token-list))))
-
-(defun wisent-push-var (symbol &optional nocheck)
- "Push a new SYMBOL in the list of nonterminals.
-Bypass checking if NOCHECK is non-nil."
- ;; Check
- (unless nocheck
- (or (wisent-ISVALID-VAR symbol)
- (error "Invalid nonterminal symbol: %S" symbol))
- (if (memq symbol var-list)
- (error "Nonterminal `%s' already defined" symbol)))
- ;; Set up properties
- (wisent-set-item-number symbol nvars)
- ;; Add
- (setq nvars (1+ nvars)
- var-list (cons symbol var-list)))
-
-(defun wisent-parse-nonterminals (defs)
- "Parse nonterminal definitions in DEFS.
-Fill in each element of the global arrays RPREC, RCODE, RUSEFUL with
-respectively rule precedence level, semantic action code and
-usefulness flag. Return a list of rules of the form (LHS . RHS) where
-LHS and RHS are respectively the Left Hand Side and Right Hand Side of
-the rule."
- (setq rprec nil
- rcode nil
- nitems 0
- nrules 0)
- (let (def nonterm rlist rule rules rhs rest item items
- rhl plevel semact @n @count iactn)
- (setq @count 0)
- (while defs
- (setq def (car defs)
- defs (cdr defs)
- nonterm (car def)
- rlist (cdr def)
- iactn 0)
- (or (consp rlist)
- (error "Invalid nonterminal definition syntax: %S" def))
- (while rlist
- (setq rule (car rlist)
- rlist (cdr rlist)
- items (car rule)
- rest (cdr rule)
- rhl 0
- rhs nil)
-
- ;; Check & count items
- (setq nitems (1+ nitems)) ;; LHS item
- (while items
- (setq item (car items)
- items (cdr items)
- nitems (1+ nitems)) ;; RHS items
- (if (listp item)
- ;; Mid-rule action
- (progn
- (setq @count (1+ @count)
- @n (intern (format "@%d" @count)))
- (wisent-push-var @n t)
- ;; Push a new empty rule with the mid-rule action
- (setq semact (vector item rhl (list nonterm iactn))
- iactn (1+ iactn)
- plevel nil
- rcode (cons semact rcode)
- rprec (cons plevel rprec)
- item @n ;; Replace action by @N nonterminal
- rules (cons (list item) rules)
- nitems (1+ nitems)
- nrules (1+ nrules)))
- ;; Check terminal or nonterminal symbol
- (cond
- ((or (memq item token-list) (memq item var-list)))
- ;; Create new literal character token
- ((characterp item) (wisent-push-token item t))
- ((error "Symbol `%s' is used, but is not defined as a token and has no rules"
- item))))
- (setq rhl (1+ rhl)
- rhs (cons item rhs)))
-
- ;; Check & collect rule precedence level
- (setq plevel (when (vectorp (car rest))
- (setq item (car rest)
- rest (cdr rest))
- (if (and (= (length item) 1)
- (memq (aref item 0) token-list)
- (wisent-prec (aref item 0)))
- (wisent-item-number (aref item 0))
- (error "Invalid rule precedence level syntax: %S" item)))
- rprec (cons plevel rprec))
-
- ;; Check & collect semantic action body
- (setq semact (vector
- (if rest
- (if (cdr rest)
- (error "Invalid semantic action syntax: %S" rest)
- (car rest))
- ;; Give a default semantic action body: nil
- ;; for an empty rule or $1, the value of the
- ;; first symbol in the rule, otherwise.
- (if (> rhl 0) '$1 '()))
- rhl
- (list nonterm iactn))
- iactn (1+ iactn)
- rcode (cons semact rcode))
- (setq rules (cons (cons nonterm (nreverse rhs)) rules)
- nrules (1+ nrules))))
-
- (setq ruseful (make-vector (1+ nrules) t)
- rprec (vconcat (cons nil (nreverse rprec)))
- rcode (vconcat (cons nil (nreverse rcode))))
- (nreverse rules)
- ))
-
-(defun wisent-parse-grammar (grammar &optional start-list)
- "Parse GRAMMAR and build a suitable internal representation.
-Optional argument START-LIST defines the start symbols.
-GRAMMAR is a list of form: (TOKENS ASSOCS . NONTERMS)
-
-TOKENS is a list of terminal symbols (tokens).
-
-ASSOCS is nil or an alist of (ASSOC-TYPE . ASSOC-VALUE) elements
-describing the associativity of TOKENS. ASSOC-TYPE must be one of the
-`default-prec' `nonassoc', `left' or `right' symbols. When ASSOC-TYPE
-is `default-prec', ASSOC-VALUE must be nil or t (the default).
-Otherwise it is a list of tokens which must have been previously
-declared in TOKENS.
-
-NONTERMS is the list of non terminal definitions (see function
-`wisent-parse-nonterminals')."
- (or (and (consp grammar) (> (length grammar) 2))
- (error "Bad input grammar"))
-
- (let (i r rhs pre dpre lst start-var assoc rules item
- token var def tokens defs ep-token ep-var ep-def)
-
- ;; Built-in tokens
- (setq ntokens 0 nvars 0)
- (wisent-push-token wisent-eoi-term t)
- (wisent-push-token wisent-error-term t)
-
- ;; Check/collect terminals
- (setq lst (car grammar))
- (while lst
- (wisent-push-token (car lst))
- (setq lst (cdr lst)))
-
- ;; Check/Set up tokens precedence & associativity
- (setq lst (nth 1 grammar)
- pre 0
- defs nil
- dpre nil
- default-prec t)
- (while lst
- (setq def (car lst)
- assoc (car def)
- tokens (cdr def)
- lst (cdr lst))
- (if (eq assoc 'default-prec)
- (progn
- (or (null (cdr tokens))
- (memq (car tokens) '(t nil))
- (error "Invalid default-prec value: %S" tokens))
- (setq default-prec (car tokens))
- (if dpre
- (message "*** redefining default-prec to %s"
- default-prec))
- (setq dpre t))
- (or (memq assoc '(left right nonassoc))
- (error "Invalid associativity syntax: %S" assoc))
- (setq pre (1+ pre))
- (while tokens
- (setq token (car tokens)
- tokens (cdr tokens))
- (if (memq token defs)
- (message "*** redefining precedence of `%s'" token))
- (or (memq token token-list)
- ;; Define token not previously declared.
- (wisent-push-token token))
- (setq defs (cons token defs))
- ;; Record the precedence and associativity of the terminal.
- (wisent-set-prec token pre)
- (wisent-set-assoc token assoc))))
-
- ;; Check/Collect nonterminals
- (setq lst (nthcdr 2 grammar)
- defs nil)
- (while lst
- (setq def (car lst)
- lst (cdr lst))
- (or (consp def)
- (error "Invalid nonterminal definition: %S" def))
- (if (memq (car def) token-list)
- (error "Nonterminal `%s' already defined as token" (car def)))
- (wisent-push-var (car def))
- (setq defs (cons def defs)))
- (or defs
- (error "No input grammar"))
- (setq defs (nreverse defs))
-
- ;; Set up the start symbol.
- (setq start-table nil)
- (cond
-
- ;; 1. START-LIST is nil, the start symbol is the first
- ;; nonterminal defined in the grammar (Bison like).
- ((null start-list)
- (setq start-var (caar defs)))
-
- ;; 2. START-LIST contains only one element, it is the start
- ;; symbol (Bison like).
- ((or wisent-single-start-flag (null (cdr start-list)))
- (setq start-var (car start-list))
- (or (assq start-var defs)
- (error "Start symbol `%s' has no rule" start-var)))
-
- ;; 3. START-LIST contains more than one element. All defines
- ;; potential start symbols. One of them (the first one by
- ;; default) will be given at parse time to be the parser goal.
- ;; If `wisent-single-start-flag' is non-nil that feature is
- ;; disabled and the first nonterminal in START-LIST defines
- ;; the start symbol, like in case 2 above.
- ((not wisent-single-start-flag)
-
- ;; START-LIST is a list of nonterminals '(nt0 ... ntN).
- ;; Build and push ad hoc start rules in the grammar:
-
- ;; ($STARTS ((nt0) $1) ((nt1) $1) ... ((ntN) $1))
- ;; ($nt1 (($$nt1 nt1) $2))
- ;; ...
- ;; ($ntN (($$ntN ntN) $2))
-
- ;; Where internal symbols $ntI and $$ntI are respectively
- ;; nonterminals and terminals.
-
- ;; The internal start symbol $STARTS is used to build the
- ;; LALR(1) automaton. The true default start symbol used by the
- ;; parser is the first nonterminal in START-LIST (nt0).
- (setq start-var wisent-starts-nonterm
- lst (nreverse start-list))
- (while lst
- (setq var (car lst)
- lst (cdr lst))
- (or (memq var var-list)
- (error "Start symbol `%s' has no rule" var))
- (unless (assq var start-table) ;; Ignore duplicates
- ;; For each nt start symbol
- (setq ep-var (intern (format "$%s" var))
- ep-token (intern (format "$$%s" var)))
- (wisent-push-token ep-token t)
- (wisent-push-var ep-var t)
- (setq
- ;; Add entry (nt . $$nt) to start-table
- start-table (cons (cons var ep-token) start-table)
- ;; Add rule ($nt (($$nt nt) $2))
- defs (cons (list ep-var (list (list ep-token var) '$2)) defs)
- ;; Add start rule (($nt) $1)
- ep-def (cons (list (list ep-var) '$1) ep-def))
- ))
- (wisent-push-var start-var t)
- (setq defs (cons (cons start-var ep-def) defs))))
-
- ;; Set up rules main data structure & RPREC, RCODE, RUSEFUL
- (setq rules (wisent-parse-nonterminals defs))
-
- ;; Set up the terminal & nonterminal lists.
- (setq nsyms (+ ntokens nvars)
- token-list (nreverse token-list)
- lst var-list
- var-list nil)
- (while lst
- (setq var (car lst)
- lst (cdr lst)
- var-list (cons var var-list))
- (wisent-set-item-number ;; adjust nonterminal item number to
- var (+ ntokens (wisent-item-number var)))) ;; I += NTOKENS
-
- ;; Store special item numbers
- (setq error-token-number (wisent-item-number wisent-error-term)
- start-symbol (wisent-item-number start-var))
-
- ;; Keep symbols in the TAGS vector so that TAGS[I] is the symbol
- ;; associated to item number I.
- (setq tags (vconcat token-list var-list))
- ;; Set up RLHS RRHS & RITEM data structures from list of rules
- ;; (LHS . RHS) received from `wisent-parse-nonterminals'.
- (setq rlhs (make-vector (1+ nrules) nil)
- rrhs (make-vector (1+ nrules) nil)
- ritem (make-vector (1+ nitems) nil)
- i 0
- r 1)
- (while rules
- (aset rlhs r (wisent-item-number (caar rules)))
- (aset rrhs r i)
- (setq rhs (cdar rules)
- pre nil)
- (while rhs
- (setq item (wisent-item-number (car rhs)))
- ;; Get default precedence level of rule, that is the
- ;; precedence of the last terminal in it.
- (and (wisent-ISTOKEN item)
- default-prec
- (setq pre item))
-
- (aset ritem i item)
- (setq i (1+ i)
- rhs (cdr rhs)))
- ;; Setup the precedence level of the rule, that is the one
- ;; specified by %prec or the default one.
- (and (not (aref rprec r)) ;; Already set by %prec
- pre
- (wisent-prec (aref tags pre))
- (aset rprec r pre))
- (aset ritem i (- r))
- (setq i (1+ i)
- r (1+ r))
- (setq rules (cdr rules)))
- ))
-\f
-;;;; ---------------------
-;;;; Compile input grammar
-;;;; ---------------------
-
-(defun wisent--compile-grammar (grammar start-list)
- "Compile the LALR(1) GRAMMAR.
-
-GRAMMAR is a list (TOKENS ASSOCS . NONTERMS) where:
-
-- TOKENS is a list of terminal symbols (tokens).
-
-- ASSOCS is nil, or an alist of (ASSOC-TYPE . ASSOC-VALUE) elements
- describing the associativity of TOKENS. ASSOC-TYPE must be one of
- the `default-prec' `nonassoc', `left' or `right' symbols. When
- ASSOC-TYPE is `default-prec', ASSOC-VALUE must be nil or t (the
- default). Otherwise it is a list of tokens which must have been
- previously declared in TOKENS.
-
-- NONTERMS is a list of nonterminal definitions.
-
-Optional argument START-LIST specify the possible grammar start
-symbols. This is a list of nonterminals which must have been
-previously declared in GRAMMAR's NONTERMS form. By default, the start
-symbol is the first nonterminal defined. When START-LIST contains
-only one element, it is the start symbol. Otherwise, all elements are
-possible start symbols, unless `wisent-single-start-flag' is non-nil.
-In that case, the first element is the start symbol, and others are
-ignored.
-
-Return an automaton as a vector: [ACTIONS GOTOS STARTS FUNCTIONS]
-where:
-
-- ACTIONS is a state/token matrix telling the parser what to do at
- every state based on the current lookahead token. That is shift,
- reduce, accept or error.
-
-- GOTOS is a state/nonterminal matrix telling the parser the next
- state to go to after reducing with each rule.
-
-- STARTS is an alist which maps the allowed start nonterminal symbols
- to tokens that will be first shifted into the parser stack.
-
-- FUNCTIONS is an obarray of semantic action symbols. Each symbol's
- function definition is the semantic action lambda expression."
- (if (wisent-automaton-p grammar)
- grammar ;; Grammar already compiled just return it
- (wisent-with-context compile-grammar
- (let* ((gc-cons-threshold (max gc-cons-threshold 1000000)))
- (garbage-collect)
- (setq wisent-new-log-flag t)
- ;; Parse input grammar
- (wisent-parse-grammar grammar start-list)
- ;; Generate the LALR(1) automaton
- (wisent-parser-automaton)))))
-\f
-;;;; --------------------------
-;;;; Obsolete byte compile support
-;;;; --------------------------
-
-(require 'bytecomp)
-
-(defun wisent-byte-compile-grammar (form)
- "Byte compile the `wisent-compile-grammar' FORM.
-Automatically called by the Emacs Lisp byte compiler as a
-`byte-compile' handler."
- (byte-compile-form
- (macroexpand-all
- (wisent-automaton-lisp-form (eval form t)))))
-
-(defun wisent-compile-grammar (grammar &optional start-list)
- ;; This is kept for compatibility with FOO-wy.el files generated
- ;; with older Emacsen.
- (declare (obsolete wisent-compiled-grammar "Mar 2021"))
- (wisent--compile-grammar grammar start-list))
-
-(put 'wisent-compile-grammar 'byte-compile #'wisent-byte-compile-grammar)
-
-;;;; --------------------------
-;;;; Byte compile input grammar
-;;;; --------------------------
-
-;; `wisent--compile-grammar' generates the actual parse table
-;; we need at run-time, but in order to be able to compile the code it
-;; contains, we need to "reify" it back into a piece of ELisp code
-;; which (re)builds it.
-;; This is needed for 2 reasons:
-;; - The parse tables include an obarray and these don't survive the print+read
-;; steps involved in generating a `.elc' file and reading it back in.
-;; - Within the parse table vectors/obarrays we have ELisp functions which
-;; we want to byte-compile, but if we were to just `quote' the table
-;; we'd get them with the same non-compiled functions.
-(defun wisent-automaton-lisp-form (automaton)
- "Return a Lisp form that produces AUTOMATON.
-See also `wisent-compile-grammar' for more details on AUTOMATON."
- (or (wisent-automaton-p automaton)
- (signal 'wrong-type-argument
- (list 'wisent-automaton-p automaton)))
- (let ((obn (make-symbol "ob")) ; Generated obarray name
- (obv (aref automaton 3)) ; Semantic actions obarray
- )
- `(let ((,obn (obarray-make 13)))
- ;; Generate code to initialize the semantic actions obarray,
- ;; in local variable OBN.
- ,@(let (obcode)
- (mapatoms
- (lambda (s)
- (setq obcode
- (cons `(fset (intern ,(symbol-name s) ,obn)
- #',(symbol-function s))
- obcode)))
- obv)
- obcode)
- ;; Generate code to create the automaton.
- (vector
- ;; In code generated to initialize the action table, take
- ;; care of symbols that are interned in the semantic actions
- ;; obarray.
- (vector
- ,@(mapcar
- ;; Use name `st' rather than `state' since `state' is
- ;; defined as dynbound in `semantic-actions' context above :-( !
- (lambda (st) ;; for each state
- `(list
- ,@(mapcar
- (lambda (tr) ;; for each transition
- (let ((k (car tr)) ; token
- (a (cdr tr))) ; action
- (if (and (symbolp a)
- (intern-soft (symbol-name a) obv))
- `(cons ,(if (symbolp k) `(quote ,k) k)
- (intern-soft ,(symbol-name a) ,obn))
- `(quote ,tr))))
- st)))
- (aref automaton 0)))
- ;; The code of the goto table is unchanged.
- ,(aref automaton 1)
- ;; The code of the alist of start symbols is unchanged.
- ',(aref automaton 2)
- ;; The semantic actions obarray is in the local variable OBN.
- ,obn))))
-
-(provide 'semantic/wisent/comp)
-
-;; Disable messages with regards to lexical scoping, since this will
-;; produce a bunch of 'lacks a prefix' warnings with the
-;; `wisent-defcontext' trickery above.
-
-;; Local variables:
-;; byte-compile-warnings: (not lexical)
-;; generated-autoload-load-name: "semantic/wisent/comp"
-;; End:
-
-;;; semantic/wisent/comp.el ends here
+++ /dev/null
-;;; semantic/wisent/grammar.el --- Wisent's input grammar mode -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-;;
-;; Author: David Ponce <david@dponce.com>
-;; Created: 26 Aug 2002
-;; Keywords: syntax
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Major mode for editing Wisent's input grammar (.wy) files.
-
-;;; Code:
-(require 'semantic)
-(require 'semantic/grammar)
-(require 'semantic/find)
-(require 'semantic/lex)
-(require 'semantic/wisent)
-(require 'semantic/bovine)
-
-(defsubst wisent-grammar-region-placeholder (symb)
- "Given a $N placeholder symbol in SYMB, return a $regionN symbol.
-Return nil if $N is not a valid placeholder symbol."
- (let ((n (symbol-name symb)))
- (if (string-match "^[$]\\([1-9][0-9]*\\)$" n)
- (intern (concat "$region" (match-string 1 n))))))
-
-(defun wisent-grammar-EXPAND (symb nonterm)
- "Expand call to EXPAND grammar macro.
-Return the form to parse from within a nonterminal.
-SYMB is a $I placeholder symbol that gives the bounds of the area to
-parse.
-NONTERM is the nonterminal symbol to start with."
- (unless (member nonterm (semantic-grammar-start))
- (error "EXPANDFULL macro called with %s, but not used with %%start"
- nonterm))
- (let (($ri (wisent-grammar-region-placeholder symb)))
- (if $ri
- `(semantic-bovinate-from-nonterminal
- (car ,$ri) (cdr ,$ri) ',nonterm)
- (error "Invalid form (EXPAND %s %s)" symb nonterm))))
-
-(defun wisent-grammar-EXPANDFULL (symb nonterm)
- "Expand call to EXPANDFULL grammar macro.
-Return the form to recursively parse an area.
-SYMB is a $I placeholder symbol that gives the bounds of the area.
-NONTERM is the nonterminal symbol to start with."
- (unless (member nonterm (semantic-grammar-start))
- (error "EXPANDFULL macro called with %s, but not used with %%start"
- nonterm))
- (let (($ri (wisent-grammar-region-placeholder symb)))
- (if $ri
- `(semantic-parse-region
- (car ,$ri) (cdr ,$ri) ',nonterm 1)
- (error "Invalid form (EXPANDFULL %s %s)" symb nonterm))))
-
-(defun wisent-grammar-TAG (name class &rest attributes)
- "Expand call to TAG grammar macro.
-Return the form to create a generic semantic tag.
-See the function `semantic-tag' for the meaning of arguments NAME,
-CLASS and ATTRIBUTES."
- `(wisent-raw-tag
- (semantic-tag ,name ,class ,@attributes)))
-
-(defun wisent-grammar-VARIABLE-TAG (name type default-value &rest attributes)
- "Expand call to VARIABLE-TAG grammar macro.
-Return the form to create a semantic tag of class variable.
-See the function `semantic-tag-new-variable' for the meaning of
-arguments NAME, TYPE, DEFAULT-VALUE and ATTRIBUTES."
- `(wisent-raw-tag
- (semantic-tag-new-variable ,name ,type ,default-value ,@attributes)))
-
-(defun wisent-grammar-FUNCTION-TAG (name type arg-list &rest attributes)
- "Expand call to FUNCTION-TAG grammar macro.
-Return the form to create a semantic tag of class function.
-See the function `semantic-tag-new-function' for the meaning of
-arguments NAME, TYPE, ARG-LIST and ATTRIBUTES."
- `(wisent-raw-tag
- (semantic-tag-new-function ,name ,type ,arg-list ,@attributes)))
-
-(defun wisent-grammar-TYPE-TAG (name type members parents &rest attributes)
- "Expand call to TYPE-TAG grammar macro.
-Return the form to create a semantic tag of class type.
-See the function `semantic-tag-new-type' for the meaning of arguments
-NAME, TYPE, MEMBERS, PARENTS and ATTRIBUTES."
- `(wisent-raw-tag
- (semantic-tag-new-type ,name ,type ,members ,parents ,@attributes)))
-
-(defun wisent-grammar-INCLUDE-TAG (name system-flag &rest attributes)
- "Expand call to INCLUDE-TAG grammar macro.
-Return the form to create a semantic tag of class include.
-See the function `semantic-tag-new-include' for the meaning of
-arguments NAME, SYSTEM-FLAG and ATTRIBUTES."
- `(wisent-raw-tag
- (semantic-tag-new-include ,name ,system-flag ,@attributes)))
-
-(defun wisent-grammar-PACKAGE-TAG (name detail &rest attributes)
- "Expand call to PACKAGE-TAG grammar macro.
-Return the form to create a semantic tag of class package.
-See the function `semantic-tag-new-package' for the meaning of
-arguments NAME, DETAIL and ATTRIBUTES."
- `(wisent-raw-tag
- (semantic-tag-new-package ,name ,detail ,@attributes)))
-
-(defun wisent-grammar-CODE-TAG (name detail &rest attributes)
- "Expand call to CODE-TAG grammar macro.
-Return the form to create a semantic tag of class code.
-See the function `semantic-tag-new-code' for the meaning of arguments
-NAME, DETAIL and ATTRIBUTES."
- `(wisent-raw-tag
- (semantic-tag-new-code ,name ,detail ,@attributes)))
-
-(defun wisent-grammar-ALIAS-TAG (name aliasclass definition &rest attributes)
- "Expand call to ALIAS-TAG grammar macro.
-Return the form to create a semantic tag of class alias.
-See the function `semantic-tag-new-alias' for the meaning of arguments
-NAME, ALIASCLASS, DEFINITION and ATTRIBUTES."
- `(wisent-raw-tag
- (semantic-tag-new-alias ,name ,aliasclass ,definition ,@attributes)))
-
-(defun wisent-grammar-EXPANDTAG (raw-tag)
- "Expand call to EXPANDTAG grammar macro.
-Return the form to produce a list of cooked tags from raw form of
-Semantic tag RAW-TAG."
- `(wisent-cook-tag ,raw-tag))
-
-(defun wisent-grammar-AST-ADD (ast &rest nodes)
- "Expand call to AST-ADD grammar macro.
-Return the form to update the abstract syntax tree AST with NODES.
-See also the function `semantic-ast-add'."
- `(semantic-ast-add ,ast ,@nodes))
-
-(defun wisent-grammar-AST-PUT (ast &rest nodes)
- "Expand call to AST-PUT grammar macro.
-Return the form to update the abstract syntax tree AST with NODES.
-See also the function `semantic-ast-put'."
- `(semantic-ast-put ,ast ,@nodes))
-
-(defun wisent-grammar-AST-GET (ast node)
- "Expand call to AST-GET grammar macro.
-Return the form to get, from the abstract syntax tree AST, the value
-of NODE.
-See also the function `semantic-ast-get'."
- `(semantic-ast-get ,ast ,node))
-
-(defun wisent-grammar-AST-GET1 (ast node)
- "Expand call to AST-GET1 grammar macro.
-Return the form to get, from the abstract syntax tree AST, the first
-value of NODE.
-See also the function `semantic-ast-get1'."
- `(semantic-ast-get1 ,ast ,node))
-
-(defun wisent-grammar-AST-GET-STRING (ast node)
- "Expand call to AST-GET-STRING grammar macro.
-Return the form to get, from the abstract syntax tree AST, the value
-of NODE as a string.
-See also the function `semantic-ast-get-string'."
- `(semantic-ast-get-string ,ast ,node))
-
-(defun wisent-grammar-AST-MERGE (ast1 ast2)
- "Expand call to AST-MERGE grammar macro.
-Return the form to merge the abstract syntax trees AST1 and AST2.
-See also the function `semantic-ast-merge'."
- `(semantic-ast-merge ,ast1 ,ast2))
-
-(defun wisent-grammar-SKIP-BLOCK (&optional symb)
- "Expand call to SKIP-BLOCK grammar macro.
-Return the form to skip a parenthesized block.
-Optional argument SYMB is a $I placeholder symbol that gives the
-bounds of the block to skip. By default, skip the block at `$1'.
-See also the function `wisent-skip-block'."
- (let ($ri)
- (when symb
- (unless (setq $ri (wisent-grammar-region-placeholder symb))
- (error "Invalid form (SKIP-BLOCK %s)" symb)))
- `(wisent-skip-block ,$ri)))
-
-(defun wisent-grammar-SKIP-TOKEN ()
- "Expand call to SKIP-TOKEN grammar macro.
-Return the form to skip the lookahead token.
-See also the function `wisent-skip-token'."
- '(wisent-skip-token))
-
-(defun wisent-grammar-assocs ()
- "Return associativity and precedence level definitions."
- (mapcar
- (lambda (tag)
- (cons (intern (semantic-tag-name tag))
- (mapcar #'semantic-grammar-item-value
- (semantic-tag-get-attribute tag :value))))
- (semantic-find-tags-by-class 'assoc (current-buffer))))
-
-(defun wisent-grammar-terminals ()
- "Return the list of terminal symbols.
-Keep order of declaration in the WY file without duplicates."
- (let (terms)
- (mapc
- (lambda (tag)
- (mapcar (lambda (name)
- (add-to-list 'terms (intern name)))
- (cons (semantic-tag-name tag)
- (semantic-tag-get-attribute tag :rest))))
- (semantic--find-tags-by-function
- (lambda (tag)
- (memq (semantic-tag-class tag) '(token keyword)))
- (current-buffer)))
- (nreverse terms)))
-
-;; Cache of macro definitions currently in use.
-(defvar wisent--grammar-macros nil)
-
-(defun wisent-grammar-expand-macros (expr)
- "Expand expression EXPR into a form without grammar macros.
-Return the expanded expression."
- (if (or (atom expr) (semantic-grammar-quote-p (car expr)))
- expr ;; Just return atom or quoted expression.
- (let* ((expr (mapcar #'wisent-grammar-expand-macros expr))
- (macro (assq (car expr) wisent--grammar-macros)))
- (if macro ;; Expand Semantic built-in.
- (apply (cdr macro) (cdr expr))
- expr))))
-
-(defun wisent-grammar-nonterminals ()
- "Return the list form of nonterminal definitions."
- (let ((nttags (semantic-find-tags-by-class
- 'nonterminal (current-buffer)))
- ;; Setup the cache of macro definitions.
- (wisent--grammar-macros (semantic-grammar-macros))
- rltags nterms rules rule elems elem actn sexp prec)
- (while nttags
- (setq rltags (semantic-tag-components (car nttags))
- rules nil)
- (while rltags
- (setq elems (semantic-tag-get-attribute (car rltags) :value)
- prec (semantic-tag-get-attribute (car rltags) :prec)
- actn (semantic-tag-get-attribute (car rltags) :expr)
- rule nil)
- (when elems ;; not an EMPTY rule
- (while elems
- (setq elem (car elems)
- elems (cdr elems))
- (setq elem (if (consp elem) ;; mid-rule action
- (wisent-grammar-expand-macros (read (car elem)))
- (semantic-grammar-item-value elem)) ;; item
- rule (cons elem rule)))
- (setq rule (nreverse rule)))
- (if prec
- (setq prec (vector (semantic-grammar-item-value prec))))
- (if actn
- (setq sexp (wisent-grammar-expand-macros (read actn))))
- (setq rule (if actn
- (if prec
- (list rule prec sexp)
- (list rule sexp))
- (if prec
- (list rule prec)
- (list rule))))
- (setq rules (cons rule rules)
- rltags (cdr rltags)))
- (setq nterms (cons (cons (intern (semantic-tag-name (car nttags)))
- (nreverse rules))
- nterms)
- nttags (cdr nttags)))
- (nreverse nterms)))
-
-(defun wisent-grammar-grammar ()
- "Return Elisp form of the grammar."
- (let* ((terminals (wisent-grammar-terminals))
- (nonterminals (wisent-grammar-nonterminals))
- (assocs (wisent-grammar-assocs)))
- (cons terminals (cons assocs nonterminals))))
-
-(define-mode-local-override semantic-grammar-parsetable-builder
- wisent-grammar-mode ()
- "Return the value of the parser table."
- `(wisent-compiled-grammar
- ,(wisent-grammar-grammar)
- ,(semantic-grammar-start)))
-
-(define-mode-local-override semantic-grammar-setupcode-builder
- wisent-grammar-mode ()
- "Return the parser setup code."
- (format
- "(semantic-install-function-overrides\n\
- '((semantic-parse-stream . wisent-parse-stream)))\n\
- (setq semantic-parser-name \"LALR\"\n\
- semantic--parse-table %s\n\
- semantic-debug-parser-source %S\n\
- semantic-flex-keywords-obarray %s\n\
- semantic-lex-types-obarray %s)\n\
- ;; Collect unmatched syntax lexical tokens\n\
- (add-hook 'wisent-discarding-token-functions\n\
- #'wisent-collect-unmatched-syntax nil t)"
- (semantic-grammar-parsetable)
- (buffer-name)
- (semantic-grammar-keywordtable)
- (semantic-grammar-tokentable)))
-
-(defvar wisent-grammar-menu
- '("WY Grammar"
- ["LALR Compiler Verbose" wisent-toggle-verbose-flag
- :style toggle :active (boundp 'wisent-verbose-flag)
- :selected (and (boundp 'wisent-verbose-flag)
- wisent-verbose-flag)]
- )
- "WY mode specific grammar menu.
-Menu items are appended to the common grammar menu.")
-
-;;;###autoload
-(define-derived-mode wisent-grammar-mode semantic-grammar-mode "WY"
- "Major mode for editing Wisent grammars."
- (semantic-grammar-setup-menu wisent-grammar-menu)
- (setq-local semantic-grammar-require-form '(require 'semantic/wisent)))
-
-(defvar-mode-local wisent-grammar-mode semantic-grammar-macros
- '(
- (ASSOC . semantic-grammar-ASSOC)
- (EXPAND . wisent-grammar-EXPAND)
- (EXPANDFULL . wisent-grammar-EXPANDFULL)
- (TAG . wisent-grammar-TAG)
- (VARIABLE-TAG . wisent-grammar-VARIABLE-TAG)
- (FUNCTION-TAG . wisent-grammar-FUNCTION-TAG)
- (TYPE-TAG . wisent-grammar-TYPE-TAG)
- (INCLUDE-TAG . wisent-grammar-INCLUDE-TAG)
- (PACKAGE-TAG . wisent-grammar-PACKAGE-TAG)
- (EXPANDTAG . wisent-grammar-EXPANDTAG)
- (CODE-TAG . wisent-grammar-CODE-TAG)
- (ALIAS-TAG . wisent-grammar-ALIAS-TAG)
- (AST-ADD . wisent-grammar-AST-ADD)
- (AST-PUT . wisent-grammar-AST-PUT)
- (AST-GET . wisent-grammar-AST-GET)
- (AST-GET1 . wisent-grammar-AST-GET1)
- (AST-GET-STRING . wisent-grammar-AST-GET-STRING)
- (AST-MERGE . wisent-grammar-AST-MERGE)
- (SKIP-BLOCK . wisent-grammar-SKIP-BLOCK)
- (SKIP-TOKEN . wisent-grammar-SKIP-TOKEN)
- )
- "Semantic grammar macros used in wisent grammars.")
-
-(defvar wisent-make-parsers--emacs-license
- ";; 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 <https://www.gnu.org/licenses/>.")
-
-(defvar wisent-make-parsers--python-license
- ";; It is derived in part from the Python grammar, used under the
-;; following license:
-;;
-;; PYTHON SOFTWARE FOUNDATION LICENSE VERSION 2
-;; --------------------------------------------
-;; 1. This LICENSE AGREEMENT is between the Python Software Foundation
-;; (\"PSF\"), and the Individual or Organization (\"Licensee\") accessing
-;; and otherwise using this software (\"Python\") in source or binary
-;; form and its associated documentation.
-;;
-;; 2. Subject to the terms and conditions of this License Agreement,
-;; PSF hereby grants Licensee a nonexclusive, royalty-free, world-wide
-;; license to reproduce, analyze, test, perform and/or display
-;; publicly, prepare derivative works, distribute, and otherwise use
-;; Python alone or in any derivative version, provided, however, that
-;; PSF's License Agreement and PSF's notice of copyright, i.e.,
-;; \"Copyright (c) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-;; 2009, 2010 Python Software Foundation; All Rights Reserved\" are
-;; retained in Python alone or in any derivative version prepared by
-;; Licensee.
-;;
-;; 3. In the event Licensee prepares a derivative work that is based
-;; on or incorporates Python or any part thereof, and wants to make
-;; the derivative work available to others as provided herein, then
-;; Licensee hereby agrees to include in any such work a brief summary
-;; of the changes made to Python.
-;;
-;; 4. PSF is making Python available to Licensee on an \"AS IS\"
-;; basis. PSF MAKES NO REPRESENTATIONS OR WARRANTIES, EXPRESS OR
-;; IMPLIED. BY WAY OF EXAMPLE, BUT NOT LIMITATION, PSF MAKES NO AND
-;; DISCLAIMS ANY REPRESENTATION OR WARRANTY OF MERCHANTABILITY OR FITNESS
-;; FOR ANY PARTICULAR PURPOSE OR THAT THE USE OF PYTHON WILL NOT
-;; INFRINGE ANY THIRD PARTY RIGHTS.
-;;
-;; 5. PSF SHALL NOT BE LIABLE TO LICENSEE OR ANY OTHER USERS OF PYTHON
-;; FOR ANY INCIDENTAL, SPECIAL, OR CONSEQUENTIAL DAMAGES OR LOSS AS A
-;; RESULT OF MODIFYING, DISTRIBUTING, OR OTHERWISE USING PYTHON, OR
-;; ANY DERIVATIVE THEREOF, EVEN IF ADVISED OF THE POSSIBILITY THEREOF.
-;;
-;; 6. This License Agreement will automatically terminate upon a
-;; material breach of its terms and conditions.
-;;
-;; 7. Nothing in this License Agreement shall be deemed to create any
-;; relationship of agency, partnership, or joint venture between PSF
-;; and Licensee. This License Agreement does not grant permission to
-;; use PSF trademarks or trade name in a trademark sense to endorse or
-;; promote products or services of Licensee, or any third party.
-;;
-;; 8. By copying, installing or otherwise using Python, Licensee
-;; agrees to be bound by the terms and conditions of this License
-;; Agreement.")
-
-(defvar wisent-make-parsers--ecmascript-license
- "\n;; It is derived from the grammar in the ECMAScript Language
-;; Specification published at
-;;
-;; https://www.ecma-international.org/publications/standards/Ecma-262.htm
-;;
-;; and redistributed under the following license:
-;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions
-;; are met:
-;;
-;; 1. Redistributions of source code must retain the above copyright
-;; notice, this list of conditions and the following disclaimer.
-;;
-;; 2. Redistributions in binary form must reproduce the above
-;; copyright notice, this list of conditions and the following
-;; disclaimer in the documentation and/or other materials provided
-;; with the distribution.
-;;
-;; 3. Neither the name of the authors nor Ecma International may be
-;; used to endorse or promote products derived from this software
-;; without specific prior written permission. THIS SOFTWARE IS
-;; PROVIDED BY THE ECMA INTERNATIONAL \"AS IS\" AND ANY EXPRESS OR
-;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-;; ARE DISCLAIMED. IN NO EVENT SHALL ECMA INTERNATIONAL BE LIABLE FOR
-;; ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
-;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
-;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
-;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
-;; DAMAGE.")
-
-(defvar wisent-make-parsers--parser-file-name
- `(("semantic/grammar-wy.el")
- ("srecode/srt-wy.el")
- ("semantic/wisent/js-wy.el"
- "Copyright (C) 1998-2011 Ecma International."
- ,wisent-make-parsers--ecmascript-license)
- ("semantic/wisent/javat-wy.el")
- ("semantic/wisent/python-wy.el"
- "Copyright (c) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
-\;; 2009, 2010 Python Software Foundation; All Rights Reserved"
- ,wisent-make-parsers--python-license)))
-
-;; Cf bovine--make-parser-1.
-(defun wisent--make-parser-1 (infile &optional outdir)
- (if outdir (setq outdir (file-name-directory (expand-file-name outdir))))
- (let ((packagename
- ;; This is with-demoted-errors.
- (condition-case err
- (with-current-buffer (find-file-noselect infile)
- (if outdir (setq default-directory outdir))
- (semantic-grammar-create-package t t))
- (error (message "%s" (error-message-string err)) nil)))
- output-data)
- (when (setq output-data (assoc packagename wisent-make-parsers--parser-file-name))
- (let ((additional-copyright (nth 1 output-data))
- (additional-license (nth 2 output-data))
- (filename (expand-file-name
- (progn (string-match ".*/\\(.*\\)" packagename)
- (match-string 1 packagename))
- outdir))
- copyright-end)
- ;; Touch up the generated parsers for Emacs integration.
- (with-temp-file filename
- (insert-file-contents filename)
- ;; Fix copyright header:
- (goto-char (point-min))
- (when additional-copyright
- (re-search-forward "Copyright (C).*$")
- (insert "\n;; " additional-copyright))
- (re-search-forward "^;; Author:")
- (setq copyright-end (match-beginning 0))
- (re-search-forward "^;;; Code:\n")
- (delete-region copyright-end (match-end 0))
- (goto-char copyright-end)
- (insert wisent-make-parsers--emacs-license)
- (insert "\n\n;;; Commentary:
-;;
-;; This file was generated from admin/grammars/"
- (file-name-nondirectory infile) ".")
- (when additional-license
- (insert "\n" additional-license))
- (insert "\n\n;;; Code:\n")
- (goto-char (point-min))
- (delete-region (point-min) (line-end-position))
- (insert ";;; " packagename
- " --- Generated parser support file "
- "-*- lexical-binding:t -*-")
- (re-search-forward ";;; \\(.*\\) ends here")
- (replace-match packagename nil nil nil 1)
- (delete-trailing-whitespace))))))
-
-(defun wisent-make-parsers ()
- "Generate Emacs' built-in Wisent-based parser files."
- (interactive)
- (semantic-mode 1)
- ;; Loop through each .wy file in current directory, and run
- ;; `semantic-grammar-batch-build-one-package' to build the grammar.
- (dolist (f (directory-files default-directory nil "\\.wy\\'"))
- (wisent--make-parser-1 f)))
-
-
-(defun wisent-batch-make-parser (&optional infile outdir)
- "Generate a Wisent parser from input INFILE, writing to OUTDIR.
-This is mainly intended for use in batch mode:
-
-emacs -batch -l semantic/wisent/grammar -f wisent-make-parser-batch \\
- [-dir output-dir | -o output-file] file.by
-
-If -o is supplied, only the directory part is used."
- (semantic-mode 1)
- (when (and noninteractive (not infile))
- (let (arg)
- (while command-line-args-left
- (setq arg (pop command-line-args-left))
- (cond ((string-equal arg "-dir")
- (setq outdir (pop command-line-args-left)))
- ((string-equal arg "-o")
- (setq outdir (file-name-directory (pop command-line-args-left))))
- (t (setq infile arg))))))
- (or infile (error "No input file specified"))
- (or (file-readable-p infile)
- (error "Input file `%s' not readable" infile))
- (wisent--make-parser-1 infile outdir))
-
-
-(provide 'semantic/wisent/grammar)
-
-;; Local variables:
-;; generated-autoload-load-name: "semantic/wisent/grammar"
-;; End:
-
-;;; semantic/wisent/grammar.el ends here
+++ /dev/null
-;;; semantic/wisent/java-tags.el --- Java LALR parser for Emacs -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2001-2006, 2009-2024 Free Software Foundation, Inc.
-
-;; Author: David Ponce <david@dponce.com>
-;; Created: 15 Dec 2001
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-
-;;; Code:
-
-(require 'semantic/wisent)
-(require 'semantic/wisent/javat-wy)
-(require 'semantic/java)
-
-;;;;
-;;;; Simple parser error reporting function
-;;;;
-
-(defun wisent-java-parse-error (msg)
- "Error reporting function called when a parse error occurs.
-MSG is the message string to report."
-;; (let ((error-start (nth 2 wisent-input)))
-;; (if (number-or-marker-p error-start)
-;; (goto-char error-start)))
- (message msg)
- ;;(debug)
- )
-
-;;;;
-;;;; Local context
-;;;;
-
-(define-mode-local-override semantic-get-local-variables
- java-mode ()
- "Get local values from a specific context.
-Parse the current context for `field_declaration' nonterminals to
-collect tags, such as local variables or prototypes.
-This function override `get-local-variables'."
- (let ((vars nil)
- (ct (semantic-current-tag))
- ;; We want nothing to do with funny syntaxing while doing this.
- (semantic-unmatched-syntax-hook nil))
- (while (not (semantic-up-context (point) 'function))
- (save-excursion
- (forward-char 1)
- (setq vars
- (append (semantic-parse-region
- (point)
- (save-excursion (semantic-end-of-context) (point))
- 'field_declaration
- 0 t)
- vars))))
- ;; Add 'this' if in a fcn
- (when (semantic-tag-of-class-p ct 'function)
- ;; Append a new tag THIS into our space.
- (setq vars (cons (semantic-tag-new-variable
- "this" (semantic-tag-name (semantic-current-tag-parent))
- nil)
- vars)))
- vars))
-
-;;;
-;;; Analyzer and type cache support
-;;;
-(define-mode-local-override semantic-analyze-split-name java-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 java-mode (namelist)
- "Assemble the list of names NAMELIST into a namespace name."
- (mapconcat #'identity namelist "."))
-
-
-
-;;;;
-;;;; Semantic integration of the Java LALR parser
-;;;;
-
-;; In semantic/imenu.el, not part of Emacs.
-(defvar semantic-imenu-summary-function)
-
-;;;###autoload
-(defun wisent-java-default-setup ()
- "Hook run to setup Semantic in `java-mode'.
-Use the alternate LALR(1) parser."
- (wisent-java-tags-wy--install-parser)
- (setq
- ;; Lexical analysis
- semantic-lex-number-expression semantic-java-number-regexp
- semantic-lex-analyzer #'wisent-java-tags-lexer
- ;; Parsing
- semantic-tag-expand-function #'semantic-java-expand-tag
- ;; Environment
- semantic-imenu-summary-function #'semantic-format-tag-prototype
- imenu-create-index-function #'semantic-create-imenu-index
- semantic-type-relation-separator-character '(".")
- semantic-command-separation-character ";"
- ;; speedbar and imenu buckets name
- semantic-symbol->name-assoc-list-for-type-parts
- ;; in type parts
- '((type . "Classes")
- (variable . "Variables")
- (function . "Methods"))
- semantic-symbol->name-assoc-list
- ;; everywhere
- (append semantic-symbol->name-assoc-list-for-type-parts
- '((include . "Imports")
- (package . "Package")))
- ;; navigation inside 'type children
- senator-step-at-tag-classes '(function variable)
- ;; Remove 'recursive from the default semanticdb find throttle
- ;; since java imports never recurse.
- semanticdb-find-default-throttle
- (remq 'recursive (default-value 'semanticdb-find-default-throttle))
- )
- ;; Setup javadoc stuff
- (semantic-java-doc-setup))
-
-(provide 'semantic/wisent/java-tags)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/wisent/java-tags"
-;; End:
-
-;;; semantic/wisent/java-tags.el ends here
+++ /dev/null
-;;; semantic/wisent/javascript.el --- javascript parser support -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2005, 2009-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Parser support for javascript language.
-
-
-;;; Code:
-(require 'semantic/java)
-(require 'semantic/wisent)
-(require 'semantic/wisent/js-wy)
-
-(defun wisent-javascript-jv-expand-tag (tag)
- "Expand TAG into a list of equivalent tags, or nil.
-Expand multiple variable declarations in the same statement, that is
-tags of class `variable' whose name is equal to a list of elements of
-the form (NAME VALUE START . END). NAME is a variable name. VALUE is
-an initializer START and END are the bounds in the declaration, related
-to this variable NAME."
- (let (elts elt value clone start end xpand)
- (when (and (eq 'variable (semantic-tag-class tag))
- (consp (setq elts (semantic-tag-name tag))))
- ;; There are multiple names in the same variable declaration.
- (while elts
- ;; For each name element, clone the initial tag and give it
- ;; the name of the element.
- (setq elt (car elts)
- elts (cdr elts)
- clone (semantic-tag-clone tag (car elt))
- value (car (cdr elt))
- start (if elts (car (cddr elt)) (semantic-tag-start tag))
- end (if xpand (cdr (cddr elt)) (semantic-tag-end tag))
- xpand (cons clone xpand))
- ;; Set the definition of the cloned tag
- (semantic-tag-put-attribute clone :default-value value)
- ;; Set the bounds of the cloned tag with those of the name
- ;; element.
- (semantic-tag-set-bounds clone start end))
- xpand)))
-
-;;; Override Methods
-;;
-;; These methods override aspects of how semantic-tools can access
-;; the tags created by the javascript parser.
-;; Local context
-(define-mode-local-override semantic-get-local-variables
- js-mode ()
- "Get local values from a specific context.
-This function overrides `get-local-variables'."
- ;; Does javascript have identifiable local variables?
- nil)
-
-(define-mode-local-override semantic-tag-protection js-mode (_tag &optional _parent)
- "Return protection information about TAG with optional PARENT.
-This function returns on of the following symbols:
- nil - No special protection. Language dependent.
- `public' - Anyone can access this TAG.
- `private' - Only methods in the local scope can access TAG.
- `protected' - Like private for outside scopes, like public for child
- classes.
-Some languages may choose to provide additional return symbols specific
-to themselves. Use of this function should allow for this.
-
-The default behavior (if not overridden with `tag-protection'
-is to return a symbol based on type modifiers."
- nil)
-
-(define-mode-local-override semantic-analyze-scope-calculate-access js-mode (_type _scope)
- "Calculate the access class for TYPE as defined by the current SCOPE.
-Access is related to the :parents in SCOPE. If type is a member of SCOPE
-then access would be `private'. If TYPE is inherited by a member of SCOPE,
-the access would be `protected'. Otherwise, access is `public'."
- nil)
-
-(define-mode-local-override semantic-ctxt-current-symbol js-mode (&optional point)
- "Return the current symbol the cursor is on at POINT in a list.
-This is a very simple implementation for Javascript symbols. It
-will at maximum do one split, so that the first part is seen as
-one type. For example: $('#sel').foo.bar will return (\"$('sel').foo\" \"bar\").
-This is currently needed for the mozrepl omniscient database."
- (save-excursion
- (if point (goto-char point))
- (let* ((case-fold-search semantic-case-fold)
- tmp end) ;; symlist
- (with-syntax-table semantic-lex-syntax-table
- (save-excursion
- (when (looking-at "\\w\\|\\s_")
- (forward-sexp 1))
- (setq end (point))
- (unless (re-search-backward "\\s-" (line-beginning-position) t)
- (beginning-of-line))
- (setq tmp (buffer-substring-no-properties (point) end))
- ;; (setq symlist
- (if (string-match "\\(.+\\)\\." tmp)
- (list (match-string 1 tmp)
- (substring tmp (1+ (match-end 1)) (length tmp)))
- (list tmp)))))));; )
-
-;;; Setup Function
-;;
-
-;; In semantic-imenu.el, not part of Emacs.
-(defvar semantic-imenu-summary-function)
-
-;;;###autoload
-(defun wisent-javascript-setup-parser ()
- "Setup buffer for parse."
- (wisent-javascript-jv-wy--install-parser)
- (setq
- ;; Lexical Analysis
- semantic-lex-analyzer #'javascript-lexer-jv
- semantic-lex-number-expression semantic-java-number-regexp
- ;; semantic-lex-depth nil ;; Full lexical analysis
- ;; Parsing
- semantic-tag-expand-function #'wisent-javascript-jv-expand-tag
- ;; Environment
- semantic-imenu-summary-function #'semantic-format-tag-name
- imenu-create-index-function #'semantic-create-imenu-index
- semantic-command-separation-character ";"
- ))
-
-(provide 'semantic/wisent/javascript-jv)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/wisent/javascript"
-;; End:
-
-;;; semantic/wisent/javascript-jv.el ends here
+++ /dev/null
-;;; wisent-python.el --- Semantic support for Python -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-
-;; Author: Richard Kim <emacs18@gmail.com>
-;; Created: June 2002
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Parser support for Python.
-
-;;; Code:
-
-(require 'python)
-
-(require 'semantic/wisent)
-(require 'semantic/wisent/python-wy)
-(require 'semantic/find)
-(require 'semantic/dep)
-(require 'semantic/ctxt)
-(require 'semantic/format)
-
-;;; Customization
-;;
-
-(defun semantic-python-get-system-include-path ()
- "Evaluate some Python code that determines the system include path."
- (delq nil
- (mapcar
- (lambda (dir)
- (when (file-directory-p dir)
- dir))
- (split-string
- (python-shell-internal-send-string
- "import sys;print ('\\n'.join(sys.path))")
- "\n" t))))
-
-(defcustom-mode-local-semantic-dependency-system-include-path
- python-mode semantic-python-dependency-system-include-path
- (when (and (featurep 'python)
- ;; python-mode and batch somehow often hangs.
- (not noninteractive))
- (semantic-python-get-system-include-path))
- "The system include path used by Python language.")
-\f
-;;; Lexical analysis
-;;
-
-;; Python strings are delimited by either single quotes or double
-;; quotes, e.g., "I'm a string" and 'I too am a string'.
-;; In addition a string can have either a 'r' and/or 'u' prefix.
-;; The 'r' prefix means raw, i.e., normal backslash substitutions are
-;; to be suppressed. For example, r"01\n34" is a string with six
-;; characters 0, 1, \, n, 3 and 4. The 'u' prefix means the following
-;; string is Unicode.
-(defconst wisent-python-string-start-re "[uU]?[rR]?['\"]"
- "Regexp matching beginning of a Python string.")
-
-(defconst wisent-python-string-re
- (rx
- (opt (any "uU")) (opt (any "rR"))
- (or
- ;; Triple-quoted string using apostrophes
- (: "'''" (zero-or-more (or "\\'"
- (not (any "'"))
- (: (repeat 1 2 "'") (not (any "'")))))
- "'''")
- ;; String using apostrophes
- (: "'" (zero-or-more (or "\\'"
- (not (any "'"))))
- "'")
- ;; Triple-quoted string using quotation marks.
- (: "\"\"\"" (zero-or-more (or "\\\""
- (not (any "\""))
- (: (repeat 1 2 "\"") (not (any "\"")))))
- "\"\"\"")
- ;; String using quotation marks.
- (: "\"" (zero-or-more (or "\\\""
- (not (any "\""))))
- "\"")))
- "Regexp matching a complete Python string.")
-
-(defvar wisent-python-EXPANDING-block nil
- "Non-nil when expanding a paren block for Python lexical analyzer.")
-
-(defun wisent-python-implicit-line-joining-p ()
- "Return non-nil if implicit line joining is active.
-That is, if inside an expression in parentheses, square brackets or
-curly braces."
- wisent-python-EXPANDING-block)
-
-(defsubst wisent-python-forward-string ()
- "Move point at the end of the Python string at point."
- (if (looking-at wisent-python-string-re)
- (let ((start (match-beginning 0))
- (end (match-end 0)))
- ;; Incomplete triple-quoted string gets matched instead as a
- ;; complete single quoted string. (This special case would be
- ;; unnecessary if Emacs regular expressions had negative
- ;; look-ahead assertions.)
- (when (and (= (- end start) 2)
- (looking-at "\"\\{3\\}\\|'\\{3\\}"))
- (error "Unterminated syntax"))
- (goto-char end))
- (error "Unterminated syntax")))
-
-(defun wisent-python-forward-balanced-expression ()
- "Move point to the end of the balanced expression at point.
-Here “balanced expression” means anything matched by Emacs's
-open/close parenthesis syntax classes. We can't use forward-sexp
-for this because that Emacs built-in can't parse Python's
-triple-quoted string syntax."
- (let ((end-char (cdr (syntax-after (point)))))
- (forward-char 1)
- (while (not (or (eobp) (eq (char-after (point)) end-char)))
- (cond
- ;; Skip over python strings.
- ((looking-at wisent-python-string-start-re)
- (wisent-python-forward-string))
- ;; At a comment start just goto end of line.
- ((looking-at "\\s<")
- (end-of-line))
- ;; Skip over balanced expressions.
- ((looking-at "\\s(")
- (wisent-python-forward-balanced-expression))
- ;; Skip over white space, word, symbol, punctuation, paired
- ;; delimiter (backquote) characters, line continuation, and end
- ;; of comment characters (AKA newline characters in Python).
- ((zerop (skip-syntax-forward "-w_.$\\>"))
- (error "Can't figure out how to go forward from here"))))
- ;; Skip closing character. As a last resort this should raise an
- ;; error if we hit EOB before we find our closing character..
- (forward-char 1)))
-
-(defun wisent-python-forward-line ()
- "Move point to the beginning of the next logical line.
-Usually this is simply the next physical line unless strings,
-implicit/explicit line continuation, blank lines, or comment lines are
-encountered. This function skips over such items so that the point is
-at the beginning of the next logical line. If the current logical
-line ends at the end of the buffer, leave the point there."
- (while (not (eolp))
- (when (= (point)
- (progn
- (cond
- ;; Skip over python strings.
- ((looking-at wisent-python-string-start-re)
- (wisent-python-forward-string))
- ;; At a comment start just goto end of line.
- ((looking-at "\\s<")
- (end-of-line))
- ;; Skip over balanced expressions.
- ((looking-at "\\s(")
- (wisent-python-forward-balanced-expression))
- ;; At the explicit line continuation character
- ;; (backslash) move to next line.
- ((looking-at "\\s\\")
- (forward-line 1))
- ;; Skip over white space, word, symbol, punctuation,
- ;; and paired delimiter (backquote) characters.
- ((skip-syntax-forward "-w_.$)")))
- (point)))
- (error "python-forward-line endless loop detected")))
- ;; The point is at eol, skip blank and comment lines.
- (forward-comment (point-max))
- ;; Goto the beginning of the next line.
- (or (eobp) (beginning-of-line)))
-
-(defun wisent-python-forward-line-skip-indented ()
- "Move point to the next logical line, skipping indented lines.
-That is the next line whose indentation is less than or equal to
-the indentation of the current line."
- (let ((indent (current-indentation)))
- (while (progn (wisent-python-forward-line)
- (and (not (eobp))
- (> (current-indentation) indent))))))
-
-(defun wisent-python-end-of-block ()
- "Move point to the end of the current block."
- (let ((indent (current-indentation)))
- (while (and (not (eobp)) (>= (current-indentation) indent))
- (wisent-python-forward-line-skip-indented))
- ;; Don't include final comments in current block bounds
- (forward-comment (- (point-max)))
- (or (bolp) (forward-line 1))
- ))
-
-;; Indentation stack, what the Python (2.3) language spec. says:
-;;
-;; The indentation levels of consecutive lines are used to generate
-;; INDENT and DEDENT tokens, using a stack, as follows.
-;;
-;; Before the first line of the file is read, a single zero is pushed
-;; on the stack; this will never be popped off again. The numbers
-;; pushed on the stack will always be strictly increasing from bottom
-;; to top. At the beginning of each logical line, the line's
-;; indentation level is compared to the top of the stack. If it is
-;; equal, nothing happens. If it is larger, it is pushed on the stack,
-;; and one INDENT token is generated. If it is smaller, it must be one
-;; of the numbers occurring on the stack; all numbers on the stack
-;; that are larger are popped off, and for each number popped off a
-;; DEDENT token is generated. At the end of the file, a DEDENT token
-;; is generated for each number remaining on the stack that is larger
-;; than zero.
-(defvar wisent-python-indent-stack)
-
-(define-lex-analyzer wisent-python-lex-beginning-of-line
- "Detect and create Python indentation tokens at beginning of line."
- (and
- (bolp) (not (wisent-python-implicit-line-joining-p))
- (let ((last-indent (car wisent-python-indent-stack))
- (last-pos (point))
- (curr-indent (current-indentation)))
- (skip-syntax-forward "-")
- (cond
- ;; Skip comments and blank lines. No change in indentation.
- ((or (eolp) (looking-at semantic-lex-comment-regex))
- (forward-comment (point-max))
- (or (eobp) (beginning-of-line))
- (setq semantic-lex-end-point (point))
- ;; Loop lexer to handle the next line.
- t)
- ;; No change in indentation.
- ((= curr-indent last-indent)
- (setq semantic-lex-end-point (point))
- ;; Try next analyzers.
- nil)
- ;; Indentation increased
- ((> curr-indent last-indent)
- (if (or (not semantic-lex-maximum-depth)
- (< semantic-lex-current-depth semantic-lex-maximum-depth))
- (progn
- ;; Return an INDENT lexical token
- (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
- (push curr-indent wisent-python-indent-stack)
- (semantic-lex-push-token
- (semantic-lex-token 'INDENT last-pos (point))))
- ;; Add an INDENT_BLOCK token
- (semantic-lex-push-token
- (semantic-lex-token
- 'INDENT_BLOCK
- (progn (beginning-of-line) (point))
- (semantic-lex-unterminated-syntax-protection 'INDENT_BLOCK
- (wisent-python-end-of-block)
- (point)))))
- ;; Loop lexer to handle tokens in current line.
- t)
- ;; Indentation decreased
- (t
- ;; Pop items from indentation stack
- (while (< curr-indent last-indent)
- (pop wisent-python-indent-stack)
- (setq semantic-lex-current-depth (1- semantic-lex-current-depth)
- last-indent (car wisent-python-indent-stack))
- (semantic-lex-push-token
- (semantic-lex-token 'DEDENT last-pos (point))))
- ;; (if (= last-pos (point))
- ;; ;; If pos did not change, then we must return nil so that
- ;; ;; other lexical analyzers can be run.
- ;; nil)
- ))))
- ;; All the work was done in the above analyzer matching condition.
- )
-
-(define-lex-regex-analyzer wisent-python-lex-end-of-line
- "Detect and create Python newline tokens.
-Just skip the newline character if the following line is an implicit
-continuation of current line."
- "\\(\n\\|\\s>\\)"
- (if (wisent-python-implicit-line-joining-p)
- (setq semantic-lex-end-point (match-end 0))
- (semantic-lex-push-token
- (semantic-lex-token 'NEWLINE (point) (match-end 0)))))
-
-(define-lex-regex-analyzer wisent-python-lex-string
- "Detect and create python string tokens."
- wisent-python-string-start-re
- (semantic-lex-push-token
- (semantic-lex-token
- 'STRING_LITERAL
- (point)
- (semantic-lex-unterminated-syntax-protection 'STRING_LITERAL
- (wisent-python-forward-string)
- (point)))))
-
-(define-lex-regex-analyzer wisent-python-lex-ignore-backslash
- "Detect and skip over backslash (explicit line joining) tokens.
-A backslash must be the last token of a physical line, it is illegal
-elsewhere on a line outside a string literal."
- "\\s\\\\s-*$"
- ;; Skip over the detected backslash and go to the first
- ;; non-whitespace character in the next physical line.
- (forward-line)
- (skip-syntax-forward "-")
- (setq semantic-lex-end-point (point)))
-
-(define-lex wisent-python-lexer
- "Lexical Analyzer for Python code."
- ;; Must analyze beginning of line first to handle indentation.
- wisent-python-lex-beginning-of-line
- wisent-python-lex-end-of-line
- ;; Must analyze string before symbol to handle string prefix.
- wisent-python-lex-string
- ;; Analyzers auto-generated from grammar.
- wisent-python-wy--<number>-regexp-analyzer
- wisent-python-wy--<keyword>-keyword-analyzer
- wisent-python-wy--<symbol>-regexp-analyzer
- wisent-python-wy--<block>-block-analyzer
- wisent-python-wy--<punctuation>-string-analyzer
- ;; Ignored things.
- wisent-python-lex-ignore-backslash
- semantic-lex-ignore-whitespace
- semantic-lex-ignore-comments
- ;; Signal error on unhandled syntax.
- semantic-lex-default-action)
-
-\f
-;;; Parsing
-;;
-
-(defun wisent-python-reconstitute-function-tag (tag suite)
- "Move a docstring from TAG's members into its :documentation attribute.
-Set attributes for constructors, special, private and static methods."
- ;; Analyze first statement to see whether it is a documentation
- ;; string.
- (let ((first-statement (car suite)))
- (when (semantic-python-docstring-p first-statement)
- (semantic-tag-put-attribute
- tag :documentation
- (semantic-python-extract-docstring first-statement))))
-
- ;; TODO HACK: we try to identify methods using the following
- ;; heuristic:
- ;; + at least one argument
- ;; + first argument is self
- (when (and (> (length (semantic-tag-function-arguments tag)) 0)
- (string= (semantic-tag-name
- (car (semantic-tag-function-arguments tag)))
- "self"))
- (semantic-tag-put-attribute tag :parent "dummy"))
-
- ;; Identify constructors, special and private functions
- (cond
- ;; TODO only valid when the function resides inside a class
- ((string= (semantic-tag-name tag) "__init__")
- (semantic-tag-put-attribute tag :constructor-flag t)
- (semantic-tag-put-attribute tag :suite suite))
-
- ((semantic-python-special-p tag)
- (semantic-tag-put-attribute tag :special-flag t))
-
- ((semantic-python-private-p tag)
- (semantic-tag-put-attribute tag :protection "private")))
-
- ;; If there is a staticmethod decorator, add a static typemodifier
- ;; for the function.
- (when (semantic-find-tags-by-name
- "staticmethod"
- (semantic-tag-get-attribute tag :decorators))
- (semantic-tag-put-attribute
- tag :typemodifiers
- (cons "static"
- (semantic-tag-get-attribute tag :typemodifiers))))
-
- ;; TODO
- ;; + check for decorators classmethod
- ;; + check for operators
- tag)
-
-(defun wisent-python-reconstitute-class-tag (tag)
- "Move a docstring from TAG's members into its :documentation attribute."
- ;; The first member of TAG may be a documentation string. If that is
- ;; the case, remove of it from the members list and stick its
- ;; content into the :documentation attribute.
- (let ((first-member (car (semantic-tag-type-members tag))))
- (when (semantic-python-docstring-p first-member)
- (semantic-tag-put-attribute
- tag :members
- (cdr (semantic-tag-type-members tag)))
- (semantic-tag-put-attribute
- tag :documentation
- (semantic-python-extract-docstring first-member))))
-
- ;; Try to find the constructor, determine the name of the instance
- ;; parameter, find assignments to instance variables and add
- ;; corresponding variable tags to the list of members.
- (dolist (member (semantic-tag-type-members tag))
- (when (semantic-tag-function-constructor-p member)
- (let ((self (semantic-tag-name
- (car (semantic-tag-function-arguments member)))))
- (dolist (statement (semantic-tag-get-attribute member :suite))
- (when (semantic-python-instance-variable-p statement self)
- (let ((variable (semantic-tag-clone
- statement
- (substring (semantic-tag-name statement) 5)))
- (members (semantic-tag-get-attribute tag :members)))
- (when (semantic-python-private-p variable)
- (semantic-tag-put-attribute variable :protection "private"))
- (setcdr (last members) (list variable))))))))
-
- ;; TODO remove the :suite attribute
- tag)
-
-(defun semantic-python-expand-tag (tag)
- "Expand compound declarations found in TAG into separate tags.
-TAG contains compound declaration if the NAME part of the tag is
-a list. In python, this can happen with `import' statements."
- (let ((class (semantic-tag-class tag))
- (elts (semantic-tag-name tag))
- (expand nil))
- (cond
- ((and (eq class 'include) (listp elts))
- (dolist (E elts)
- (setq expand (cons (semantic-tag-clone tag E) expand)))
- (setq expand (nreverse expand)))
- )))
-
-
-\f
-;;; Overridden Semantic API.
-;;
-
-(define-mode-local-override semantic-lex python-mode
- (start end &optional depth length)
- "Lexically analyze Python code in current buffer.
-See the function `semantic-lex' for the meaning of the START, END,
-DEPTH and LENGTH arguments.
-This function calls `wisent-python-lexer' to actually perform the
-lexical analysis, then emits the necessary Python DEDENT tokens from
-what remains in the `wisent-python-indent-stack'."
- (let* ((wisent-python-indent-stack (list 0))
- (stream (wisent-python-lexer start end depth length))
- (semantic-lex-token-stream nil))
- ;; Emit DEDENT tokens if something remains in the INDENT stack.
- (while (> (pop wisent-python-indent-stack) 0)
- (semantic-lex-push-token (semantic-lex-token 'DEDENT end end)))
- (nconc stream (nreverse semantic-lex-token-stream))))
-
-(define-mode-local-override semantic-get-local-variables python-mode ()
- "Get the local variables based on point's context.
-To be implemented for Python! For now just return nil."
- nil)
-
-;; Adapted from the semantic Java support by Andrey Torba
-(define-mode-local-override semantic-tag-include-filename python-mode (tag)
- "Return a suitable path for (some) Python imports."
- (let ((name (semantic-tag-name tag)))
- (concat (mapconcat #'identity (split-string name "\\.") "/") ".py")))
-
-;; Override ctxt-current-function/assignment defaults, since they do
-;; not work properly with Python code, even leading to endless loops
-;; (see bug #xxxxx).
-(define-mode-local-override semantic-ctxt-current-function python-mode (&optional _point)
- "Return the current function call the cursor is in at POINT.
-The function returned is the one accepting the arguments that
-the cursor is currently in. It will not return function symbol if the
-cursor is on the text representing that function."
- nil)
-
-(define-mode-local-override semantic-ctxt-current-assignment python-mode (&optional _point)
- "Return the current assignment near the cursor at POINT.
-Return a list as per `semantic-ctxt-current-symbol'.
-Return nil if there is nothing relevant."
- nil)
-
-;;; Tag Formatting
-;;
-(define-mode-local-override semantic-format-tag-abbreviate python-mode (tag &optional parent color)
- "Format an abbreviated tag for python.
-Shortens `code' tags, but passes through for others."
- (cond ((semantic-tag-of-class-p tag 'code)
- ;; Just take the first line.
- (let ((name (semantic-tag-name tag)))
- (when (string-match "\n" name)
- (setq name (substring name 0 (match-beginning 0))))
- name))
- (t
- (semantic-format-tag-abbreviate-default tag parent color))))
-
-;;; Enable Semantic in `python-mode'.
-;;
-
-;;;###autoload
-(defun wisent-python-default-setup ()
- "Setup buffer for parse."
- (wisent-python-wy--install-parser)
- (setq-local parse-sexp-ignore-comments t)
- ;; Give python modes the possibility to overwrite this:
- (if (not comment-start-skip)
- (setq-local comment-start-skip "#+\\s-*"))
- (setq
- ;; Character used to separation a parent/child relationship
- semantic-type-relation-separator-character '(".")
- semantic-command-separation-character ";"
- ;; Parsing
- semantic-tag-expand-function #'semantic-python-expand-tag
-
- ;; Semantic to take over from the one provided by python.
- ;; The python one, if it uses the senator advice, will hang
- ;; Emacs unrecoverably.
- imenu-create-index-function #'semantic-create-imenu-index
-
- ;; I need a python guru to update this list:
- semantic-symbol->name-assoc-list-for-type-parts '((variable . "Variables")
- (function . "Methods"))
- semantic-symbol->name-assoc-list '((type . "Classes")
- (variable . "Variables")
- (function . "Functions")
- (include . "Imports")
- (package . "Package")
- (code . "Code")))
- )
-
-\f
-;;; Utility functions
-;;
-
-(defun semantic-python-special-p (tag)
- "Return non-nil if the name of TAG is a special identifier of
-the form __NAME__. "
- (string-match
- (rx (seq string-start "__" (1+ (syntax symbol)) "__" string-end))
- (semantic-tag-name tag)))
-
-(defun semantic-python-private-p (tag)
- "Return non-nil if the name of TAG follows the convention _NAME
-for private names."
- (string-match
- (rx (seq string-start "_" (0+ (syntax symbol)) string-end))
- (semantic-tag-name tag)))
-
-(defun semantic-python-instance-variable-p (tag &optional self)
- "Return non-nil if TAG is an instance variable of the instance
-SELF or the instance name \"self\" if SELF is nil."
- (when (semantic-tag-of-class-p tag 'variable)
- (let ((name (semantic-tag-name tag)))
- (when (string-match
- (rx-to-string
- `(seq string-start ,(or self "self") "."))
- name)
- (not (string-search "." (substring name 5)))))))
-
-(defun semantic-python-docstring-p (tag)
- "Return non-nil, when TAG is a Python documentation string."
- ;; TAG is considered to be a documentation string if the first
- ;; member is of class 'code and its name looks like a documentation
- ;; string.
- (let ((class (semantic-tag-class tag))
- (name (semantic-tag-name tag)))
- (and (eq class 'code)
- (string-match
- (rx (seq string-start "\"\"\"" (0+ anything) "\"\"\"" string-end))
- name))))
-
-(defun semantic-python-extract-docstring (tag)
- "Return the Python documentation string contained in TAG."
- ;; Strip leading and trailing """
- (let ((name (semantic-tag-name tag)))
- (substring name 3 -3)))
-
-\f
-;;; Test
-;;
-
-(defun wisent-python-lex-buffer ()
- "Run `wisent-python-lexer' on current buffer."
- (interactive)
- (semantic-lex-init)
- (let ((token-stream (semantic-lex (point-min) (point-max) 0)))
- (with-current-buffer (get-buffer-create "*wisent-python-lexer*")
- (erase-buffer)
- (pp token-stream (current-buffer))
- (goto-char (point-min))
- (pop-to-buffer (current-buffer)))))
-
-(provide 'semantic/wisent/python)
-
-;; Local variables:
-;; generated-autoload-file: "../loaddefs.el"
-;; generated-autoload-load-name: "semantic/wisent/python"
-;; End:
-
-;;; semantic/wisent/python.el ends here
+++ /dev/null
-;;; semantic/wisent/wisent.el --- GNU Bison for Emacs - Runtime -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2002-2024 Free Software Foundation, Inc.
-
-;; Author: David Ponce <david@dponce.com>
-;; Created: 30 January 2002
-;; Keywords: syntax
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Parser engine and runtime of Wisent.
-;;
-;; Wisent (the European Bison ;-) is an Elisp implementation of the
-;; GNU Compiler Compiler Bison. The Elisp code is a port of the C
-;; code of GNU Bison 1.28 & 1.31.
-;;
-;; For more details on the basic concepts for understanding Wisent,
-;; read the Bison manual ;)
-;;
-;; For more details on Wisent itself read the Wisent manual.
-
-;;; Code:
-
-(defgroup wisent nil
- "
- /\\_.-^^^-._/\\ The GNU
- \\_ _/
- ( \\=`o \\=` (European ;-) Bison
- \\ \\=` /
- ( D ,\" for Emacs!
- \\=` ~ ,\"
- \\=`\"\""
- :group 'semantic)
-
-\f
-;;;; -------------
-;;;; Runtime stuff
-;;;; -------------
-
-(define-obsolete-function-alias 'wisent-char-p
- #'characterp "28.1")
-
-;;; Printed representation of terminals and nonterminals
-(defconst wisent-escape-sequence-strings
- '(
- (?\a . "'\\a'") ; C-g
- (?\b . "'\\b'") ; backspace, BS, C-h
- (?\t . "'\\t'") ; tab, TAB, C-i
- (?\n . "'\\n'") ; newline, C-j
- (?\v . "'\\v'") ; vertical tab, C-k
- (?\f . "'\\f'") ; formfeed character, C-l
- (?\r . "'\\r'") ; carriage return, RET, C-m
- (?\e . "'\\e'") ; escape character, ESC, C-[
- (?\\ . "'\\'") ; backslash character, \
- (?\d . "'\\d'") ; delete character, DEL
- )
- "Printed representation of usual escape sequences.")
-
-(defsubst wisent-item-to-string (item)
- "Return a printed representation of ITEM.
-ITEM can be a nonterminal or terminal symbol, or a character literal."
- (if (characterp item)
- (or (cdr (assq item wisent-escape-sequence-strings))
- (format "'%c'" item))
- (symbol-name item)))
-
-(defsubst wisent-token-to-string (token)
- "Return a printed representation of lexical token TOKEN."
- (format "%s%s(%S)" (wisent-item-to-string (car token))
- (if (nth 2 token) (format "@%s" (nth 2 token)) "")
- (nth 1 token)))
-
-;;; Special symbols
-(defconst wisent-eoi-term '$EOI
- "End Of Input token.")
-
-(defconst wisent-error-term 'error
- "Error recovery token.")
-
-(defconst wisent-accept-tag 'accept
- "Accept result after input successfully parsed.")
-
-(defconst wisent-error-tag 'error
- "Process a syntax error.")
-
-;;; Special functions
-(defun wisent-automaton-p (obj)
- "Return non-nil if OBJ is a LALR automaton.
-If OBJ is a symbol check its value."
- (and obj (symbolp obj) (boundp obj)
- (setq obj (symbol-value obj)))
- (and (vectorp obj) (= 4 (length obj))
- (vectorp (aref obj 0)) (vectorp (aref obj 1))
- (= (length (aref obj 0)) (length (aref obj 1)))
- (listp (aref obj 2)) (obarrayp (aref obj 3))))
-
-(defsubst wisent-region (&rest positions)
- "Return the start/end positions of the region including POSITIONS.
-Each element of POSITIONS is a pair (START-POS . END-POS) or nil. The
-returned value is the pair (MIN-START-POS . MAX-END-POS) or nil if no
-POSITIONS are available."
- (let ((pl (delq nil positions)))
- (if pl
- (cons (apply #'min (mapcar #'car pl))
- (apply #'max (mapcar #'cdr pl))))))
-
-;;; Reporting
-(defcustom wisent-parse-verbose-flag nil
- "Non-nil means to issue more messages while parsing."
- :type 'boolean)
-
-(defun wisent-parse-toggle-verbose-flag ()
- "Toggle whether to issue more messages while parsing."
- (interactive)
- (setq wisent-parse-verbose-flag (not wisent-parse-verbose-flag))
- (when (called-interactively-p 'interactive)
- (message "More messages while parsing %sabled"
- (if wisent-parse-verbose-flag "en" "dis"))))
-
-(defsubst wisent-message (string &rest args)
- "Print a one-line message if `wisent-parse-verbose-flag' is set.
-Pass STRING and ARGS arguments to `message'."
- (and wisent-parse-verbose-flag
- (apply #'message string args)))
-\f
-;;;; --------------------
-;;;; The LR parser engine
-;;;; --------------------
-
-(defcustom wisent-parse-max-stack-size 500
- "The parser stack size."
- :type 'integer)
-
-(defcustom wisent-parse-max-recover 3
- "Number of tokens to shift before turning off error status."
- :type 'integer)
-
-(defvar wisent-discarding-token-functions nil
- "List of functions to be called when discarding a lexical token.
-These functions receive the lexical token discarded.
-When the parser encounters unexpected tokens, it can discards them,
-based on what directed by error recovery rules. Either when the
-parser reads tokens until one is found that can be shifted, or when an
-semantic action calls the function `wisent-skip-token' or
-`wisent-skip-block'.
-For language specific hooks, make sure you define this as a local
-hook.")
-
-(defvar wisent-pre-parse-hook nil
- "Normal hook run just before entering the LR parser engine.")
-
-(defvar wisent-post-parse-hook nil
- "Normal hook run just after the LR parser engine terminated.")
-
-(defvar wisent-loop nil
- "The current parser action.
-Stop parsing when set to nil.
-This variable only has meaning in the scope of `wisent-parse'.")
-
-(defvar wisent-nerrs nil
- "The number of parse errors encountered so far.")
-
-(defvar wisent-lookahead nil
- "The lookahead lexical token.
-This value is non-nil if the parser terminated because of an
-unrecoverable error.")
-
-;; Variables and macros that are useful in semantic actions.
-(defvar wisent-parse-lexer-function nil
- "The user supplied lexer function.
-This function don't have arguments.
-This variable only has meaning in the scope of `wisent-parse'.")
-
-(defvar wisent-parse-error-function nil
- "The user supplied error function.
-This function must accept one argument, a message string.
-This variable only has meaning in the scope of `wisent-parse'.")
-
-(defvar wisent-input nil
- "The last token read.
-This variable only has meaning in the scope of `wisent-parse'.")
-
-(defvar wisent-recovering nil
- "Non-nil means that the parser is recovering.
-This variable only has meaning in the scope of `wisent-parse'.")
-
-;; Variables that only have meaning in the scope of a semantic action.
-;; These global definitions avoid byte-compiler warnings.
-(defvar $region nil)
-(defvar $nterm nil)
-(defvar $action nil)
-
-(defmacro wisent-lexer ()
- "Obtain the next terminal in input."
- '(funcall wisent-parse-lexer-function))
-
-(defmacro wisent-error (msg)
- "Call the user supplied error reporting function with message MSG."
- `(funcall wisent-parse-error-function ,msg))
-
-(defmacro wisent-errok ()
- "Resume generating error messages immediately for subsequent syntax errors.
-This is useful primarily in error recovery semantic actions."
- '(setq wisent-recovering nil))
-
-(defmacro wisent-clearin ()
- "Discard the current lookahead token.
-This will cause a new lexical token to be read.
-This is useful primarily in error recovery semantic actions."
- '(setq wisent-input nil))
-
-(defmacro wisent-abort ()
- "Abort parsing and save the lookahead token.
-This is useful primarily in error recovery semantic actions."
- '(setq wisent-lookahead wisent-input
- wisent-loop nil))
-
-(defmacro wisent-set-region (start end)
- "Change the region of text matched by the current nonterminal.
-START and END are respectively the beginning and end positions of the
-region. If START or END values are not a valid positions the region
-is set to nil."
- `(setq $region (and (number-or-marker-p ,start)
- (number-or-marker-p ,end)
- (cons ,start ,end))))
-
-(defun wisent-skip-token ()
- "Skip the lookahead token in order to resume parsing.
-Return nil.
-Must be used in error recovery semantic actions."
- (if (eq (car wisent-input) wisent-eoi-term)
- ;; Does nothing at EOI to avoid infinite recovery loop.
- nil
- (wisent-message "%s: skip %s" $action
- (wisent-token-to-string wisent-input))
- (run-hook-with-args
- 'wisent-discarding-token-functions wisent-input)
- (wisent-clearin)
- (wisent-errok)))
-
-(defun wisent-skip-block (&optional bounds)
- "Safely skip a parenthesized block in order to resume parsing.
-Return nil.
-Must be used in error recovery semantic actions.
-Optional argument BOUNDS is a pair (START . END) which indicates where
-the parenthesized block starts. Typically the value of a `$regionN'
-variable, where `N' is the Nth element of the current rule components
-that match the block beginning. It defaults to the value of the
-`$region' variable."
- (let ((start (car (or bounds $region)))
- end input)
- (if (not (number-or-marker-p start))
- ;; No nonterminal region available, skip the lookahead token.
- (wisent-skip-token)
- ;; Try to skip a block.
- (if (not (setq end (save-excursion
- (goto-char start)
- (and (looking-at "\\s(")
- (condition-case nil
- (1- (scan-lists (point) 1 0))
- (error nil))))))
- ;; Not actually a block, skip the lookahead token.
- (wisent-skip-token)
- ;; OK to safely skip the block, so read input until a matching
- ;; close paren or EOI is encountered.
- (setq input wisent-input)
- (while (and (not (eq (car input) wisent-eoi-term))
- (< (nth 2 input) end))
- (run-hook-with-args
- 'wisent-discarding-token-functions input)
- (setq input (wisent-lexer)))
- (wisent-message "%s: in enclosing block, skip from %s to %s"
- $action
- (wisent-token-to-string wisent-input)
- (wisent-token-to-string input))
- (if (eq (car wisent-input) wisent-eoi-term)
- ;; Does nothing at EOI to avoid infinite recovery loop.
- nil
- (wisent-clearin)
- (wisent-errok))
- ;; Set end of $region to end of block.
- (wisent-set-region (car $region) (1+ end))
- nil))))
-
-;;; Core parser engine
-(defsubst wisent-production-bounds (stack i j)
- "Determine the start and end locations of a production value.
-Return a pair (START . END), where START is the first available start
-location, and END the last available end location, in components
-values of the rule currently reduced.
-Return nil when no component location is available.
-STACK is the parser stack.
-I and J are the indices in STACK of respectively the value of the
-first and last components of the current rule.
-This function is for internal use by semantic actions' generated
-lambda-expression."
- (let ((f (cadr (aref stack i)))
- (l (cddr (aref stack j))))
- (while (/= i j)
- (cond
- ((not f) (setq f (cadr (aref stack (setq i (+ i 2))))))
- ((not l) (setq l (cddr (aref stack (setq j (- j 2))))))
- ((setq i j))))
- (and f l (cons f l))))
-
-(defmacro wisent-parse-action (i al)
- "Return the next parser action.
-I is a token item number and AL is the list of (item . action)
-available at current state. The first element of AL contains the
-default action for this state."
- `(cdr (or (assq ,i ,al) (car ,al))))
-
-(defsubst wisent-parse-start (start starts)
- "Return the first lexical token to shift for START symbol.
-STARTS is the table of allowed start symbols or nil if the LALR
-automaton has only one entry point."
- (if (null starts)
- ;; Only one entry point, return the first lexical token
- ;; available in input.
- (wisent-lexer)
- ;; Multiple start symbols defined, return the internal lexical
- ;; token associated to START. By default START is the first
- ;; nonterminal defined in STARTS.
- (let ((token (cdr (if start (assq start starts) (car starts)))))
- (if token
- (list token (symbol-name token))
- (error "Invalid start symbol %s" start)))))
-
-(defun wisent-parse (automaton lexer &optional error start)
- "Parse input using the automaton specified in AUTOMATON.
-
-- AUTOMATON is an LALR(1) automaton generated by
- `wisent-compile-grammar'.
-
-- LEXER is a function with no argument called by the parser to obtain
- the next terminal (token) in input.
-
-- ERROR is an optional reporting function called when a parse error
- occurs. It receives a message string to report. It defaults to the
- function `wisent-message'.
-
-- START specify the start symbol (nonterminal) used by the parser as
- its goal. It defaults to the start symbol defined in the grammar
- (see also `wisent-compile-grammar')."
- (run-hooks 'wisent-pre-parse-hook)
- (let* ((actions (aref automaton 0))
- (gotos (aref automaton 1))
- (starts (aref automaton 2))
- (stack (make-vector wisent-parse-max-stack-size nil))
- (sp 0)
- (wisent-loop t)
- (wisent-parse-error-function (or error 'wisent-message))
- (wisent-parse-lexer-function lexer)
- (wisent-recovering nil)
- (wisent-input (wisent-parse-start start starts))
- state tokid choices choice)
- (setq wisent-nerrs 0 ;; Reset parse error counter
- wisent-lookahead nil) ;; and lookahead token
- (aset stack 0 0) ;; Initial state
- (while wisent-loop
- (setq state (aref stack sp)
- tokid (car wisent-input)
- wisent-loop (wisent-parse-action tokid (aref actions state)))
- (cond
-
- ;; Input successfully parsed
- ;; -------------------------
- ((eq wisent-loop wisent-accept-tag)
- (setq wisent-loop nil))
-
- ;; Syntax error in input
- ;; ---------------------
- ((eq wisent-loop wisent-error-tag)
- ;; Report this error if not already recovering from an error.
- (setq choices (aref actions state))
- (or wisent-recovering
- (wisent-error
- (format "Syntax error, unexpected %s, expecting %s"
- (wisent-token-to-string wisent-input)
- (mapconcat #'wisent-item-to-string
- (delq wisent-error-term
- (mapcar #'car (cdr choices)))
- ", "))))
- ;; Increment the error counter
- (setq wisent-nerrs (1+ wisent-nerrs))
- ;; If just tried and failed to reuse lookahead token after an
- ;; error, discard it.
- (if (eq wisent-recovering wisent-parse-max-recover)
- (if (eq tokid wisent-eoi-term)
- (wisent-abort) ;; Terminate if at end of input.
- (wisent-message "Error recovery: skip %s"
- (wisent-token-to-string wisent-input))
- (run-hook-with-args
- 'wisent-discarding-token-functions wisent-input)
- (setq wisent-input (wisent-lexer)))
-
- ;; Else will try to reuse lookahead token after shifting the
- ;; error token.
-
- ;; Each real token shifted decrements this.
- (setq wisent-recovering wisent-parse-max-recover)
- ;; Pop the value/state stack to see if an action associated
- ;; to special terminal symbol 'error exists.
- (while (and (>= sp 0)
- (not (and (setq state (aref stack sp)
- choices (aref actions state)
- choice (assq wisent-error-term choices))
- (natnump (cdr choice)))))
- (setq sp (- sp 2)))
-
- (if (not choice)
- ;; No 'error terminal was found. Just terminate.
- (wisent-abort)
- ;; Try to recover and continue parsing.
- ;; Shift the error terminal.
- (setq state (cdr choice) ; new state
- sp (+ sp 2))
- (aset stack (1- sp) nil) ; push value
- (aset stack sp state) ; push new state
- ;; Adjust input to error recovery state. Unless 'error
- ;; triggers a reduction, eat the input stream until an
- ;; expected terminal symbol is found, or EOI is reached.
- (if (cdr (setq choices (aref actions state)))
- (while (not (or (eq (car wisent-input) wisent-eoi-term)
- (assq (car wisent-input) choices)))
- (wisent-message "Error recovery: skip %s"
- (wisent-token-to-string wisent-input))
- (run-hook-with-args
- 'wisent-discarding-token-functions wisent-input)
- (setq wisent-input (wisent-lexer)))))))
-
- ;; Shift current token on top of the stack
- ;; ---------------------------------------
- ((natnump wisent-loop)
- ;; Count tokens shifted since error; after
- ;; `wisent-parse-max-recover', turn off error status.
- (setq wisent-recovering (and (natnump wisent-recovering)
- (> wisent-recovering 1)
- (1- wisent-recovering)))
- (setq sp (+ sp 2))
- (aset stack (1- sp) (cdr wisent-input))
- (aset stack sp wisent-loop)
- (setq wisent-input (wisent-lexer)))
-
- ;; Reduce by rule (call semantic action)
- ;; -------------------------------------
- (t
- (setq sp (funcall wisent-loop stack sp gotos))
- (or wisent-input (setq wisent-input (wisent-lexer))))))
- (run-hooks 'wisent-post-parse-hook)
- (car (aref stack 1))))
-
-(provide 'semantic/wisent/wisent)
-
-;; Local variables:
-;; generated-autoload-load-name: "semantic/wisent/wisent"
-;; End:
-
-;;; semantic/wisent/wisent.el ends here
+++ /dev/null
-;;; srecode.el --- Semantic buffer evaluator. -*- lexical-binding: t -*-
-
-;; Copyright (C) 2005-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: codegeneration
-;; Version: 1.2
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic does the job of converting source code into useful tag
-;; information. The set of `semantic-format-tag' functions has one
-;; function that will create a prototype of a tag, which has severe
-;; issues of complexity (in the format tag file itself) and inaccuracy
-;; (for the purpose of C++ code.)
-;;
-;; Contemplation of the simplistic problem within the scope of
-;; semantic showed that the solution was more complex than could
-;; possibly be handled in semantic/format.el. Semantic Recode, or
-;; srecode is a rich API for generating code out of semantic tags, or
-;; recoding the tags.
-;;
-;; See the srecode manual for specific details.
-
-;;; Code:
-
-(require 'eieio)
-(require 'mode-local)
-(load "srecode/loaddefs" nil 'nomessage)
-
-(defvar srecode-version "1.2"
- "Current version of the Semantic Recoder.")
-(make-obsolete-variable 'srecode-version 'emacs-version "29.1")
-
-(defgroup srecode nil
- "Semantic Recoder."
- :group 'extensions
- :group 'tools)
-
-(provide 'srecode)
-
-;;; srecode.el ends here
+++ /dev/null
-;;; srecode/args.el --- Provide some simple template arguments -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Srecode templates can accept arguments. These arguments represent
-;; sets of dictionary words that need to be derived. This file contains
-;; a set of simple arguments for srecode templates.
-
-(require 'srecode/dictionary)
-(require 'ede)
-
-;;; Code:
-
-;;; :blank
-;;
-;; Using :blank means that the template should force blank lines
-;; before and after the template, regardless of where the insertion
-;; is occurring.
-(defun srecode-semantic-handle-:blank (dict)
- "Add macros into the dictionary DICT specifying blank line spacing.
-The wrapgap means make sure the first and last lines of the macro
-do not contain any text from preceding or following text."
- ;; This won't actually get used, but it might be nice
- ;; to know about it.
- (srecode-dictionary-set-value dict "BLANK" t)
- )
-
-;;; :indent ARGUMENT HANDLING
-;;
-;; When a :indent argument is required, the default is to indent
-;; for the current major mode.
-(defun srecode-semantic-handle-:indent (dict)
- "Add macros into the dictionary DICT for indentation."
- (srecode-dictionary-set-value dict "INDENT" t)
- )
-
-;;; :region ARGUMENT HANDLING
-;;
-;; When a :region argument is required, provide macros that
-;; deal with that active region.
-;;
-;; Regions allow a macro to wrap the region text within the
-;; template bounds.
-;;
-(defvar srecode-handle-region-when-non-active-flag nil
- "Non-nil means do region handling w/out the region being active.")
-
-(defun srecode-semantic-handle-:region (dict)
- "Add macros into the dictionary DICT based on the current :region."
- ;; Only enable the region section if we can clearly show that
- ;; the user is intending to do something with the region.
- (when (or srecode-handle-region-when-non-active-flag
- (eq last-command 'mouse-drag-region)
- (and transient-mark-mode mark-active))
- ;; Show the region section
- (srecode-dictionary-show-section dict "REGION")
- (srecode-dictionary-set-value
- dict "REGIONTEXT" (buffer-substring-no-properties (point) (mark)))
- ;; Only whack the region if our template output
- ;; is also destined for the current buffer.
- (when (eq standard-output (current-buffer))
- (kill-region (point) (mark))))
- )
-
-;;; :user ARGUMENT HANDLING
-;;
-;; When a :user argument is required, fill the dictionary with
-;; information about the current Emacs user.
-(defun srecode-semantic-handle-:user (dict)
- "Add macros into the dictionary DICT based on the current :user."
- (srecode-dictionary-set-value dict "AUTHOR" (user-full-name))
- (srecode-dictionary-set-value dict "LOGIN" (user-login-name))
- (srecode-dictionary-set-value dict "EMAIL" user-mail-address)
- (srecode-dictionary-set-value dict "EMACSINITFILE" user-init-file)
- (srecode-dictionary-set-value dict "UID" (user-uid))
- )
-
-;;; :time ARGUMENT HANDLING
-;;
-;; When a :time argument is required, fill the dictionary with
-;; information about the current Emacs time.
-(defun srecode-semantic-handle-:time (dict)
- "Add macros into the dictionary DICT based on the current :time."
- ;; DATE Values
- (let ((now (current-time)))
- (srecode-dictionary-set-value
- dict "YEAR" (format-time-string "%Y" now))
- (srecode-dictionary-set-value
- dict "MONTHNAME" (format-time-string "%B" now))
- (srecode-dictionary-set-value
- dict "MONTH" (format-time-string "%m" now))
- (srecode-dictionary-set-value
- dict "DAY" (format-time-string "%d" now))
- (srecode-dictionary-set-value
- dict "WEEKDAY" (format-time-string "%a" now))
- ;; Time Values
- (srecode-dictionary-set-value
- dict "HOUR" (format-time-string "%H" now))
- (srecode-dictionary-set-value
- dict "HOUR12" (format-time-string "%l" now))
- (srecode-dictionary-set-value
- dict "AMPM" (format-time-string "%p" now))
- (srecode-dictionary-set-value
- dict "MINUTE" (format-time-string "%M" now))
- (srecode-dictionary-set-value
- dict "SECOND" (format-time-string "%S" now))
- (srecode-dictionary-set-value
- dict "TIMEZONE" (format-time-string "%Z" now))
- ;; Convenience pre-packed date/time
- (srecode-dictionary-set-value
- dict "DATE" (format-time-string "%D" now))
- (srecode-dictionary-set-value
- dict "TIME" (format-time-string "%X" now))))
-
-;;; :file ARGUMENT HANDLING
-;;
-;; When a :file argument is required, fill the dictionary with
-;; information about the file Emacs is editing at the time of
-;; insertion.
-(defun srecode-semantic-handle-:file (dict)
- "Add macros into the dictionary DICT based on the current :file."
- (let* ((bfn (buffer-file-name))
- (file (file-name-nondirectory bfn))
- (dir (file-name-directory bfn)))
- (srecode-dictionary-set-value dict "FILENAME" file)
- (srecode-dictionary-set-value dict "FILE" (file-name-sans-extension file))
- (srecode-dictionary-set-value dict "EXTENSION" (file-name-extension file))
- (srecode-dictionary-set-value dict "DIRECTORY" dir)
- (srecode-dictionary-set-value dict "MODE" (symbol-name major-mode))
- (srecode-dictionary-set-value
- dict "SHORTMODE"
- (let* ((mode-name (symbol-name major-mode))
- (match (string-match "-mode" mode-name)))
- (if match
- (substring mode-name 0 match)
- mode-name)))
- (if (or (file-exists-p "CVS")
- (file-exists-p "RCS"))
- (srecode-dictionary-show-section dict "RCS")
- )))
-
-;;; :project ARGUMENT HANDLING
-;;
-;; When the :project argument is required, fill the dictionary with
-;; information that the current project (from EDE) might know
-(defun srecode-semantic-handle-:project (dict)
- "Add macros into the dictionary DICT based on the current ede project."
- (let* ((bfn (buffer-file-name))
- (dir (file-name-directory bfn)))
- (if (ede-toplevel)
- (let* ((projecttop (ede-toplevel-project default-directory))
- (relfname (file-relative-name bfn projecttop))
- (reldir (file-relative-name dir projecttop))
- )
- (srecode-dictionary-set-value dict "PROJECT_FILENAME" relfname)
- (srecode-dictionary-set-value dict "PROJECT_DIRECTORY" reldir)
- (srecode-dictionary-set-value dict "PROJECT_NAME" (ede-name (ede-toplevel)))
- (srecode-dictionary-set-value dict "PROJECT_VERSION"
- (oref (ede-toplevel) version)))
- ;; If there is no EDE project, then put in some base values.
- (srecode-dictionary-set-value dict "PROJECT_FILENAME" bfn)
- (srecode-dictionary-set-value dict "PROJECT_DIRECTORY" dir)
- (srecode-dictionary-set-value dict "PROJECT_NAME" "N/A")
- (srecode-dictionary-set-value dict "PROJECT_VERSION" "1.0"))))
-
-;;; :system ARGUMENT HANDLING
-;;
-;; When a :system argument is required, fill the dictionary with
-;; information about the computer Emacs is running on.
-(defun srecode-semantic-handle-:system (dict)
- "Add macros into the dictionary DICT based on the current :system."
- (srecode-dictionary-set-value dict "SYSTEMCONF" system-configuration)
- (srecode-dictionary-set-value dict "SYSTEMTYPE" system-type)
- (srecode-dictionary-set-value dict "SYSTEMNAME" (system-name))
- (srecode-dictionary-set-value dict "MAILHOST" (or mail-host-address
- (system-name)))
- )
-
-;;; :kill ARGUMENT HANDLING
-;;
-;; When a :kill argument is required, fill the dictionary with
-;; information about the current kill ring.
-(defun srecode-semantic-handle-:kill (dict)
- "Add macros into the dictionary DICT based on the kill ring."
- (srecode-dictionary-set-value dict "KILL" (car kill-ring))
- (srecode-dictionary-set-value dict "KILL2" (nth 1 kill-ring))
- (srecode-dictionary-set-value dict "KILL3" (nth 2 kill-ring))
- (srecode-dictionary-set-value dict "KILL4" (nth 3 kill-ring))
- )
-
-(provide 'srecode/args)
-
-;;; srecode/args.el ends here
+++ /dev/null
-;;; srecode/compile --- Compilation of srecode template files. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2005, 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: codegeneration
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Compile a Semantic Recoder template file.
-;;
-;; Template files are parsed using a Semantic/Wisent parser into
-;; a tag table. The code therein is then further parsed down using
-;; a regular expression parser.
-;;
-;; The output are a series of EIEIO objects which represent the
-;; templates in a way that could be inserted later.
-
-(require 'semantic)
-(require 'eieio)
-(require 'cl-generic)
-(require 'eieio-base)
-(require 'srecode/table)
-(require 'srecode/dictionary)
-
-;;; Code:
-
-;;; Template Class
-;;
-;; Templates describe a pattern of text that can be inserted into a
-;; buffer.
-;;
-(defclass srecode-template (eieio-named)
- ((context :initarg :context
- :initform nil
- :documentation
- "Context this template belongs to.")
- (args :initarg :args
- :documentation
- "List of arguments that this template requires.")
- (code :initarg :code
- :documentation
- "Compiled text from the template.")
- (dictionary :initarg :dictionary
- :type (or null srecode-dictionary)
- :documentation
- "List of section dictionaries.
-The compiled template can contain lists of section dictionaries,
-or values that are expected to be passed down into different
-section macros. The template section dictionaries are merged in with
-any incoming dictionaries values.")
- (binding :initarg :binding
- :documentation
- "Preferred keybinding for this template in `srecode-minor-mode-map'.")
- (active :allocation :class
- :initform nil
- :documentation
- "During template insertion, this is the stack of active templates.
-The top-most template is the `active' template. Use the accessor methods
-for push, pop, and peek for the active template.")
- (table :initarg :table
- :documentation
- "The table this template lives in.")
- )
- "Class defines storage for semantic recoder templates.")
-
-(defun srecode-flush-active-templates ()
- "Flush the active template storage.
-Useful if something goes wrong in SRecode, and the active template
-stack is broken."
- (interactive)
- (if (oref-default 'srecode-template active)
- (when (y-or-n-p (format "%d active templates. Flush? "
- (length (oref-default 'srecode-template active))))
- (oset-default 'srecode-template active nil))
- (message "No active templates to flush."))
- )
-
-;;; Inserters
-;;
-;; Each inserter object manages a different thing that
-;; might be inserted into a template output stream.
-;;
-;; The 'srecode-insert-method' on each inserter does the actual
-;; work, and the smaller, simple inserter object is saved in
-;; the compiled templates.
-;;
-;; See srecode/insert.el for the specialized classes.
-;;
-(defclass srecode-template-inserter (eieio-named)
- ((secondname :initarg :secondname
- :type (or null string)
- :documentation
- "If there is a colon in the inserter's name, it represents
-additional static argument data.")
- (key :initform nil :allocation :class
- :documentation
- "The character code used to identify inserters of this style.
-All children of this class should specify `key' slot with appropriate
-:initform value."))
- "This represents an item to be inserted via a template macro.
-Plain text strings are not handled via this baseclass."
- :abstract t)
-
-(cl-defmethod srecode-parse-input ((_ins srecode-template-inserter)
- _tag input _STATE)
- "For the template inserter INS, parse INPUT.
-Shorten input only by the amount needed.
-Return the remains of INPUT.
-STATE is the current compilation state."
- input)
-
-(cl-defmethod srecode-match-end ((_ins srecode-template-inserter) _name)
- "For the template inserter INS, do I end a section called NAME?"
- nil)
-
-(cl-defmethod srecode-inserter-apply-state ((_ins srecode-template-inserter) _STATE)
- "For the template inserter INS, apply information from STATE."
- nil)
-
-
-
-;;; Compile State
-(defclass srecode-compile-state ()
- ((context :initform "declaration"
- :documentation "The active context.")
- (prompts :initform nil
- :documentation "The active prompts.")
- (escape_start :initform "{{"
- :documentation "The starting escape sequence.")
- (escape_end :initform "}}"
- :documentation "The ending escape sequence.")
- )
- "Current state of the compile.")
-
-(cl-defmethod srecode-compile-add-prompt ((state srecode-compile-state)
- prompttag)
- "Add PROMPTTAG to the current list of prompts."
- (with-slots (prompts) state
- (let ((match (assoc (semantic-tag-name prompttag) prompts))
- (newprompts prompts))
- (when match
- (let ((tmp prompts))
- (setq newprompts nil)
- (while tmp
- (when (not (string= (car (car tmp))
- (car prompttag)))
- (setq newprompts (cons (car tmp)
- newprompts)))
- (setq tmp (cdr tmp)))))
- (setq prompts (cons prompttag newprompts)))
- ))
-
-;;; TEMPLATE COMPILER
-;;
-(defun srecode-compile-file (fname)
- "Compile the templates from the file FNAME."
- (let ((peb (get-file-buffer fname)))
- (save-excursion
- ;; Make whatever it is local.
- (if (not peb)
- (set-buffer (semantic-find-file-noselect fname))
- (set-buffer peb))
- ;; Do the compile.
- (unless (semantic-active-p)
- (semantic-new-buffer-fcn))
- (srecode-compile-templates)
- ;; Trash the buffer if we had to read it in.
- (if (not peb)
- (kill-buffer (current-buffer)))
- )))
-
-;;;###autoload
-(defun srecode-compile-templates ()
- "Compile a semantic recode template file into a mode-local variable."
- (interactive)
- (unless (semantic-active-p)
- (error "You have to activate semantic-mode to compile SRecode templates"))
- (require 'srecode/insert)
- (when (called-interactively-p 'interactive)
- (message "Compiling template %s..."
- (file-name-nondirectory (buffer-file-name))))
- (let ((tags (semantic-fetch-tags))
- (tag nil)
- (class nil)
- (table nil)
- (STATE (srecode-compile-state (file-name-nondirectory
- (buffer-file-name))))
- (mode nil)
- (application nil)
- (framework nil)
- (priority nil)
- (project nil)
- (vars nil)
- )
-
- ;;
- ;; COMPILE
- ;;
- (while tags
- (setq tag (car tags)
- class (semantic-tag-class tag))
- ;; What type of item is it?
- (cond
- ;; CONTEXT tags specify the context all future tags
- ;; belong to.
- ((eq class 'context)
- (oset STATE context (semantic-tag-name tag))
- )
-
- ;; PROMPT tags specify prompts for dictionary ? inserters
- ;; which appear in the following templates
- ((eq class 'prompt)
- (srecode-compile-add-prompt STATE tag)
- )
-
- ;; VARIABLE tags can specify operational control
- ((eq class 'variable)
- (let* ((name (semantic-tag-name tag))
- (value (semantic-tag-variable-default tag))
- (firstvalue (car value)))
- ;; If it is a single string, and one value, then
- ;; look to see if it is one of our special variables.
- (if (and (= (length value) 1) (stringp firstvalue))
- (cond ((string= name "mode")
- (setq mode (intern firstvalue)))
- ((string= name "escape_start")
- (oset STATE escape_start firstvalue)
- )
- ((string= name "escape_end")
- (oset STATE escape_end firstvalue)
- )
- ((string= name "application")
- (setq application (read firstvalue)))
- ((string= name "framework")
- (setq framework (read firstvalue)))
- ((string= name "priority")
- (setq priority (read firstvalue)))
- ((string= name "project")
- (setq project firstvalue))
- (t
- ;; Assign this into some table of variables.
- (setq vars (cons (cons name firstvalue) vars))
- ))
- ;; If it isn't a single string, then the value of the
- ;; variable belongs to a compound dictionary value.
- ;;
- ;; Create a compound dictionary value from "value".
- (require 'srecode/dictionary)
- (let ((cv (srecode-dictionary-compound-variable
- name :value value)))
- (setq vars (cons (cons name cv) vars)))
- ))
- )
-
- ;; FUNCTION tags are really templates.
- ((eq class 'function)
- (setq table (cons (srecode-compile-one-template-tag tag STATE)
- table))
- )
-
- ;; Ooops
- (t (error "Unknown TAG class %s" class))
- )
- ;; Continue
- (setq tags (cdr tags)))
-
- ;; MSG - Before install since nreverse whacks our list.
- (when (called-interactively-p 'interactive)
- (message "%d templates compiled for %s"
- (length table) mode))
-
- ;;
- ;; APPLY TO MODE
- ;;
- (if (not mode)
- (error "You must specify a MODE for your templates"))
-
- ;;
- ;; Calculate priority
- ;;
- (if (not priority)
- (let ((d (expand-file-name (file-name-directory (buffer-file-name))))
- (sd (expand-file-name (file-name-directory (locate-library "srecode"))))
- (defaultdelta (if (eq mode 'default) 0 10)))
- ;; @TODO : WHEN INTEGRATING INTO EMACS
- ;; The location of Emacs default templates needs to be specified
- ;; here to also have a lower priority.
- (if (string-match (concat "^" sd) d)
- (setq priority (+ 30 defaultdelta))
- ;; If the user created template is for a project, then
- ;; don't add as much as if it is unique to just some user.
- (if (stringp project)
- (setq priority (+ 50 defaultdelta))
- (setq priority (+ 80 defaultdelta))))
- (when (called-interactively-p 'interactive)
- (message "Templates %s has estimated priority of %d"
- (file-name-nondirectory (buffer-file-name))
- priority)))
- (when (called-interactively-p 'interactive)
- (message "Compiling templates %s priority %d... done!"
- (file-name-nondirectory (buffer-file-name))
- priority)))
-
- ;; Save it up!
- (srecode-compile-template-table table mode priority application framework project vars)
- )
-)
-
-(defun srecode-compile-one-template-tag (tag state)
- "Compile a template tag TAG into a srecode template object.
-STATE is the current compile state as an object of class
-`srecode-compile-state'."
- (let* ((context (oref state context))
- (code (cdr (srecode-compile-split-code
- tag (semantic-tag-get-attribute tag :code)
- state)))
- (args (semantic-tag-function-arguments tag))
- (binding (semantic-tag-get-attribute tag :binding))
- (dict-tags (semantic-tag-get-attribute tag :dictionaries))
- (root-dict (when dict-tags
- (srecode-create-dictionaries-from-tags
- dict-tags state)))
- (addargs))
- ;; Examine arguments.
- (dolist (arg args)
- (let ((symbol (intern arg)))
- (push symbol addargs)
-
- ;; If we have a wrap, then put wrap inserters on both ends of
- ;; the code.
- (when (eq symbol :blank)
- (setq code (append
- (list (srecode-compile-inserter
- "BLANK"
- "\r"
- state
- :secondname nil
- :where 'begin))
- code
- (list (srecode-compile-inserter
- "BLANK"
- "\r"
- state
- :secondname nil
- :where 'end)))))))
-
- ;; Construct and return the template object.
- (srecode-template (semantic-tag-name tag)
- :context context
- :args (nreverse addargs)
- :dictionary root-dict
- :binding binding
- :code code))
- )
-
-(defun srecode-compile-do-hard-newline-p (comp)
- "Examine COMP to decide if the upcoming newline should be hard.
-It is hard if the previous inserter is a newline object."
- (while (and comp (stringp (car comp)))
- (setq comp (cdr comp)))
- (or (not comp)
- (srecord-compile-inserter-newline-p (car comp))))
-
-(cl-defgeneric srecord-compile-inserter-newline-p (_obj)
- "Non-nil if OBJ is a newline inserter object."
- nil)
-
-(defun srecode-compile-split-code (tag str STATE
- &optional end-name)
- "Split the code for TAG into something templatable.
-STR is the string of code from TAG to split.
-STATE is the current compile state.
-ESCAPE_START and ESCAPE_END are regexps that indicate the beginning
-escape character, and end escape character pattern for expandable
-macro names.
-Optional argument END-NAME specifies the name of a token upon which
-parsing should stop."
- (let* ((what str)
- (end-token nil)
- (comp nil)
- (regex (concat "\n\\|" (regexp-quote (oref STATE escape_start))))
- (regexend (regexp-quote (oref STATE escape_end)))
- )
- (while (and what (not end-token))
- (cond
- ((string-match regex what)
- (let* ((prefix (substring what 0 (match-beginning 0)))
- (match (substring what
- (match-beginning 0)
- (match-end 0)))
- (namestart (match-end 0))
- (junk (string-match regexend what namestart))
- end tail name)
- ;; Add string to compiled output
- (when (> (length prefix) 0)
- (setq comp (cons prefix comp)))
- (if (string= match "\n")
- ;; Do newline thingy.
- (let ((new-inserter
- (srecode-compile-inserter
- "INDENT"
- "\n"
- STATE
- :secondname nil
- ;; This newline is "hard" meaning ALWAYS do it
- ;; if the previous entry is also a newline.
- ;; Without it, user entered blank lines will be
- ;; ignored.
- :hard (srecode-compile-do-hard-newline-p comp)
- )))
- ;; Trim WHAT back.
- (setq what (substring what namestart))
- (when (> (length what) 0)
- ;; make the new inserter, but only if we aren't last.
- (setq comp (cons new-inserter comp))
- ))
- ;; Regular inserter thingy.
- (setq end (if junk
- (match-beginning 0)
- (error "Could not find end escape for %s"
- (semantic-tag-name tag)))
- tail (match-end 0))
- (cond ((not end)
- (error "No matching escape end for %s"
- (semantic-tag-name tag)))
- ((<= end namestart)
- (error "Stray end escape for %s"
- (semantic-tag-name tag)))
- )
- ;; Add string to compiled output
- (setq name (substring what namestart end))
- ;; Trim WHAT back.
- (setq what (substring what tail))
- ;; Get the inserter
- (let ((new-inserter
- (srecode-compile-parse-inserter name STATE))
- )
- ;; If this is an end inserter, then assign into
- ;; the end-token.
- (if (srecode-match-end new-inserter end-name)
- (setq end-token new-inserter))
- ;; Add the inserter to our compilation stream.
- (setq comp (cons new-inserter comp))
- ;; Allow the inserter an opportunity to modify
- ;; the input stream.
- (setq what (srecode-parse-input new-inserter tag what
- STATE))
- )
- )))
- (t
- (if end-name
- (error "Unmatched section end %s" end-name))
- (setq comp (cons what comp)
- what nil))))
- (cons what (nreverse comp))))
-
-(defun srecode-compile-parse-inserter (txt STATE)
- "Parse the inserter TXT with the current STATE.
-Return an inserter object."
- (let ((key (aref txt 0))
- name
- )
- (if (and (or (< key ?A) (> key ?Z))
- (or (< key ?a) (> key ?z)) )
- (setq name (substring txt 1))
- (setq name txt
- key nil))
- (let* ((junk (string-match ":" name))
- (namepart (if junk
- (substring name 0 (match-beginning 0))
- name))
- (secondname (if junk
- (substring name (match-end 0))
- nil))
- (new-inserter (srecode-compile-inserter
- namepart key STATE
- :secondname secondname
- )))
- ;; Return the new inserter
- new-inserter)))
-
-(defun srecode-compile-inserter (name key STATE &rest props)
- "Create an srecode inserter object for some macro NAME.
-KEY indicates a single character key representing a type
-of inserter to create.
-STATE is the current compile state.
-PROPS are additional properties that might need to be passed
-to the inserter constructor."
- ;;(message "Compile: %s %S" name props)
- (if (not key)
- (apply #'make-instance 'srecode-template-inserter-variable name props)
- (let ((classes (eieio-class-children 'srecode-template-inserter))
- (new nil))
- ;; Loop over the various subclasses and
- ;; create the correct inserter.
- (while (and (not new) classes)
- (setq classes (append classes (eieio-class-children (car classes))))
- ;; Do we have a match?
- (when (and (not (class-abstract-p (car classes)))
- (equal (oref-default (car classes) key) key))
- ;; Create the new class, and apply state.
- (setq new (apply #'make-instance (car classes) name props))
- (srecode-inserter-apply-state new STATE)
- )
- (setq classes (cdr classes)))
- (if (not new) (error "SRECODE: Unknown macro code %S" key))
- new)))
-
-(defun srecode-compile-template-table (templates mode priority application framework project vars)
- "Compile a list of TEMPLATES into an semantic recode table.
-The table being compiled is for MODE, or the string \"default\".
-PRIORITY is a numerical value that indicates this tables location
-in an ordered search.
-APPLICATION is the name of the application these templates belong to.
-FRAMEWORK is the name of the framework these templates belong to.
-PROJECT is a directory name which these templates scope to.
-A list of defined variables VARS provides a variable table."
- (let ((namehash (make-hash-table :test 'equal
- :size (length templates)))
- (contexthash (make-hash-table :test 'equal :size 10))
- (lp templates)
- )
-
- (while lp
-
- (let* ((objname (oref (car lp) object-name))
- (context (oref (car lp) context))
- (globalname (concat context ":" objname))
- )
-
- ;; Place this template object into the global name hash.
- (puthash globalname (car lp) namehash)
-
- ;; Place this template into the specific context name hash.
- (let ((hs (gethash context contexthash)))
- ;; Make a new context if none was available.
- (when (not hs)
- (setq hs (make-hash-table :test 'equal :size 20))
- (puthash context hs contexthash))
- ;; Put into that context's hash.
- (puthash objname (car lp) hs)
- )
-
- (setq lp (cdr lp))))
-
- (when (stringp project)
- (setq project (expand-file-name project)))
-
- (let* ((table (srecode-mode-table-new mode (buffer-file-name)
- :templates (nreverse templates)
- :namehash namehash
- :contexthash contexthash
- :variables vars
- :major-mode mode
- :priority priority
- :application application
- :framework framework
- :project project))
- (tmpl (oref table templates)))
- ;; Loop over all the templates, and xref.
- (while tmpl
- (oset (car tmpl) table table)
- (setq tmpl (cdr tmpl))))
- ))
-
-
-
-;;; DEBUG
-;;
-;; Dump out information about the current srecoder compiled templates.
-;;
-
-(cl-defmethod srecode-dump ((tmp srecode-template))
- "Dump the contents of the SRecode template tmp."
- (princ "== Template \"")
- (princ (eieio-object-name-string tmp))
- (princ "\" in context ")
- (princ (oref tmp context))
- (princ "\n")
- (when (oref tmp args)
- (princ " Arguments: ")
- (prin1 (oref tmp args))
- (princ "\n"))
- (when (oref tmp dictionary)
- (princ " Section Dictionaries:\n")
- (srecode-dump (oref tmp dictionary) 4)
- ;(princ "\n")
- )
- (when (and (slot-boundp tmp 'binding) (oref tmp binding))
- (princ " Binding: ")
- (prin1 (oref tmp binding))
- (princ "\n"))
- (princ " Compiled Codes:\n")
- (srecode-dump-code-list (oref tmp code) " ")
- (princ "\n\n")
- )
-
-(defun srecode-dump-code-list (code indent)
- "Dump the CODE from a template code list to standard output.
-Argument INDENT specifies the indentation level for the list."
- (let ((i 1))
- (while code
- (princ indent)
- (prin1 i)
- (princ ") ")
- (cond ((stringp (car code))
- (prin1 (car code)))
- ((cl-typep (car code) 'srecode-template-inserter)
- (srecode-dump (car code) indent))
- (t
- (princ "Unknown Code: ")
- (prin1 (car code))))
- (setq code (cdr code)
- i (1+ i))
- (when code
- (princ "\n"))))
- )
-
-(cl-defmethod srecode-dump ((ins srecode-template-inserter) _indent)
- "Dump the state of the SRecode template inserter INS."
- (princ "INS: \"")
- (princ (eieio-object-name-string ins))
- (when (oref ins secondname)
- (princ "\" : \"")
- (princ (oref ins secondname)))
- (princ "\" type \"")
- (let* ((oc (symbol-name (eieio-object-class ins)))
- (junk (string-match "srecode-template-inserter-" oc))
- (on (if junk
- (substring oc (match-end 0))
- oc)))
- (princ on))
- (princ "\"")
- )
-
-(provide 'srecode/compile)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/compile"
-;; End:
-
-;;; srecode/compile.el ends here
+++ /dev/null
-;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007, 2009-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Jan Moringen <scymtym@users.sourceforge.net>
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Supply some C++ specific dictionary fillers and helpers
-
-;;; Code:
-
-(require 'srecode)
-(require 'srecode/dictionary)
-(require 'srecode/semantic)
-(require 'semantic/tag)
-
-;;; Customization
-;;
-
-(defgroup srecode-cpp nil
- "C++-specific Semantic Recoder settings."
- :group 'srecode)
-
-(defcustom srecode-cpp-namespaces
- '("std" "boost")
- "List expansion candidates for the :using-namespaces argument.
-A dictionary entry of the named PREFIX_NAMESPACE with the value
-NAMESPACE:: is created for each namespace unless the current
-buffer contains a using NAMESPACE; statement."
- :type '(repeat string))
-
-;;; :c ARGUMENT HANDLING
-;;
-;; When a :c argument is required, fill the dictionary with
-;; information about the current C file.
-;;
-;; Error if not in a C mode.
-
-;;;###autoload
-(defun srecode-semantic-handle-:c (dict)
- "Add macros into the dictionary DICT based on the current C file.
-Adds the following:
-FILENAME_SYMBOL - filename converted into a C compat symbol.
-HEADER - Shown section if in a header file."
- ;; A symbol representing
- (let ((fsym (file-name-nondirectory (buffer-file-name)))
- (case-fold-search t))
-
- ;; Are we in a header file?
- (if (string-match "\\.\\(h\\|hh\\|hpp\\|h\\+\\+\\)$" fsym)
- (srecode-dictionary-show-section dict "HEADER")
- (srecode-dictionary-show-section dict "NOTHEADER"))
-
- ;; Strip out bad characters
- (setq fsym (replace-regexp-in-string "[^a-zA-Z0-9_]" "_" fsym))
- (srecode-dictionary-set-value dict "FILENAME_SYMBOL" fsym)
- )
- )
-
-;;; :cpp ARGUMENT HANDLING
-;;
-;; When a :cpp argument is required, fill the dictionary with
-;; information about the current C++ file.
-;;
-;; Error if not in a C++ mode.
-;;;###autoload
-(defun srecode-semantic-handle-:cpp (dict)
- "Add macros into the dictionary DICT based on the current c file.
-Calls `srecode-semantic-handle-:c'.
-Also adds the following:
- - nothing -"
- (srecode-semantic-handle-:c dict)
- )
-
-(defun srecode-semantic-handle-:using-namespaces (dict)
- "Add macros into the dictionary DICT based on used namespaces.
-Adds the following:
-PREFIX_NAMESPACE - for each NAMESPACE in `srecode-cpp-namespaces'."
- (let ((tags (semantic-find-tags-by-class
- 'using (semantic-fetch-tags))))
- (dolist (name srecode-cpp-namespaces)
- (let ((variable (format "PREFIX_%s" (upcase name)))
- (prefix (format "%s::" name)))
- (srecode-dictionary-set-value dict variable prefix)
- (dolist (tag tags)
- (when (and (eq (semantic-tag-get-attribute tag :kind)
- 'namespace)
- (string= (semantic-tag-name tag) name))
- (srecode-dictionary-set-value dict variable ""))))))
- )
-
-(define-mode-local-override srecode-semantic-apply-tag-to-dict
- c-mode (tag-wrapper dict)
- "Apply C and C++ specific features from TAG-WRAPPER into DICT.
-Calls `srecode-semantic-apply-tag-to-dict-default' first. Adds
-special behavior for tag of classes include, using and function.
-
-This function cannot be split into C and C++ specific variants, as
-the way the tags are created from the parser does not distinguish
-either. The side effect is that you could get some C++ tag properties
-specified in a C file."
-
- ;; Use default implementation to fill in the basic properties.
- (srecode-semantic-apply-tag-to-dict-default tag-wrapper dict)
-
- ;; Pull out the tag for the individual pieces.
- (let* ((tag (oref tag-wrapper prime))
- (class (semantic-tag-class tag)))
-
- ;; Add additional information based on the class of the tag.
- (cond
- ;;
- ;; INCLUDE
- ;;
- ((eq class 'include)
- ;; For include tags, we have to discriminate between system-wide
- ;; and local includes.
- (if (semantic-tag-include-system-p tag)
- (srecode-dictionary-show-section dict "SYSTEM")
- (srecode-dictionary-show-section dict "LOCAL")))
-
- ;;
- ;; USING
- ;;
- ((eq class 'using)
- ;; Insert the subject (a tag) of the include statement as VALUE
- ;; entry into the dictionary.
- (let ((value-tag (semantic-tag-get-attribute tag :value))
- (value-dict (srecode-dictionary-add-section-dictionary
- dict "VALUE")))
- (srecode-semantic-apply-tag-to-dict
- (srecode-semantic-tag (semantic-tag-name value-tag)
- :prime value-tag)
- value-dict))
-
- ;; Discriminate using statements referring to namespaces and
- ;; types.
- (when (eq (semantic-tag-get-attribute tag :kind) 'namespace)
- (srecode-dictionary-show-section dict "NAMESPACE")))
-
- ;;
- ;; FUNCTION
- ;;
- ((eq class 'function)
- ;; @todo It would be nice to distinguish member functions from
- ;; free functions and only apply the const and pure modifiers,
- ;; when they make sense. My best bet would be
- ;; (semantic-tag-function-parent tag), but it is not there, when
- ;; the function is defined in the scope of a class.
- (let (;; (member t)
- (templates (semantic-tag-get-attribute tag :template))
- (modifiers (semantic-tag-modifiers tag)))
-
- ;; Mark constructors and destructors as such.
- (when (semantic-tag-function-constructor-p tag)
- (srecode-dictionary-show-section dict "CONSTRUCTOR"))
- (when (semantic-tag-function-destructor-p tag)
- (srecode-dictionary-show-section dict "DESTRUCTOR"))
-
- ;; Add modifiers into the dictionary.
- (dolist (modifier modifiers)
- (let ((modifier-dict (srecode-dictionary-add-section-dictionary
- dict "MODIFIERS")))
- (srecode-dictionary-set-value modifier-dict "NAME" modifier)))
-
- ;; Add templates into child dictionaries.
- (srecode-c-apply-templates dict templates)
-
- ;; When the function is a member function, it can have
- ;; additional modifiers.
- (when t ;; member
-
- ;; For member functions, constness is called
- ;; 'methodconst-flag'.
- (when (semantic-tag-get-attribute tag :methodconst-flag)
- (srecode-dictionary-show-section dict "CONST"))
-
- ;; If the member function is pure virtual, add a dictionary
- ;; entry.
- (when (semantic-tag-get-attribute tag :pure-virtual-flag)
- (srecode-dictionary-show-section dict "PURE")))))
-
- ;;
- ;; CLASS
- ;;
- ((eq class 'type)
- ;; For classes, add template parameters.
- (when (or (semantic-tag-of-type-p tag "class")
- (semantic-tag-of-type-p tag "struct"))
-
- ;; Add templates into child dictionaries.
- (let ((templates (semantic-tag-get-attribute tag :template)))
- (srecode-c-apply-templates dict templates))))
- ))
- )
-
-\f
-;;; Helper functions
-;;
-
-(defun srecode-c-apply-templates (dict templates)
- "Add section dictionaries for TEMPLATES to DICT."
- (when templates
- (let ((templates-dict (srecode-dictionary-add-section-dictionary
- dict "TEMPLATES")))
- (dolist (template templates)
- (let ((template-dict (srecode-dictionary-add-section-dictionary
- templates-dict "ARGS")))
- (srecode-semantic-apply-tag-to-dict
- (srecode-semantic-tag (semantic-tag-name template)
- :prime template)
- template-dict)))))
- )
-
-(provide 'srecode/cpp)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/cpp"
-;; End:
-
-;;; srecode/cpp.el ends here
+++ /dev/null
-;;; srecode/ctxt.el --- Derive a context from the source buffer. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Manage context calculations for Semantic Recoder.
-;;
-;; SRecode templates are always bound to a context. By calculating
-;; the current context, we can narrow down the selection of possible
-;; templates to something reasonable.
-;;
-;; Alternately, code here will find a context for templates that
-;; require different pieces of code placed in multiple areas.
-
-(require 'semantic)
-(require 'semantic/tag-ls)
-(require 'srecode/dictionary)
-
-;;; Code:
-
-(define-overloadable-function srecode-calculate-context ()
- "Calculate the context at the current point.
-The returned context is a list, with the top-most context first.
-Each returned context is a string that would show up in a `context'
-statement in an `.srt' file.
-
-Some useful context values used by the provided srecode templates are:
- \"file\" - Templates that for a file (such as an empty file.)
- \"empty\" - The file is empty
- \"declaration\" - Top-level declarations in a file.
- \"include\" - In or near include statements
- \"package\" - In or near provide statements
- \"function\" - In or near function statements
- \"NAME\" - Near functions within NAME namespace or class
- \"variable\" - In or near variable statements.
- \"type\" - In or near type declarations.
- \"comment\" - In a comment
- \"classdecl\" - Declarations within a class/struct/etc.
- \"variable\" - In or near class fields
- \"function\" - In or near methods/functions
- \"virtual\" - Nearby items are virtual
- \"pure\" - and those virtual items are pure virtual
- \"type\" - In or near type declarations.
- \"comment\" - In a comment in a block of code
- -- these items show up at the end of the context list. --
- \"public\", \"protected\", \"private\" -
- In or near a section of public/protected/private entries.
- \"code\" - In a block of code.
- \"string\" - In a string in a block of code
- \"comment\" - In a comment in a block of code
-
- ... More later."
- )
-
-(defun srecode-calculate-nearby-things ()
- ;; NOTE: May need to add bounds to this FCN
- "Calculate the CONTEXT type items nearby the current point.
-Assume that what we want to insert next is based on what is just
-before point. If there is nothing, then assume it is whatever is
-after point."
- ;; @todo - ADD BOUNDS TO THE PREV/NEXT TAG SEARCH
- ;; thus classdecl "near" stuff cannot be
- ;; outside the bounds of the type in question.
- (let ((near (semantic-find-tag-by-overlay-prev))
- (prot nil)
- (ans nil))
- (if (not near)
- (setq near (semantic-find-tag-by-overlay-next)))
- (when near
- ;; Calculate the type of thing we are near.
- (if (not (semantic-tag-of-class-p near 'function))
- (setq ans (cons (symbol-name (semantic-tag-class near)) ans))
- ;; if the symbol NEAR has a parent,
- (let ((p (semantic-tag-function-parent near)))
- (setq ans (cons (symbol-name (semantic-tag-class near)) ans))
- (cond ((semantic-tag-p p)
- (setq ans (cons (semantic-tag-name p) ans)))
- ((stringp p)
- (setq ans (cons p ans)))
- (t nil)))
- ;; Was it virtual?
- (when (semantic-tag-get-attribute near :virtual)
- (setq ans (cons "virtual" ans)))
- ;; Was it pure?
- (when (semantic-tag-get-attribute near :pure-virtual-flag)
- (setq ans (cons "pure" ans)))
- )
- ;; Calculate the protection
- (setq prot (semantic-tag-protection near))
- (when (and prot (not (eq prot 'unknown)))
- (setq ans (cons (symbol-name prot) ans)))
- )
- (nreverse ans)))
-
-(defun srecode-calculate-context-font-lock ()
- "Calculate an srecode context by using font-lock."
- (let ((face (get-text-property (point) 'face))
- )
- (cond ((member face '(font-lock-string-face
- font-lock-doc-face))
- (list "string"))
- ((member face '(font-lock-comment-face
- font-lock-comment-delimiter-face))
- (list "comment"))
- )
- ))
-
-(defun srecode-calculate-context-default ()
- "Generic method for calculating a context for srecode."
- (if (= (point-min) (point-max))
- (list "file" "empty")
-
- (semantic-fetch-tags)
- (let ((ct (semantic-find-tag-by-overlay))
- )
- (cond ((or (not ct)
- ;; Ok, below is a bit C specific.
- (and (eq (semantic-tag-class (car ct)) 'type)
- (string= (semantic-tag-type (car ct)) "namespace")))
- (cons "declaration"
- (or (srecode-calculate-context-font-lock)
- (srecode-calculate-nearby-things)
- ))
- )
- ((eq (semantic-tag-class (car ct)) 'function)
- (cons "code" (srecode-calculate-context-font-lock))
- )
- ((eq (semantic-tag-class (car ct)) 'type) ; We know not namespace
- (cons "classdecl"
- (or (srecode-calculate-context-font-lock)
- (srecode-calculate-nearby-things)))
- )
- ((and (car (cdr ct))
- (eq (semantic-tag-class (car (cdr ct))) 'type))
- (list "classdecl"
- (symbol-name (semantic-tag-class (car ct))))
- )
- )
- )))
-
-\f
-;;; HANDLERS
-;;
-;; The calculated context is one thing, but more info is often available.
-;; The context handlers can add info into the active dictionary that is
-;; based on the context, such as a method parent name, protection scheme,
-;; or other feature.
-
-(defun srecode-semantic-handle-:ctxt (dict &optional template)
- "Add macros into the dictionary DICT based on the current Emacs Lisp file.
-Argument TEMPLATE is the template object adding context dictionary
-entries.
-This might add the following:
- VIRTUAL - show a section if a function is virtual
- PURE - show a section if a function is pure virtual.
- PARENT - The name of a parent type for functions.
- PROTECTION - Show a protection section, and what the protection is."
- (when template
-
- (let ((name (oref template object-name))
- (cc (if (boundp 'srecode-insertion-start-context)
- srecode-insertion-start-context))
- ;(context (oref template context))
- )
-
-; (when (and cc
-; (null (string= (car cc) context))
-; )
-; ;; No current context, or the base is different, then
-; ;; this is the section where we need to recalculate
-; ;; the context based on user choice, if possible.
-; ;;
-; ;; The recalculation is complex, as there are many possibilities
-; ;; that need to be divined. Set "cc" to the new context
-; ;; at the end.
-; ;;
-; ;; @todo -
-;
-; )
-
- ;; The various context all have different features.
- (let ((ct (nth 0 cc))
- (it (nth 1 cc))
- (last (last cc))
- (parent nil)
- )
- (cond ((string= it "function")
- (setq parent (nth 2 cc))
- (when parent
- (cond ((string= parent "virtual")
- (srecode-dictionary-show-section dict "VIRTUAL")
- (when (nth 3 cc)
- (srecode-dictionary-show-section dict "PURE"))
- )
- (t
- (srecode-dictionary-set-value dict "PARENT" parent))))
- )
- ((and (string= it "type")
- (or (string= name "function") (string= name "method")))
- ;; If we have a type, but we insert a fcn, then use that type
- ;; as the function parent.
- (let ((near (semantic-find-tag-by-overlay-prev)))
- (when (and near (semantic-tag-of-class-p near 'type))
- (srecode-dictionary-set-value
- dict "PARENT" (semantic-tag-name near))))
- )
- ((string= ct "code")
- ;;(let ((analyzer (semantic-analyze-current-context)))
- ;; @todo - Use the analyze to setup things like local
- ;; variables we might use or something.
- nil
- ;;)
- )
- (t
- nil))
- (when (member last '("public" "private" "protected"))
- ;; Hey, fancy that, we can do both.
- (srecode-dictionary-set-value dict "PROTECTION" parent)
- (srecode-dictionary-show-section dict "PROTECTION"))
- ))
- ))
-
-
-(provide 'srecode/ctxt)
-
-;;; srecode/ctxt.el ends here
+++ /dev/null
-;;; srecode/dictionary.el --- Dictionary code for the semantic recoder. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Dictionaries contain lists of names and their associated values.
-;; These dictionaries are used to fill in macros from recoder templates.
-
-;;; Code:
-
-;;; CLASSES
-
-(require 'eieio)
-(require 'cl-generic)
-(require 'srecode)
-(require 'srecode/table)
-(require 'srecode/fields)
-(eval-when-compile (require 'semantic))
-
-(declare-function srecode-compile-parse-inserter "srecode/compile")
-(declare-function srecode-dump-code-list "srecode/compile")
-(declare-function srecode-load-tables-for-mode "srecode/find")
-(declare-function srecode-template-table-in-project-p "srecode/find")
-(declare-function srecode-insert-code-stream "srecode/insert")
-(declare-function data-debug-new-buffer "data-debug")
-(declare-function data-debug-insert-object-slots "eieio-datadebug")
-
-(defclass srecode-dictionary ()
- ((namehash :initarg :namehash
- :documentation
- "Hash table containing the names of all the templates.")
- (buffer :initarg :buffer
- :documentation
- "The buffer this dictionary was initialized with.")
- (parent :initarg :parent
- :type (or null srecode-dictionary)
- :documentation
- "The parent dictionary.
-Symbols not appearing in this dictionary will be checked against the
-parent dictionary.")
- (origin :initarg :origin
- :type string
- :documentation
- "A string representing the origin of this dictionary.
-Useful only while debugging.")
- )
- "Dictionary of symbols and what they mean.
-Dictionaries are used to look up named symbols from
-templates to decide what to do with those symbols.")
-
-(defclass srecode-dictionary-compound-value ()
- ()
- "A compound dictionary value.
-Values stored in a dictionary must be a STRING,
-a dictionary for showing sections, or an instance of a subclass
-of this class.
-
-Compound dictionary values derive from this class, and must
-provide a sequence of method implementations to convert into
-a string."
- :abstract t)
-
-(defclass srecode-dictionary-compound-variable
- (srecode-dictionary-compound-value)
- ((value :initarg :value
- :documentation
- "The value of this template variable.
-Variables in template files are usually a single string
-which can be inserted into a dictionary directly.
-
-Some variables may be more complex and involve dictionary
-lookups, strings, concatenation, or the like.
-
-The format of VALUE is determined by current template
-formatting rules.")
- (compiled :initarg :compiled
- :type list
- :documentation
- "The compiled version of VALUE.")
- )
- "A compound dictionary value for template file variables.
-You can declare a variable in a template like this:
-
-set NAME \"str\" macro \"OTHERNAME\"
-
-with appending various parts together in a list.")
-
-(cl-defmethod initialize-instance ((this srecode-dictionary-compound-variable)
- &optional fields)
- "Initialize the compound variable THIS.
-Makes sure that :value is compiled."
- (let ((newfields nil)
- (state nil))
- (while fields
- ;; Strip out :state
- (if (eq (car fields) :state)
- (setq state (car (cdr fields)))
- (setq newfields (cons (car (cdr fields))
- (cons (car fields) newfields))))
- (setq fields (cdr (cdr fields))))
-
- ;;(when (not state)
- ;; (error "Cannot create compound variable outside of sectiondictionary"))
-
- (cl-call-next-method this (nreverse newfields))
- (when (not (slot-boundp this 'compiled))
- (let ((val (oref this value))
- (comp nil))
- (while val
- (let ((nval (car val))
- )
- (cond ((stringp nval)
- (setq comp (cons nval comp)))
- ((and (listp nval)
- (equal (car nval) 'macro))
- (require 'srecode/compile)
- (setq comp (cons
- (srecode-compile-parse-inserter
- (cdr nval)
- state)
- comp)))
- (t
- (error "Don't know how to handle variable value %S" nval)))
- )
- (setq val (cdr val)))
- (oset this compiled (nreverse comp))))))
-
-;;; DICTIONARY METHODS
-;;
-
-(defun srecode-create-dictionary (&optional buffer-or-parent)
- "Create a dictionary for BUFFER-OR-PARENT.
-If BUFFER-OR-PARENT is not specified, assume a buffer, and
-use the current buffer.
-If BUFFER-OR-PARENT is another dictionary, then remember the
-parent within the new dictionary, and assume that BUFFER
-is the same as belongs to the parent dictionary.
-The dictionary is initialized with variables setup for that
-buffer's table.
-If BUFFER-OR-PARENT is t, then this dictionary should not be
-associated with a buffer or parent."
- (save-excursion
- ;; Handle the parent
- (let ((parent nil)
- (buffer nil)
- (origin nil)
- (initfrombuff nil))
- (cond
- ;; Parent is a buffer
- ((bufferp buffer-or-parent)
- (set-buffer buffer-or-parent)
- (setq buffer buffer-or-parent
- origin (buffer-name buffer-or-parent)
- initfrombuff t))
-
- ;; Parent is another dictionary
- ((cl-typep buffer-or-parent 'srecode-dictionary)
- (setq parent buffer-or-parent
- buffer (oref buffer-or-parent buffer)
- origin (concat (eieio-object-name buffer-or-parent) " in "
- (if buffer (buffer-name buffer)
- "no buffer")))
- (when buffer
- (set-buffer buffer)))
-
- ;; No parent
- ((eq buffer-or-parent t)
- (setq buffer nil
- origin "Unspecified Origin"))
-
- ;; Default to unspecified parent
- (t
- (setq buffer (current-buffer)
- origin (concat "Unspecified. Assume "
- (buffer-name buffer))
- initfrombuff t)))
-
- ;; Create the new dictionary object.
- (let ((dict (make-instance
- 'srecode-dictionary
- :buffer buffer
- :parent parent
- :namehash (make-hash-table :test 'equal
- :size 20)
- :origin origin)))
- ;; Only set up the default variables if we are being built
- ;; directly for a particular buffer.
- (when initfrombuff
- ;; Variables from the table we are inserting from.
- ;; @todo - get a better tree of tables.
- (let ((mt (srecode-get-mode-table major-mode))
- (def (srecode-get-mode-table 'default)))
- ;; Each table has multiple template tables.
- ;; Do DEF first so that MT can override any values.
- (srecode-dictionary-add-template-table dict def)
- (srecode-dictionary-add-template-table dict mt)
- ))
- dict))))
-
-(cl-defmethod srecode-dictionary-add-template-table ((dict srecode-dictionary)
- tpl)
- "Insert into DICT the variables found in table TPL.
-TPL is an object representing a compiled template file."
- (when tpl
- ;; Tables are sorted with highest priority first, useful for looking
- ;; up templates, but this means we need to install the variables in
- ;; reverse order so higher priority variables override lower ones.
- (let ((tabs (reverse (oref tpl tables))))
- (require 'srecode/find) ; For srecode-template-table-in-project-p
- (while tabs
- (when (srecode-template-table-in-project-p (car tabs))
- (let ((vars (oref (car tabs) variables)))
- (while vars
- (srecode-dictionary-set-value
- dict (car (car vars)) (cdr (car vars)))
- (setq vars (cdr vars)))))
- (setq tabs (cdr tabs))))))
-
-
-(cl-defmethod srecode-dictionary-set-value ((dict srecode-dictionary)
- name value)
- "In dictionary DICT, set NAME to have VALUE."
- ;; Validate inputs
- (unless (stringp name)
- (signal 'wrong-type-argument (list name 'stringp)))
-
- ;; Add the value.
- (with-slots (namehash) dict
- (puthash name value namehash))
- )
-
-(cl-defmethod srecode-dictionary-add-section-dictionary ((dict srecode-dictionary)
- name &optional show-only force)
- "In dictionary DICT, add a section dictionary for section macro NAME.
-Return the new dictionary.
-
-You can add several dictionaries to the same section entry.
-For each dictionary added to a variable, the block of codes in
-the template will be repeated.
-
-If optional argument SHOW-ONLY is non-nil, then don't add a new dictionary
-if there is already one in place. Also, don't add FIRST/LAST entries.
-These entries are not needed when we are just showing a section.
-
-Each dictionary added will automatically get values for positional macros
-which will enable SECTIONS to be enabled.
-
- * FIRST - The first entry in the table.
- * NOTFIRST - Not the first entry in the table.
- * LAST - The last entry in the table
- * NOTLAST - Not the last entry in the table.
-
-Adding a new dictionary will alter these values in previously
-inserted dictionaries."
- ;; Validate inputs
- (unless (stringp name)
- (signal 'wrong-type-argument (list name 'stringp)))
-
- (let ((new (srecode-create-dictionary dict))
- (ov (srecode-dictionary-lookup-name dict name t)))
-
- (when (not show-only)
- ;; Setup the FIRST/NOTFIRST and LAST/NOTLAST entries.
- (if (null ov)
- (progn
- (srecode-dictionary-show-section new "FIRST")
- (srecode-dictionary-show-section new "LAST"))
- ;; Not the very first one. Let's clean up CAR.
- (let ((tail (car (last ov))))
- (srecode-dictionary-hide-section tail "LAST")
- (srecode-dictionary-show-section tail "NOTLAST")
- )
- (srecode-dictionary-show-section new "NOTFIRST")
- (srecode-dictionary-show-section new "LAST"))
- )
-
- (when (or force
- (not show-only)
- (null ov))
- (srecode-dictionary-set-value dict name (append ov (list new))))
- ;; Return the new sub-dictionary.
- new))
-
-(cl-defmethod srecode-dictionary-show-section ((dict srecode-dictionary) name)
- "In dictionary DICT, indicate that the section NAME should be exposed."
- ;; Validate inputs
- (unless (stringp name)
- (signal 'wrong-type-argument (list name 'stringp)))
-
- ;; Showing a section is just like making a section dictionary, but
- ;; with no dictionary values to add.
- (srecode-dictionary-add-section-dictionary dict name t)
- nil)
-
-(cl-defmethod srecode-dictionary-hide-section ((dict srecode-dictionary) name)
- "In dictionary DICT, indicate that the section NAME should be hidden."
- ;; We need to find the has value, and then delete it.
- ;; Validate inputs
- (unless (stringp name)
- (signal 'wrong-type-argument (list name 'stringp)))
-
- ;; Add the value.
- (with-slots (namehash) dict
- (remhash name namehash))
- nil)
-
-(cl-defmethod srecode-dictionary-add-entries ((dict srecode-dictionary)
- entries &optional state)
- "Add ENTRIES to DICT.
-
-ENTRIES is a list of even length of dictionary entries to add.
-ENTRIES looks like this:
-
- (NAME_1 VALUE_1 NAME_2 VALUE_2 ...)
-
-The following rules apply:
- * NAME_N is a string
-and for values
- * If VALUE_N is t, the section NAME_N is shown.
- * If VALUE_N is a string, an ordinary value is inserted.
- * If VALUE_N is a dictionary, it is inserted as entry NAME_N.
- * Otherwise, a compound variable is created for VALUE_N.
-
-The optional argument STATE has to non-nil when compound values
-are inserted. An error is signaled if ENTRIES contains compound
-values but STATE is nil."
- (while entries
- (let ((name (nth 0 entries))
- (value (nth 1 entries)))
- (cond
- ;; Value is t; show a section.
- ((eq value t)
- (srecode-dictionary-show-section dict name))
-
- ;; Value is a simple string; create an ordinary dictionary
- ;; entry
- ((stringp value)
- (srecode-dictionary-set-value dict name value))
-
- ;; Value is a dictionary; insert as child dictionary.
- ((cl-typep value 'srecode-dictionary)
- (srecode-dictionary-merge
- (srecode-dictionary-add-section-dictionary dict name)
- value t))
-
- ;; Value is some other object; create a compound value.
- (t
- (unless state
- (error "Cannot insert compound values without state"))
-
- (srecode-dictionary-set-value
- dict name
- (srecode-dictionary-compound-variable
- name :value value :state state)))))
- (setq entries (nthcdr 2 entries)))
- dict)
-
-(cl-defmethod srecode-dictionary-merge ((dict srecode-dictionary) otherdict
- &optional force)
- "Merge into DICT the dictionary entries from OTHERDICT.
-Unless the optional argument FORCE is non-nil, values in DICT are
-not modified, even if there are values of the same names in
-OTHERDICT."
- (when otherdict
- (maphash
- (lambda (key entry)
- ;; The new values is only merged in if there was no old value
- ;; or FORCE is non-nil.
- ;;
- ;; This protects applications from being whacked, and basically
- ;; makes these new section dictionary entries act like
- ;; "defaults" instead of overrides.
- (when (or force
- (not (srecode-dictionary-lookup-name dict key t)))
- (cond
- ;; A list of section dictionaries. We need to merge them in.
- ((and (listp entry)
- (srecode-dictionary-p (car entry)))
- (dolist (sub-dict entry)
- (srecode-dictionary-merge
- (srecode-dictionary-add-section-dictionary
- dict key t t)
- sub-dict force)))
-
- ;; Other values can be set directly.
- (t
- (srecode-dictionary-set-value dict key entry)))))
- (oref otherdict namehash))))
-
-(cl-defmethod srecode-dictionary-lookup-name ((dict srecode-dictionary)
- name &optional non-recursive)
- "Return information about DICT's value for NAME.
-DICT is a dictionary, and NAME is a string that is treated as the
-name of an entry in the dictionary. If such an entry exists, its
-value is returned. Otherwise, nil is returned. Normally, the
-lookup is recursive in the sense that the parent of DICT is
-searched for NAME if it is not found in DICT. This recursive
-lookup can be disabled by the optional argument NON-RECURSIVE.
-
-This function derives values for some special NAMEs, such as
-`FIRST' and `LAST'."
- (if (not (slot-boundp dict 'namehash))
- nil
- ;; Get the value of this name from the dictionary or its parent
- ;; unless the lookup should be non-recursive.
- (with-slots (namehash parent) dict
- (or (gethash name namehash)
- (and (not non-recursive)
- (not (member name '("FIRST" "LAST" "NOTFIRST" "NOTLAST")))
- parent
- (srecode-dictionary-lookup-name parent name)))))
- )
-
-(cl-defmethod srecode-root-dictionary ((dict srecode-dictionary))
- "For dictionary DICT, return the root dictionary.
-The root dictionary is usually for a current or active insertion."
- (let ((ans dict))
- (while (oref ans parent)
- (setq ans (oref ans parent)))
- ans))
-
-;;; COMPOUND VALUE METHODS
-;;
-;; Compound values must provide at least the toString method
-;; for use in converting the compound value into something insertable.
-
-(cl-defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value)
- _function
- _dictionary)
- "Convert the compound dictionary value CP to a string.
-If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect
-of the compound value. The FUNCTION could be a fraction
-of some function symbol with a logical prefix excluded.
-
-If you subclass `srecode-dictionary-compound-value' then this
-method could return nil, but if it does that, it must insert
-the value itself using `princ', or by detecting if the current
-standard out is a buffer, and using `insert'."
- (eieio-object-name cp))
-
-(cl-defmethod srecode-dump ((cp srecode-dictionary-compound-value)
- &optional _indent)
- "Display information about this compound value."
- (princ (eieio-object-name cp))
- )
-
-(cl-defmethod srecode-compound-toString
- ((cp srecode-dictionary-compound-variable)
- _function
- dictionary)
- "Convert the compound dictionary variable value CP into a string.
-FUNCTION and DICTIONARY are as for the baseclass."
- (require 'srecode/insert)
- (srecode-insert-code-stream (oref cp compiled) dictionary))
-
-
-(cl-defmethod srecode-dump ((cp srecode-dictionary-compound-variable)
- &optional indent)
- "Display information about this compound value."
- (require 'srecode/compile)
- (princ "# Compound Variable #\n")
- (let ((indent (+ 4 (or indent 0)))
- (cmp (oref cp compiled))
- )
- (srecode-dump-code-list cmp (make-string indent ? ))
- ))
-
-;;; FIELD EDITING COMPOUND VALUE
-;;
-;; This is an interface to using field-editing objects
-;; instead of asking questions. This provides the basics
-;; behind this compound value.
-
-(defclass srecode-field-value (srecode-dictionary-compound-value)
- ((firstinserter :initarg :firstinserter
- :documentation
- "The inserter object for the first occurrence of this field.")
- (defaultvalue :initarg :defaultvalue
- :documentation
- "The default value for this inserter.")
- )
- "When inserting values with editable field mode, a dictionary value.
-Compound values allow a field to be stored in the dictionary for when
-it is referenced a second time. This compound value can then be
-inserted with a new editable field.")
-
-(cl-defmethod srecode-compound-toString((cp srecode-field-value)
- function
- dictionary)
- "Convert this field into an insertable string."
- ;; If we are not in a buffer, then this is not supported.
- (when (not (bufferp standard-output))
- (error "FIELDS invoked while inserting template to non-buffer"))
-
- (if function
- (error "@todo: Cannot mix field insertion with functions")
-
- ;; No function. Perform a plain field insertion.
- ;; We know we are in a buffer, so we can perform the insertion.
- (let* ((dv (oref cp defaultvalue))
- (sti (oref cp firstinserter))
- (start (point))
- (name (oref sti object-name)))
-
- (cond
- ;; No default value.
- ((not dv) (insert name))
- ;; A compound value as the default? Recurse.
- ((cl-typep dv 'srecode-dictionary-compound-value)
- (srecode-compound-toString dv function dictionary))
- ;; A string that is empty? Use the name.
- ((and (stringp dv) (string= dv ""))
- (insert name))
- ;; Insert strings
- ((stringp dv) (insert dv))
- ;; Some other issue
- (t
- (error "Unknown default value for value %S" name)))
-
- ;; Create a field from the inserter.
- (srecode-field name :name name
- :start start
- :end (point)
- :prompt (oref sti prompt)
- :read-fcn (oref sti read-fcn)
- )
- ))
- ;; Returning nil is a signal that we have done the insertion ourselves.
- nil)
-
-\f
-;;; Higher level dictionary functions
-;;
-(defun srecode-create-dictionaries-from-tags (tags state)
- "Create a dictionary with entries according to TAGS.
-
-TAGS should be in the format produced by the template file
-grammar. That is
-
-TAGS = (ENTRY_1 ENTRY_2 ...)
-
-where
-
-ENTRY_N = (NAME ENTRY_N_1 ENTRY_N_2 ...) | TAG
-
-where TAG is a semantic tag of class `variable'. The (NAME ... )
-form creates a child dictionary which is stored under the name
-NAME. The TAG form creates a value entry or section dictionary
-entry whose name is the name of the tag.
-
-STATE is the current compiler state."
- (let ((dict (srecode-create-dictionary t))
- (entries (apply #'append
- (mapcar
- (lambda (entry)
- (cond
- ;; Entry is a tag
- ((semantic-tag-p entry)
- (let ((name (semantic-tag-name entry))
- (value (semantic-tag-variable-default entry)))
- (list name
- (if (and (listp value)
- (= (length value) 1)
- (stringp (car value)))
- (car value)
- value))))
-
- ;; Entry is a nested dictionary
- (t
- (let ((name (car entry))
- (entries (cdr entry)))
- (list name
- (srecode-create-dictionaries-from-tags
- entries state))))))
- tags))))
- (srecode-dictionary-add-entries
- dict entries state)
- dict)
- )
-
-;;; DUMP DICTIONARY
-;;
-;; Make a dictionary, and dump it's contents.
-
-(defun srecode-adebug-dictionary ()
- "Run data-debug on this mode's dictionary."
- (interactive)
- (require 'eieio-datadebug)
- (require 'srecode/find)
- (let* ((modesym major-mode)
- (start (current-time))
- (_ (or (progn (srecode-load-tables-for-mode modesym)
- (srecode-get-mode-table modesym))
- (error "No table found for mode %S" modesym)))
- (dict (srecode-create-dictionary (current-buffer)))
- )
- (message "Creating a dictionary took %.2f seconds."
- (semantic-elapsed-time start nil))
- (data-debug-new-buffer "*SRECODE ADEBUG*")
- (data-debug-insert-object-slots dict "*")))
-
-(defun srecode-dictionary-dump ()
- "Dump a typical fabricated dictionary."
- (interactive)
- (require 'srecode/find)
- (let ((modesym major-mode))
- ;; This load allows the dictionary access to inherited
- ;; and stacked dictionary entries.
- (srecode-load-tables-for-mode modesym)
- (let ((tmp (srecode-get-mode-table modesym))
- )
- (if (not tmp)
- (error "No table found for mode %S" modesym))
- ;; Now make the dictionary.
- (let ((dict (srecode-create-dictionary (current-buffer))))
- (with-output-to-temp-buffer "*SRECODE DUMP*"
- (princ "DICTIONARY FOR ")
- (princ major-mode)
- (princ "\n--------------------------------------------\n")
- (srecode-dump dict))
- ))))
-
-(cl-defmethod srecode-dump ((dict srecode-dictionary) &optional indent)
- "Dump a dictionary."
- (if (not indent) (setq indent 0))
- (maphash (lambda (key entry)
- (princ (make-string indent ? ))
- (princ " ")
- (princ key)
- (princ " ")
- (cond ((and (listp entry)
- (srecode-dictionary-p (car entry)))
- (let ((newindent (if indent
- (+ indent 4)
- 4)))
- (while entry
- (princ " --> SUBDICTIONARY ")
- (princ (eieio-object-name dict))
- (princ "\n")
- (srecode-dump (car entry) newindent)
- (setq entry (cdr entry))
- ))
- (princ "\n")
- )
- ((cl-typep entry 'srecode-dictionary-compound-value)
- (srecode-dump entry indent)
- (princ "\n")
- )
- (t
- (prin1 entry)
- ;(princ "\n")
- ))
- (terpri)
- )
- (oref dict namehash))
- )
-
-(provide 'srecode/dictionary)
-
-;;; srecode/dictionary.el ends here
+++ /dev/null
-;;; srecode/document.el --- Documentation (comment) generation -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Routines for fabricating human readable text from function and
-;; variable names as base-text for function comments. Document is not
-;; meant to generate end-text for any function. It is merely meant to
-;; provide some useful base words and text, and as a framework for
-;; managing comments.
-;;
-;;; Origins:
-;;
-;; Document was first written with cparse, a custom regexp based c
-;; parser.
-;;
-;; Document was then ported to cedet/semantic using sformat (super
-;; format) as the templating engine.
-;;
-;; Document has now been ported to srecode, using the semantic recoder
-;; as the templating engine.
-
-;; This file combines srecode/document.el and srecode/document-vars.el
-;; from the CEDET repository.
-
-(require 'srecode/args)
-(require 'srecode/dictionary)
-(require 'srecode/extract)
-(require 'srecode/insert)
-(require 'srecode/semantic)
-
-(require 'semantic)
-(require 'semantic/tag)
-(require 'semantic/doc)
-(require 'pulse)
-
-;;; Code:
-
-(defgroup document nil
- "File and tag browser frame."
- :group 'texinfo
- :group 'srecode)
-
-(defcustom srecode-document-autocomment-common-nouns-abbrevs
- '(
- ("sock\\(et\\)?" . "socket")
- ("addr\\(ess\\)?" . "address")
- ("buf\\(f\\(er\\)?\\)?" . "buffer")
- ("cur\\(r\\(ent\\)?\\)?" . "current")
- ("dev\\(ice\\)?" . "device")
- ("doc" . "document")
- ("i18n" . "internationalization")
- ("file" . "file")
- ("line" . "line")
- ("l10n" . "localization")
- ("msg\\|message" . "message")
- ("name" . "name")
- ("next\\|nxt" . "next")
- ("num\\(ber\\)?" . "number")
- ("port" . "port")
- ("host" . "host")
- ("obj\\|object" . "object")
- ("previous\\|prev" . "previous")
- ("str\\(ing\\)?" . "string")
- ("use?r" . "user")
- ("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;common syllable
- )
- "List of common English abbreviations or full words.
-These are nouns (as opposed to verbs) for use in creating expanded
-versions of names. This is an alist with each element of the form:
- (MATCH . RESULT)
-MATCH is a regexp to match in the type field.
-RESULT is a string."
- :type '(repeat (cons (regexp :tag "Regexp")
- (string :tag "Doc Text"))))
-
-(defcustom srecode-document-autocomment-function-alist
- '(
- ("abort" . "Aborts the")
- ;; trick to get re-alloc and alloc to pair into one sentence.
- ("realloc" . "moves or ")
- ("alloc\\(ate\\)?" . "Allocates and initializes a new ")
- ("clean" . "Cleans up the")
- ("clobber" . "Removes")
- ("close" . "Cleanly closes")
- ("check" . "Checks the")
- ("comp\\(are\\)?" . "Compares the")
- ("create" . "Creates a new ")
- ("find" . "Finds ")
- ("free" . "Frees up space")
- ("gen\\(erate\\)?" . "Generates a new ")
- ("get\\|find" . "Looks for the given ")
- ("gobble" . "Removes")
- ("he?lp" . "Provides help for")
- ("li?ste?n" . "Listens for ")
- ("connect" . "Connects to ")
- ("acc?e?pt" . "Accepts a ")
- ("load" . "Loads in ")
- ("match" . "Check that parameters match")
- ("name" . "Provides a name which ")
- ("new" . "Allocates a ")
- ("parse" . "Parses the parameters and returns ")
- ("print\\|display" . "Prints out")
- ("read" . "Reads from")
- ("reset" . "Resets the parameters and returns")
- ("scan" . "Scans the ")
- ("setup\\|init\\(ialize\\)?" . "Initializes the ")
- ("select" . "Chooses the ")
- ("send" . "Sends a")
- ("re?c\\(v\\|ieves?\\)" . "Receives a ")
- ("to" . "Converts ")
- ("update" . "Updates the ")
- ("wait" . "Waits for ")
- ("write" . "Writes to")
- )
- "List of names to string match against the function name.
-This is an alist with each element of the form:
- (MATCH . RESULT)
-MATCH is a regexp to match in the type field.
-RESULT is a string.
-
-Certain prefixes may always mean the same thing, and the same comment
-can be used as a beginning for the description. Regexp should be
-lower case since the string they are compared to is downcased.
-A string may end in a space, in which case, last-alist is searched to
-see how best to describe what can be returned.
-Doesn't always work correctly, but that is just because English
-doesn't always work correctly."
- :type '(repeat (cons (regexp :tag "Regexp")
- (string :tag "Doc Text"))))
-
-(defcustom srecode-document-autocomment-common-nouns-abbrevs
- '(
- ("sock\\(et\\)?" . "socket")
- ("addr\\(ess\\)?" . "address")
- ("buf\\(f\\(er\\)?\\)?" . "buffer")
- ("cur\\(r\\(ent\\)?\\)?" . "current")
- ("dev\\(ice\\)?" . "device")
- ("file" . "file")
- ("line" . "line")
- ("msg\\|message" . "message")
- ("name" . "name")
- ("next\\|nxt" . "next")
- ("port" . "port")
- ("host" . "host")
- ("obj\\|object" . "object")
- ("previous\\|prev" . "previous")
- ("str\\(ing\\)?" . "string")
- ("use?r" . "user")
- ("num\\(ber\\)?" . "number")
- ("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;common syllable
- )
- "List of common English abbreviations or full words.
-These are nouns (as opposed to verbs) for use in creating expanded
-versions of names. This is an alist with each element of the form:
- (MATCH . RESULT)
-MATCH is a regexp to match in the type field.
-RESULT is a string."
- :type '(repeat (cons (regexp :tag "Regexp")
- (string :tag "Doc Text"))))
-
-(defcustom srecode-document-autocomment-return-first-alist
- '(
- ;; Static must be first in the list to provide the intro to the sentence
- ("static" . "Locally defined function which ")
- ("Bool\\|BOOL" . "Status of ")
- )
- "List of regexp matches for types.
-They provide a little bit of text when typing information is
-described.
-This is an alist with each element of the form:
- (MATCH . RESULT)
-MATCH is a regexp to match in the type field.
-RESULT is a string."
- :type '(repeat (cons (regexp :tag "Regexp")
- (string :tag "Doc Text"))))
-
-(defcustom srecode-document-autocomment-return-last-alist
- '(
- ("static[ \t\n]+struct \\([a-zA-Z0-9_]+\\)" . "%s")
- ("struct \\([a-zA-Z0-9_]+\\)" . "%s")
- ("static[ \t\n]+union \\([a-zA-Z0-9_]+\\)" . "%s")
- ("union \\([a-zA-Z0-9_]+\\)" . "%s")
- ("static[ \t\n]+enum \\([a-zA-Z0-9_]+\\)" . "%s")
- ("enum \\([a-zA-Z0-9_]+\\)" . "%s")
- ("static[ \t\n]+\\([a-zA-Z0-9_]+\\)" . "%s")
- ("\\([a-zA-Z0-9_]+\\)" . "of type %s")
- )
- "List of regexps which provide the type of the return value.
-This is an alist with each element of the form:
- (MATCH . RESULT)
-MATCH is a regexp to match in the type field.
-RESULT is a string, which can contain %s, which is replaced with
-`match-string' 1."
- :type '(repeat (cons (regexp :tag "Regexp")
- (string :tag "Doc Text"))))
-
-(defcustom srecode-document-autocomment-param-alist
- '( ("[Cc]txt" . "Context")
- ("[Ii]d" . "Identifier of")
- ("[Tt]ype" . "Type of")
- ("[Nn]ame" . "Name of")
- ("argc" . "Number of arguments")
- ("argv" . "Argument vector")
- ("envp" . "Environment variable vector")
- )
- "Alist of common variable names appearing as function parameters.
-This is an alist with each element of the form:
- (MATCH . RESULT)
-MATCH is a regexp to match in the type field.
-RESULT is a string of text to use to describe MATCH.
-When one is encountered, document-insert-parameters will automatically
-place this comment after the parameter name."
- :type '(repeat (cons (regexp :tag "Regexp")
- (string :tag "Doc Text"))))
-
-(defcustom srecode-document-autocomment-param-type-alist
- '(("const" . "Constant")
- ("void" . "Empty")
- ("char[ ]*\\*" . "String ")
- ("\\*\\*" . "Pointer to ")
- ("\\*" . "Pointer ")
- ("char[ ]*\\([^ \t*]\\|$\\)" . "Character")
- ("int\\|long" . "Number of")
- ("FILE" . "File of")
- ("float\\|double" . "Value of")
- ;; How about some X things?
- ("Bool\\|BOOL" . "Flag")
- ("Window" . "Window")
- ("GC" . "Graphic Context")
- ("Widget" . "Widget")
- )
- "Alist of input parameter types and strings describing them.
-This is an alist with each element of the form:
- (MATCH . RESULT)
-MATCH is a regexp to match in the type field.
-RESULT is a string."
- :type '(repeat (cons (regexp :tag "Regexp")
- (string :tag "Doc Text"))))
-
-;;;###autoload
-(defun srecode-document-insert-comment ()
- "Insert some comments.
-Whack any comments that may be in the way and replace them.
-If the region is active, then insert group function comments.
-If the cursor is in a comment, figure out what kind of comment it is
- and replace it.
-If the cursor is in a function, insert a function comment.
-If the cursor is on a one line prototype, then insert post-fcn comments."
- (interactive)
- (semantic-fetch-tags)
- (let ((ctxt (srecode-calculate-context)))
- (if ;; Active region stuff.
- (or srecode-handle-region-when-non-active-flag
- (eq last-command 'mouse-drag-region)
- (and transient-mark-mode mark-active))
- (if (> (point) (mark))
- (srecode-document-insert-group-comments (mark) (point))
- (srecode-document-insert-group-comments (point) (mark)))
- ;; ELSE
-
- ;; A declaration comment. Find what it documents.
- (when (equal ctxt '("declaration" "comment"))
-
- ;; If we are on a one line tag/comment, go to that fcn.
- (if (save-excursion (back-to-indentation)
- (semantic-current-tag))
- (back-to-indentation)
-
- ;; Else, do we have a fcn following us?
- (let ((tag (semantic-find-tag-by-overlay-next)))
- (when tag (semantic-go-to-tag tag))))
- )
-
- ;; Now analyze the tag we may be on.
-
- (if (semantic-current-tag)
- (cond
- ;; A one-line variable
- ((and (semantic-tag-of-class-p (semantic-current-tag) 'variable)
- (srecode-document-one-line-tag-p (semantic-current-tag)))
- (srecode-document-insert-variable-one-line-comment))
- ;; A plain function
- ((semantic-tag-of-class-p (semantic-current-tag) 'function)
- (srecode-document-insert-function-comment))
- ;; Don't know.
- (t
- (error "Not sure what to comment"))
- )
-
- ;; ELSE, no tag. Perhaps we should just insert a nice section
- ;; header??
-
- (let ((title (read-string "Section Title (RET to skip): ")))
-
- (when (and (stringp title) (not (= (length title) 0)))
- (srecode-document-insert-section-comment title)))
-
- ))))
-
-(defun srecode-document-insert-section-comment (&optional title)
- "Insert a section comment with TITLE."
- (interactive "sSection Title: ")
-
- (srecode-load-tables-for-mode major-mode)
- (srecode-load-tables-for-mode major-mode 'document)
-
- (if (not (srecode-table))
- (error "No template table found for mode %s" major-mode))
-
- (let* ((dict (srecode-create-dictionary))
- (temp (srecode-template-get-table (srecode-table)
- "section-comment"
- "declaration"
- 'document)))
- (if (not temp)
- (error "No templates for inserting section comments"))
-
- (when title
- (srecode-dictionary-set-value
- dict "TITLE" title))
-
- (srecode-insert-fcn temp dict)
- ))
-
-
-(defun srecode-document-trim-whitespace (str)
- "Strip stray whitespace from around STR."
- (when (string-match "^\\(\\s-\\|\n\\)+" str)
- (setq str (replace-match "" t t str)))
- (when (string-match "\\(\\s-\\|\n\\)+$" str)
- (setq str (replace-match "" t t str)))
- str)
-
-;;;###autoload
-(defun srecode-document-insert-function-comment (&optional fcn-in)
- "Insert or replace a function comment.
-FCN-IN is the Semantic tag of the function to add a comment too.
-If FCN-IN is not provided, the current tag is used instead.
-It is assumed that the comment occurs just in front of FCN-IN."
- (interactive)
-
- (srecode-load-tables-for-mode major-mode)
- (srecode-load-tables-for-mode major-mode 'document)
-
- (if (not (srecode-table))
- (error "No template table found for mode %s" major-mode))
-
- (let* ((dict (srecode-create-dictionary))
- (temp (srecode-template-get-table (srecode-table)
- "function-comment"
- "declaration"
- 'document)))
- (if (not temp)
- (error "No templates for inserting function comments"))
-
- ;; Try to figure out the tag we want to use.
- (when (not fcn-in)
- (semantic-fetch-tags)
- (setq fcn-in (semantic-current-tag)))
-
- (when (or (not fcn-in)
- (not (semantic-tag-of-class-p fcn-in 'function)))
- (error "No tag of class `function' to insert comment for"))
-
- (if (not (eq (current-buffer) (semantic-tag-buffer fcn-in)))
- (error "Only insert comments for tags in the current buffer"))
-
- ;; Find any existing doc strings.
- (semantic-go-to-tag fcn-in)
- (beginning-of-line)
- (forward-char -1)
-
- (let ((lextok (semantic-documentation-comment-preceding-tag fcn-in 'lex))
- (doctext
- (srecode-document-function-name-comment fcn-in))
- )
-
- (when lextok
- (let* ((s (semantic-lex-token-start lextok))
- (e (semantic-lex-token-end lextok))
- (plaintext
- (srecode-document-trim-whitespace
- (save-excursion
- (goto-char s)
- (semantic-doc-snarf-comment-for-tag nil))))
- (extract (condition-case nil
- (srecode-extract temp s e)
- (error nil))
- )
- (distance (count-lines e (semantic-tag-start fcn-in)))
- (belongelsewhere (save-excursion
- (goto-char s)
- (back-to-indentation)
- (semantic-current-tag)))
- )
-
- (when (not belongelsewhere)
-
- (pulse-momentary-highlight-region s e)
-
- ;; There are many possible states that comment could be in.
- ;; Take a guess about what the user would like to do, and ask
- ;; the right kind of question.
- (when (or (not (> distance 2))
- (y-or-n-p "Replace this comment? "))
-
- (when (> distance 2)
- (goto-char e)
- (delete-horizontal-space)
- (delete-blank-lines))
-
- (cond
- ((and plaintext (not extract))
- (if (y-or-n-p "Convert old-style comment to Template with old text? ")
- (setq doctext plaintext))
- (delete-region s e)
- (goto-char s))
- (extract
- (when (y-or-n-p "Refresh pre-existing comment (recycle old doc)? ")
- (delete-region s e)
- (goto-char s)
- (setq doctext
- (srecode-document-trim-whitespace
- (srecode-dictionary-lookup-name extract "DOC")))))
- ))
- )))
-
- (beginning-of-line)
-
- ;; Perform the insertion
- (let ((srecode-semantic-selected-tag fcn-in)
- (srecode-semantic-apply-tag-augment-hook
- (lambda (tag dict)
- (srecode-dictionary-set-value
- dict "DOC"
- (if (eq tag fcn-in)
- doctext
- (srecode-document-parameter-comment tag))
- )))
- )
- (srecode-insert-fcn temp dict)
- ))
- ))
-
-;;;###autoload
-(defun srecode-document-insert-variable-one-line-comment (&optional var-in)
- "Insert or replace a variable comment.
-VAR-IN is the Semantic tag of the function to add a comment too.
-If VAR-IN is not provided, the current tag is used instead.
-It is assumed that the comment occurs just after VAR-IN."
- (interactive)
-
- (srecode-load-tables-for-mode major-mode)
- (srecode-load-tables-for-mode major-mode 'document)
-
- (if (not (srecode-table))
- (error "No template table found for mode %s" major-mode))
-
- (let* ((dict (srecode-create-dictionary))
- (temp (srecode-template-get-table (srecode-table)
- "variable-same-line-comment"
- "declaration"
- 'document)))
- (if (not temp)
- (error "No templates for inserting variable comments"))
-
- ;; Try to figure out the tag we want to use.
- (when (not var-in)
- (semantic-fetch-tags)
- (setq var-in (semantic-current-tag)))
-
- (when (or (not var-in)
- (not (semantic-tag-of-class-p var-in 'variable)))
- (error "No tag of class `variable' to insert comment for"))
-
- (if (not (eq (current-buffer) (semantic-tag-buffer var-in)))
- (error "Only insert comments for tags in the current buffer"))
-
- ;; Find any existing doc strings.
- (goto-char (semantic-tag-end var-in))
- (skip-syntax-forward "-" (line-end-position))
- (let ((lextok (semantic-doc-snarf-comment-for-tag 'lex))
- )
-
- (when lextok
- (let ((s (semantic-lex-token-start lextok))
- (e (semantic-lex-token-end lextok)))
-
- (pulse-momentary-highlight-region s e)
-
- (when (not (y-or-n-p "A comment already exists. Replace? "))
- (error "Quit"))
-
- ;; Extract text from the existing comment.
- (srecode-extract temp s e)
-
- (delete-region s e)
- (goto-char s) ;; To avoid adding a CR.
- ))
- )
-
- ;; Clean up the end of the line and use handy comment-column.
- (end-of-line)
- (delete-horizontal-space)
- (move-to-column comment-column t)
- (when (< (point) (line-end-position)) (end-of-line))
-
- ;; Perform the insertion
- (let ((srecode-semantic-selected-tag var-in)
- (srecode-semantic-apply-tag-augment-hook
- (lambda (tag dict)
- (srecode-dictionary-set-value
- dict "DOC" (srecode-document-parameter-comment
- tag))))
- )
- (srecode-insert-fcn temp dict)
- ))
- )
-
-;;;###autoload
-(defun srecode-document-insert-group-comments (beg end)
- "Insert group comments around the active between BEG and END.
-If the region includes only parts of some tags, expand out
-to the beginning and end of the tags on the region.
-If there is only one tag in the region, complain."
- (interactive "r")
- (srecode-load-tables-for-mode major-mode)
- (srecode-load-tables-for-mode major-mode 'document)
-
- (if (not (srecode-table))
- (error "No template table found for mode %s" major-mode))
-
- (let* ((dict (srecode-create-dictionary))
- (context "declaration")
- (temp-start nil)
- (temp-end nil)
- (tag-start (save-excursion
- (goto-char beg)
- (or (semantic-current-tag)
- (semantic-find-tag-by-overlay-next))))
- (tag-end (save-excursion
- (goto-char end)
- (or (semantic-current-tag)
- (semantic-find-tag-by-overlay-prev))))
- (parent-tag nil)
- (first-pos beg)
- (second-pos end)
- )
-
- ;; If beg/end wrapped nothing, then tag-start,end would actually
- ;; point at some odd stuff that is out of order.
- (when (or (not tag-start) (not tag-end)
- (> (semantic-tag-end tag-start)
- (semantic-tag-start tag-end)))
- (setq tag-start nil
- tag-end nil))
-
- (when tag-start
- ;; If tag-start and -end are the same, and it is a class or
- ;; struct, try to find child tags inside the classdecl.
- (cond
- ((and (eq tag-start tag-end)
- tag-start
- (semantic-tag-of-class-p tag-start 'type))
- (setq parent-tag tag-start)
- (setq tag-start (semantic-find-tag-by-overlay-next beg)
- tag-end (semantic-find-tag-by-overlay-prev end))
- )
- ((eq (semantic-find-tag-parent-by-overlay tag-start) tag-end)
- (setq parent-tag tag-end)
- (setq tag-end (semantic-find-tag-by-overlay-prev end))
- )
- ((eq tag-start (semantic-find-tag-parent-by-overlay tag-end))
- (setq parent-tag tag-start)
- (setq tag-start (semantic-find-tag-by-overlay-next beg))
- )
- )
-
- (when parent-tag
- ;; We are probably in a classdecl
- ;; @todo -could I really use (srecode-calculate-context) ?
-
- (setq context "classdecl")
- )
-
- ;; Derive start and end locations based on the tags.
- (setq first-pos (semantic-tag-start tag-start)
- second-pos (semantic-tag-end tag-end))
- )
- ;; Now load the templates
- (setq temp-start (srecode-template-get-table (srecode-table)
- "group-comment-start"
- context
- 'document)
- temp-end (srecode-template-get-table (srecode-table)
- "group-comment-end"
- context
- 'document))
-
- (when (or (not temp-start) (not temp-end))
- (error "No templates for inserting group comments"))
-
- ;; Setup the name of this group ahead of time.
-
- ;; @todo - guess at a name based on common strings
- ;; of the tags in the group.
- (srecode-dictionary-set-value
- dict "GROUPNAME"
- (read-string "Name of group: "))
-
- ;; Perform the insertion
- ;; Do the end first so we don't need to recalculate anything.
- ;;
- (goto-char second-pos)
- (end-of-line)
- (srecode-insert-fcn temp-end dict)
-
- (goto-char first-pos)
- (beginning-of-line)
- (srecode-insert-fcn temp-start dict)
-
- ))
-
-
-;;; Document Generation Functions
-;;
-;; Routines for making up English style comments.
-
-(defun srecode-document-function-name-comment (tag)
- "Create documentation for the function defined in TAG.
-If we can identify a verb in the list followed by some
-name part then check the return value to see if we can use that to
-finish off the sentence. That is, any function with `alloc' in it will be
-allocating something based on its type."
- (let ((al srecode-document-autocomment-return-first-alist)
- (dropit nil)
- (tailit nil)
- (news "")
- (fname (semantic-tag-name tag))
- (retval (or (semantic-tag-type tag) "")))
- (if (listp retval)
- ;; convert a type list into a long string to analyze.
- (setq retval (car retval)))
- ;; check for modifiers like static
- (while al
- (if (string-match (car (car al)) (downcase retval))
- (progn
- (setq news (concat news (cdr (car al))))
- (setq dropit t)
- (setq al nil)))
- (setq al (cdr al)))
- ;; check for verb parts!
- (setq al srecode-document-autocomment-function-alist)
- (while al
- (if (string-match (car (car al)) (downcase fname))
- (progn
- (setq news
- (concat news (if dropit (downcase (cdr (car al)))
- (cdr (car al)))))
- ;; if we end in a space, then we are expecting a potential
- ;; return value.
- (if (= ? (aref news (1- (length news))))
- (setq tailit t))
- (setq al nil)))
- (setq al (cdr al)))
- ;; check for noun parts!
- (setq al srecode-document-autocomment-common-nouns-abbrevs)
- (while al
- (if (string-match (car (car al)) (downcase fname))
- (progn
- (setq news
- (concat news (if dropit (downcase (cdr (car al)))
- (cdr (car al)))))
- (setq al nil)))
- (setq al (cdr al)))
- ;; add trailers to names which are obviously returning something.
- (if tailit
- (progn
- (setq al srecode-document-autocomment-return-last-alist)
- (while al
- (if (string-match (car (car al)) (downcase retval))
- (progn
- (setq news
- (concat news " "
- ;; this one may use parts of the return value.
- (format (cdr (car al))
- (srecode-document-programmer->english
- (substring retval (match-beginning 1)
- (match-end 1))))))
- (setq al nil)))
- (setq al (cdr al)))))
- news))
-
-(defun srecode-document-parameter-comment (param &optional _commentlist)
- "Convert tag or string PARAM into a name,comment pair.
-Optional COMMENTLIST is list of previously existing comments to
-use instead in alist form. If the name doesn't appear in the list of
-standard names, then english it instead."
- (let ((cmt "")
- (aso srecode-document-autocomment-param-alist)
- (fnd nil)
- (name (if (stringp param) param (semantic-tag-name param)))
- (tt (if (stringp param) nil (semantic-tag-type param))))
- ;; Make sure the type is a string.
- (if (listp tt)
- (setq tt (semantic-tag-name tt)))
- ;; Find name description parts.
- (while aso
- (if (string-match (car (car aso)) name)
- (progn
- (setq fnd t)
- (setq cmt (concat cmt (cdr (car aso))))))
- (setq aso (cdr aso)))
- (if (/= (length cmt) 0)
- nil
- ;; finally check for array parts
- (if (and (not (stringp param)) (semantic-tag-modifiers param))
- (setq cmt (concat cmt "array of ")))
- (setq aso srecode-document-autocomment-param-type-alist)
- (while (and aso tt)
- (if (string-match (car (car aso)) tt)
- (setq cmt (concat cmt (cdr (car aso)))))
- (setq aso (cdr aso))))
- ;; Convert from programmer to english.
- (if (not fnd)
- (setq cmt (concat cmt " "
- (srecode-document-programmer->english name))))
- cmt))
-
-(defun srecode-document-programmer->english (programmer)
- "Take PROGRAMMER and convert it into English.
-Works with the following rules:
- 1) convert all _ into spaces.
- 2) inserts spaces between CamelCasing word breaks.
- 3) expands noun names based on common programmer nouns.
-
- This function is designed for variables, not functions. This does
-not account for verb parts."
- (if (string= "" programmer)
- ""
- (let ((ind 0) ;index in string
- (llow nil) ;lower/upper case flag
- (newstr nil) ;new string being generated
- (al nil)) ;autocomment list
- ;;
- ;; 1) Convert underscores
- ;;
- (while (< ind (length programmer))
- (setq newstr (concat newstr
- (if (= (aref programmer ind) ?_)
- " " (char-to-string (aref programmer ind)))))
- (setq ind (1+ ind)))
- (setq programmer newstr
- newstr nil
- ind 0)
- ;;
- ;; 2) Find word breaks between case changes
- ;;
- (while (< ind (length programmer))
- (setq newstr
- (concat newstr
- (let ((tc (aref programmer ind)))
- (if (and (>= tc ?a) (<= tc ?z))
- (progn
- (setq llow t)
- (char-to-string tc))
- (if llow
- (progn
- (setq llow nil)
- (concat " " (char-to-string tc)))
- (char-to-string tc))))))
- (setq ind (1+ ind)))
- ;;
- ;; 3) Expand the words if possible
- ;;
- (setq llow nil
- ind 0
- programmer newstr
- newstr nil)
- (while (string-match (concat "^\\s-*\\([^ \t\n]+\\)") programmer)
- (let ((ts (substring programmer (match-beginning 1) (match-end 1)))
- (end (match-end 1)))
- (setq al srecode-document-autocomment-common-nouns-abbrevs)
- (setq llow nil)
- (while al
- (if (string-match (car (car al)) (downcase ts))
- (progn
- (setq newstr (concat newstr (cdr (car al))))
- ;; don't terminate because we may actually have 2 words
- ;; next to each other we didn't identify before
- (setq llow t)))
- (setq al (cdr al)))
- (if (not llow) (setq newstr (concat newstr ts)))
- (setq newstr (concat newstr " "))
- (setq programmer (substring programmer end))))
- newstr)))
-
-;;; UTILS
-;;
-(defun srecode-document-one-line-tag-p (tag)
- "Does TAG fit on one line with space on the end?"
- (save-excursion
- (semantic-go-to-tag tag)
- (and (<= (semantic-tag-end tag) (line-end-position))
- (goto-char (semantic-tag-end tag))
- (< (current-column) 70))))
-
-(provide 'srecode/document)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/document"
-;; End:
-
-;;; srecode/document.el ends here
+++ /dev/null
-;;; srecode/el.el --- Emacs Lisp specific arguments -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Emacs Lisp specific handlers. To use these handlers in your
-;; template, add the :name part to your template argument list.
-;;
-;; Error if not in an Emacs Lisp mode
-
-;;; Code:
-
-(require 'srecode)
-(require 'srecode/semantic)
-
-(declare-function semanticdb-brute-find-tags-by-class "semantic/db-find")
-
-;;;###autoload
-(defun srecode-semantic-handle-:el (dict)
- "Add macros into the dictionary DICT based on the current Emacs Lisp file.
-Adds the following:
- PRENAME - The common name prefix of this file."
- (let* ((names (append (semantic-find-tags-by-class 'function (current-buffer))
- (semantic-find-tags-by-class 'variable (current-buffer)))
- )
- (common (try-completion "" names)))
-
- (srecode-dictionary-set-value dict "PRENAME" common)
- ))
-
-;;;###autoload
-(defun srecode-semantic-handle-:el-custom (dict)
- "Add macros into the dictionary DICT based on the current Emacs Lisp file.
-Adds the following:
- GROUP - The `defgroup' name we guess you want for variables.
- FACEGROUP - The `defgroup' name you might want for faces."
- (require 'semantic/db-find)
- (let ((groups (semanticdb-strip-find-results
- (semanticdb-brute-find-tags-by-class 'customgroup)))
- (varg nil)
- (faceg nil)
- )
-
- ;; Pick the best group
- (while groups
- (cond ((string-match "face" (semantic-tag-name (car groups)))
- (setq faceg (car groups)))
- ((not varg)
- (setq varg (car groups)))
- (t
- ;; What about other groups?
- ))
- (setq groups (cdr groups)))
-
- ;; Double check the facegroup.
- (setq faceg (or faceg varg))
-
- ;; Setup some variables
- (srecode-dictionary-set-value dict "GROUP" (semantic-tag-name varg))
- (srecode-dictionary-set-value dict "FACEGROUP" (semantic-tag-name faceg))
-
- ))
-
-(define-mode-local-override srecode-semantic-apply-tag-to-dict
- emacs-lisp-mode (tagobj dict)
- "Apply Emacs Lisp specific features from TAGOBJ into DICT.
-Calls `srecode-semantic-apply-tag-to-dict-default' first."
- (srecode-semantic-apply-tag-to-dict-default tagobj dict)
-
- ;; Pull out the tag for the individual pieces.
- (let* ((tag (oref tagobj prime))
- (doc (semantic-tag-docstring tag)))
-
- ;; It is much more common to have doc on ELisp.
- (srecode-dictionary-set-value dict "DOC" doc)
-
- (cond
- ;;
- ;; FUNCTION
- ;;
- ((eq (semantic-tag-class tag) 'function)
- (if (semantic-tag-get-attribute tag :user-visible-flag)
- (srecode-dictionary-set-value dict "INTERACTIVE" " (interactive)\n ")
- (srecode-dictionary-set-value dict "INTERACTIVE" ""))))))
-
-
-(provide 'srecode/el)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/el"
-;; End:
-
-;;; srecode/el.el ends here
+++ /dev/null
-;;; srecode/expandproto.el --- Expanding prototypes. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007, 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Methods for expanding a prototype into an implementation.
-
-(require 'ring)
-(require 'semantic)
-(require 'semantic/analyze)
-(require 'semantic/senator)
-(require 'srecode/insert)
-(require 'srecode/dictionary)
-
-(declare-function semantic-brute-find-tag-by-attribute-value "semantic/find")
-
-;;; Code:
-(defcustom srecode-expandproto-template-file-alist
- '( ( c++-mode . "srecode-expandproto-cpp.srt" )
- )
- ;; @todo - Make this variable auto-generated from the Makefile.
- "Associate template files for expanding prototypes to a major mode."
- :group 'srecode
- :type '(repeat (cons (sexp :tag "Mode")
- (sexp :tag "Filename"))
- ))
-
-;;;###autoload
-(defun srecode-insert-prototype-expansion ()
- "Insert get/set methods for the current class."
- (interactive)
-
- (srecode-load-tables-for-mode major-mode)
- (srecode-load-tables-for-mode major-mode
- srecode-expandproto-template-file-alist)
-
- (if (not (srecode-table))
- (error "No template table found for mode %s" major-mode))
-
- (let ((proto
- ;; Step 1: Find the prototype, or prototype list to expand.
- (srecode-find-prototype-for-expansion)))
-
- (if (not proto)
- (error "Could not find prototype to expand"))
-
- ;; Step 2: Insert implementations of the prototypes.
-
-
- ))
-
-(defun srecode-find-prototype-for-expansion ()
- "Find a prototype to use for expanding into an implementation."
- ;; We may find a prototype tag in one of several places.
- ;; Search in order of logical priority.
- (let ((proto nil)
- )
-
- ;; 1) A class full of prototypes under point.
- (let ((tag (semantic-current-tag)))
- (when tag
- (when (not (semantic-tag-of-class-p tag 'type))
- (setq tag (semantic-current-tag-parent))))
- (when (and tag (semantic-tag-of-class-p tag 'type))
- ;; If the current class has prototype members, then
- ;; we will do the whole class!
- (require 'semantic/find)
- (if (semantic-brute-find-tag-by-attribute-value
- :prototype t
- (semantic-tag-type-members tag))
- (setq proto tag)))
- )
-
- ;; 2) A prototype under point.
- (when (not proto)
- (let ((tag (semantic-current-tag)))
- (when (and tag
- (and
- (semantic-tag-of-class-p tag 'function)
- (semantic-tag-get-attribute tag :prototype)))
- (setq proto tag))))
-
- ;; 3) A tag in the kill ring that is a prototype
- (when (not proto)
- (if (ring-empty-p senator-tag-ring)
- nil ;; Not for us.
- (let ((tag (ring-ref senator-tag-ring 0))
- )
- (when
- (and tag
- (or
- (and
- (semantic-tag-of-class-p tag 'function)
- (semantic-tag-get-attribute tag :prototype))
- (and
- (semantic-tag-of-class-p tag 'type)
- (require 'semantic/find)
- (semantic-brute-find-tag-by-attribute-value
- :prototype t
- (semantic-tag-type-members tag))))
- )
- (setq proto tag))
- )))
-
- proto))
-
-(provide 'srecode/expandproto)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/expandproto"
-;; End:
-
-;;; srecode/expandproto.el ends here
+++ /dev/null
-;;; srecode/extract.el --- Extract content from previously inserted macro. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Extract content from a previously inserted macro.
-;;
-;; The extraction routines can be handy if you want to extract users
-;; added text from the middle of a template inserted block of text.
-;; This code will not work for all templates. It will only work for
-;; templates with unique static text between all the different insert
-;; macros.
-;;
-;; That said, it will handle include and section templates, so complex
-;; or deep template calls can be extracted.
-;;
-;; This code was specifically written for srecode-document, which
-;; wants to extract user written text, and reuse it in a reformatted
-;; comment.
-
-(require 'srecode)
-(require 'srecode/compile)
-(require 'srecode/insert)
-
-;;; Code:
-
-(defclass srecode-extract-state ()
- ((anchor :initform nil
- :documentation
- "The last known plain-text end location.")
- (lastinserter :initform nil
- :documentation
- "The last inserter with 'later extraction type.")
- (lastdict :initform nil
- :documentation
- "The dictionary associated with lastinserter.")
- )
- "The current extraction state.")
-
-(cl-defmethod srecode-extract-state-set ((st srecode-extract-state) ins dict)
- "Set onto the extract state ST a new inserter INS and dictionary DICT."
- (oset st lastinserter ins)
- (oset st lastdict dict))
-
-(cl-defmethod srecode-extract-state-set-anchor ((st srecode-extract-state))
- "Reset the anchor point on extract state ST."
- (oset st anchor (point)))
-
-(cl-defmethod srecode-extract-state-extract ((st srecode-extract-state)
- endpoint)
- "Perform an extraction on the extract state ST with ENDPOINT.
-If there was no waiting inserter, do nothing."
- (when (oref st lastinserter)
- (save-match-data
- (srecode-inserter-extract (oref st lastinserter)
- (oref st anchor)
- endpoint
- (oref st lastdict)
- st))
- ;; Clear state.
- (srecode-extract-state-set st nil nil)))
-
-;;; Extraction
-;l
-(defun srecode-extract (template start end)
- "Extract TEMPLATE from between START and END in the current buffer.
-Uses TEMPLATE's constant strings to break up the text and guess what
-the dictionary entries were for that block of text."
- (save-excursion
- (save-restriction
- (narrow-to-region start end)
- (let ((dict (srecode-create-dictionary t))
- (state (srecode-extract-state))
- )
- (goto-char start)
- (srecode-extract-method template dict state)
- dict))))
-
-(cl-defmethod srecode-extract-method ((st srecode-template) dictionary
- state)
- "Extract template ST and store extracted text in DICTIONARY.
-Optional STARTRETURN is a symbol in which the start of the first
-plain-text match occurred."
- (srecode-extract-code-stream (oref st code) dictionary state))
-
-(defun srecode-extract-code-stream (code dictionary state)
- "Extract CODE from buffer text into DICTIONARY.
-Uses string constants in CODE to split up the buffer.
-Uses STATE to maintain the current extraction state."
- (while code
- (cond
-
- ;; constant strings need mark the end of old inserters that
- ;; need to extract values, or are just there.
- ((stringp (car code))
- (srecode-extract-state-set-anchor state)
- ;; When we have a string, find it in the collection, then extract
- ;; that start point as the end point of the inserter
- (unless (re-search-forward (regexp-quote (car code))
- (point-max) t)
- (error "Unable to extract all dictionary entries"))
-
- (srecode-extract-state-extract state (match-beginning 0))
- (goto-char (match-end 0))
- )
-
- ;; Some inserters are simple, and need to be extracted after
- ;; we find our next block of static text.
- ((eq (srecode-inserter-do-extract-p (car code)) 'later)
- (srecode-extract-state-set state (car code) dictionary)
- )
-
- ;; Some inserter want to start extraction now, such as sections.
- ;; We can't predict the end point till we parse out the middle.
- ((eq (srecode-inserter-do-extract-p (car code)) 'now)
- (srecode-extract-state-set-anchor state)
- (srecode-inserter-extract (car code) (point) nil dictionary state))
- )
- (setq code (cdr code))
- ))
-
-;;; Inserter Base Extractors
-;;
-(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter))
- "Return non-nil if this inserter can extract values."
- nil)
-
-(cl-defmethod srecode-inserter-extract ((_ins srecode-template-inserter)
- _start _end _dict _state)
- "Extract text from START/END and store in DICT.
-Return nil as this inserter will extract nothing."
- nil)
-
-;;; Variable extractor is simple and can extract later.
-;;
-(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter-variable))
- "Return non-nil if this inserter can extract values."
- 'later)
-
-(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter-variable)
- start end vdict _state)
- "Extract text from START/END and store in VDICT.
-Return t if something was extracted.
-Return nil if this inserter doesn't need to extract anything."
- (srecode-dictionary-set-value vdict
- (oref ins object-name)
- (buffer-substring-no-properties
- start end))
- t)
-
-;;; Section Inserter
-;;
-(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter-section-start))
- "Return non-nil if this inserter can extract values."
- 'now)
-
-(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter-section-start)
- _start _end indict state)
- "Extract text from START/END and store in INDICT.
-Return the starting location of the first plain-text match.
-Return nil if nothing was extracted."
- (let ((name (oref ins object-name))
- (subdict (srecode-create-dictionary indict))
- (allsubdict nil))
-
- ;; Keep extracting till we can extract no more.
- (while (condition-case nil
- (progn
- (srecode-extract-method
- (oref ins template) subdict state)
- t)
- (error nil))
-
- ;; Success means keep this subdict, and also make a new one for
- ;; the next iteration.
- (setq allsubdict (cons subdict allsubdict))
- (setq subdict (srecode-create-dictionary indict))
- )
-
- (srecode-dictionary-set-value indict name (nreverse allsubdict))
-
- nil))
-
-;;; Include Extractor must extract now.
-;;
-(cl-defmethod srecode-inserter-do-extract-p ((_ins srecode-template-inserter-include))
- "Return non-nil if this inserter can extract values."
- 'now)
-
-(cl-defmethod srecode-inserter-extract ((ins srecode-template-inserter-include)
- start _end dict state)
- "Extract text from START/END and store in DICT.
-Return the starting location of the first plain-text match.
-Return nil if nothing was extracted."
- (goto-char start)
- (srecode-insert-include-lookup ins dict)
- ;; There are two modes for includes. One is with no dict,
- ;; so it is inserted straight. If the dict has a name, then
- ;; we need to run once per dictionary occurrence.
- (if (not (string= (oref ins object-name) ""))
- ;; With a name, do the insertion.
- (let ((subdict (srecode-dictionary-add-section-dictionary
- dict (oref ins object-name))))
- (error "Need to implement include with name extractor")
- ;; Recurse into the new template while no errors.
- (while (condition-case nil
- (progn
- (srecode-extract-method
- (oref ins includedtemplate) subdict
- state)
- t)
- (error nil))))
-
- ;; No stream, do the extraction into the current dictionary.
- (srecode-extract-method (oref ins includedtemplate) dict
- state))
- )
-
-
-(provide 'srecode/extract)
-
-;;; srecode/extract.el ends here
+++ /dev/null
-;;; srecode/fields.el --- Handling type-in fields in a buffer. -*- lexical-binding: t; -*-
-;;
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Idea courtesy of yasnippets.
-;;
-;; If someone prefers not to type unknown dictionary entries into
-;; mini-buffer prompts, it could instead use in-buffer fields.
-;;
-;; A template-region specifies an area in which the fields exist. If
-;; the cursor exits the region, all fields are cleared.
-;;
-;; Each field is independent, but some are linked together by name.
-;; Typing in one will cause the matching ones to change in step.
-;;
-;; Each field has 2 overlays. The second overlay allows control in
-;; the character just after the field, but does not highlight it.
-
-;; @TODO - Cancel an old field array if a new one is about to be created!
-
-;; Keep this library independent of SRecode proper.
-(require 'eieio)
-(require 'cl-generic)
-
-;;; Code:
-(defvar srecode-field-archive nil
- "While inserting a set of fields, collect in this variable.
-Once an insertion set is done, these fields will be activated.")
-
-\f
-;;; Customization
-;;
-
-(defface srecode-field-face
- '((((class color) (background dark))
- (:underline "green"))
- (((class color) (background light))
- (:underline "green4")))
- "Face used to specify editable fields from a template."
- :group 'semantic-faces)
-
-(defcustom srecode-fields-exit-confirmation nil
- "Ask for confirmation before leaving field editing mode."
- :group 'srecode
- :type 'boolean)
-
-;;; BASECLASS
-;;
-;; Fields and the template region share some basic overlay features.
-
-(defclass srecode-overlaid ()
- ((overlay :documentation
- "Overlay representing this field.
-The overlay will crossreference this object.")
- )
- "An object that gets automatically bound to an overlay.
-Has virtual :start and :end initializers.")
-
-(cl-defmethod initialize-instance ((olaid srecode-overlaid) &optional args)
- "Initialize OLAID, being sure it archived."
- ;; Extract :start and :end from the olaid list.
- (let ((newargs nil)
- (olay nil)
- start end
- )
-
- (while args
- (cond ((eq (car args) :start)
- (setq args (cdr args))
- (setq start (car args))
- (setq args (cdr args))
- )
- ((eq (car args) :end)
- (setq args (cdr args))
- (setq end (car args))
- (setq args (cdr args))
- )
- (t
- (push (car args) newargs)
- (setq args (cdr args))
- (push (car args) newargs)
- (setq args (cdr args)))
- ))
-
- ;; Create a temporary overlay now. We have to use an overlay and
- ;; not a marker because of the in-front insertion rules. The rules
- ;; are backward from what is wanted while typing.
- (setq olay (make-overlay start end (current-buffer) t nil))
- (overlay-put olay 'srecode-init-only t)
-
- (oset olaid overlay olay)
- (cl-call-next-method olaid (nreverse newargs))
-
- ))
-
-(cl-defmethod srecode-overlaid-activate ((olaid srecode-overlaid))
- "Activate the overlaid area."
- (let* ((ola (oref olaid overlay))
- (start (overlay-start ola))
- (end (overlay-end ola))
- ;; Create a new overlay here.
- (ol (make-overlay start end (current-buffer) nil t)))
-
- ;; Remove the old one.
- (delete-overlay ola)
-
- (overlay-put ol 'srecode olaid)
-
- (oset olaid overlay ol)
-
- ))
-
-(cl-defmethod srecode-delete ((olaid srecode-overlaid))
- "Delete the overlay from OLAID."
- (delete-overlay (oref olaid overlay))
- (slot-makeunbound olaid 'overlay)
- )
-
-(cl-defmethod srecode-empty-region-p ((olaid srecode-overlaid))
- "Return non-nil if the region covered by OLAID is of length 0."
- (= 0 (srecode-region-size olaid)))
-
-(cl-defmethod srecode-region-size ((olaid srecode-overlaid))
- "Return the length of region covered by OLAID."
- (let ((start (overlay-start (oref olaid overlay)))
- (end (overlay-end (oref olaid overlay))))
- (- end start)))
-
-(cl-defmethod srecode-point-in-region-p ((olaid srecode-overlaid))
- "Return non-nil if point is in the region of OLAID."
- (let ((start (overlay-start (oref olaid overlay)))
- (end (overlay-end (oref olaid overlay))))
- (and (>= (point) start) (<= (point) end))))
-
-(defun srecode-overlaid-at-point (class)
- "Return a list of overlaid fields of type CLASS at point."
- (let ((ol (overlays-at (point)))
- (ret nil))
- (while ol
- (let ((tmp (overlay-get (car ol) 'srecode)))
- (when (and tmp (object-of-class-p tmp class))
- (setq ret (cons tmp ret))))
- (setq ol (cdr ol)))
- (car (nreverse ret))))
-
-(cl-defmethod srecode-overlaid-text ((olaid srecode-overlaid) &optional set-to)
- "Return the text under OLAID.
-If SET-TO is a string, then replace the text of OLAID with SET-TO."
- (let* ((ol (oref olaid overlay))
- (start (overlay-start ol)))
- (if (not (stringp set-to))
- ;; Just return it.
- (buffer-substring-no-properties start (overlay-end ol))
- ;; Replace it.
- (save-excursion
- (delete-region start (overlay-end ol))
- (goto-char start)
- (insert set-to)
- (move-overlay ol start (+ start (length set-to))))
- nil)))
-
-;;; INSERTED REGION
-;;
-;; Managing point-exit, and flushing fields.
-
-(defclass srecode-template-inserted-region (srecode-overlaid)
- ((fields :documentation
- "A list of field overlays in this region.")
- (active-region :allocation :class
- :initform nil
- :documentation
- "The template region currently being handled.")
- )
- "Manage a buffer region in which fields exist.")
-
-(cl-defmethod initialize-instance ((ir srecode-template-inserted-region)
- &rest _args)
- "Initialize IR, capturing the active fields, and creating the overlay."
- ;; Fill in the fields
- (oset ir fields srecode-field-archive)
- (setq srecode-field-archive nil)
-
- ;; Initialize myself first.
- (cl-call-next-method)
- )
-
-(cl-defmethod srecode-overlaid-activate ((ir srecode-template-inserted-region))
- "Activate the template area for IR."
- ;; Activate all our fields
-
- (dolist (F (oref ir fields))
- (srecode-overlaid-activate F))
-
- ;; Activate our overlay.
- (cl-call-next-method)
-
- ;; Position the cursor at the first field
- (let ((first (car (oref ir fields))))
- (goto-char (overlay-start (oref first overlay))))
-
- ;; Set ourselves up as 'active'
- (oset ir active-region ir)
-
- ;; Setup the post command hook.
- (add-hook 'post-command-hook #'srecode-field-post-command t t)
- )
-
-(cl-defmethod srecode-delete ((ir srecode-template-inserted-region))
- "Call into our base, but also clear out the fields."
- ;; Clear us out of the baseclass.
- (oset ir active-region nil)
- ;; Clear our fields.
- (mapc #'srecode-delete (oref ir fields))
- ;; Call to our base
- (cl-call-next-method)
- ;; Clear our hook.
- (remove-hook 'post-command-hook #'srecode-field-post-command t))
-
-(defsubst srecode-active-template-region ()
- "Return the active region for template fields."
- (oref-default 'srecode-template-inserted-region active-region))
-
-(defun srecode-field-post-command ()
- "Srecode field handler in the post command hook."
- (let ((ar (srecode-active-template-region))
- )
- (if (not ar)
- ;; Find a bug and fix it.
- (remove-hook 'post-command-hook #'srecode-field-post-command t)
- (if (srecode-point-in-region-p ar)
- nil ;; Keep going
- ;; We moved out of the template. Cancel the edits.
- (srecode-delete ar)))
- ))
-
-;;; FIELDS
-
-(defclass srecode-field (srecode-overlaid)
- ((tail :documentation
- "Overlay used on character just after this field.
-Used to provide useful keybindings there.")
- (name :initarg :name
- :documentation
- "The name of this field.
-Usually initialized from the dictionary entry name that
-the users needs to edit.")
- (prompt :initarg :prompt
- :documentation
- "A prompt string to use if this were in the minibuffer.
-Display when the cursor enters this field.")
- (read-fcn :initarg :read-fcn
- :documentation
- "A function that would be used to read a string.
-Try to use this to provide useful completion when available.")
- )
- "Representation of one field.")
-
-(defvar srecode-field-keymap
- (let ((km (make-sparse-keymap)))
- (define-key km "\C-i" #'srecode-field-next)
- (define-key km "\M-\C-i" #'srecode-field-prev)
- (define-key km "\C-e" #'srecode-field-end)
- (define-key km "\C-a" #'srecode-field-start)
- (define-key km "\M-m" #'srecode-field-start)
- (define-key km "\C-c\C-c" #'srecode-field-exit-ask)
- km)
- "Keymap applied to field overlays.")
-
-(cl-defmethod initialize-instance ((field srecode-field) &optional _args)
- "Initialize FIELD, being sure it archived."
- (add-to-list 'srecode-field-archive field t)
- (cl-call-next-method)
- )
-
-(cl-defmethod srecode-overlaid-activate ((field srecode-field))
- "Activate the FIELD area."
- (cl-call-next-method)
-
- (let* ((ol (oref field overlay))
- (end nil)
- (tail nil))
- (overlay-put ol 'face 'srecode-field-face)
- (overlay-put ol 'keymap srecode-field-keymap)
- (overlay-put ol 'modification-hooks '(srecode-field-mod-hook))
- (overlay-put ol 'insert-behind-hooks '(srecode-field-behind-hook))
- (overlay-put ol 'insert-in-front-hooks '(srecode-field-mod-hook))
-
- (setq end (overlay-end ol))
- (setq tail (make-overlay end (+ end 1) (current-buffer)))
-
- (overlay-put tail 'srecode field)
- (overlay-put tail 'keymap srecode-field-keymap)
- (overlay-put tail 'face 'srecode-field-face)
- (oset field tail tail)
- )
- )
-
-(cl-defmethod srecode-delete ((olaid srecode-field))
- "Delete our secondary overlay."
- ;; Remove our spare overlay
- (delete-overlay (oref olaid tail))
- (slot-makeunbound olaid 'tail)
- ;; Do our baseclass work.
- (cl-call-next-method)
- )
-
-(defvar srecode-field-replication-max-size 100
- "Maximum size of a field before canceling replication.")
-
-(defun srecode-field-mod-hook (ol after _start _end &optional _pre-len)
- "Modification hook for the field overlay.
-OL is the overlay.
-AFTER is non-nil if it is called after the change.
-START and END are the bounds of the change.
-PRE-LEN is used in the after mode for the length of the changed text."
- (when (and after (not undo-in-progress))
- (let* ((field (overlay-get ol 'srecode))
- (inhibit-modification-hooks t))
- ;; Sometimes a field is deleted, but we might still get a stray
- ;; event. Let's just ignore those events.
- (when (slot-boundp field 'overlay)
- ;; First, fixup the two overlays, in case they got confused.
- (let ((main (oref field overlay))
- (tail (oref field tail)))
- (move-overlay main
- (overlay-start main)
- (1- (overlay-end tail)))
- (move-overlay tail
- (1- (overlay-end tail))
- (overlay-end tail)))
- ;; Now capture text from the main overlay, and propagate it.
- (let* ((new-text (srecode-overlaid-text field))
- (region (srecode-active-template-region))
- (allfields (when region (oref region fields)))
- (name (oref field name)))
- (dolist (F allfields)
- (when (and (not (eq F field))
- (string= name (oref F name)))
- (if (> (length new-text) srecode-field-replication-max-size)
- (message "Field size too large for replication.")
- ;; If we find other fields with the same name, then keep
- ;; then all together. Disable change hooks to make sure
- ;; we don't get a recursive edit.
- (srecode-overlaid-text F new-text)
- ))))
- ))))
-
-(defun srecode-field-behind-hook (ol after start end &optional pre-len)
- "Modification hook for the field overlay.
-OL is the overlay.
-AFTER is non-nil if it is called after the change.
-START and END are the bounds of the change.
-PRE-LEN is used in the after mode for the length of the changed text."
- (when after
- (let* (;; (field (overlay-get ol 'srecode))
- )
- (move-overlay ol (overlay-start ol) end)
- (srecode-field-mod-hook ol after start end pre-len))
- ))
-
-(cl-defmethod srecode-field-goto ((field srecode-field))
- "Goto the FIELD."
- (goto-char (overlay-start (oref field overlay))))
-
-(defun srecode-field-next ()
- "Move to the next field."
- (interactive)
- (let* ((f (srecode-overlaid-at-point 'srecode-field))
- (tr (srecode-overlaid-at-point 'srecode-template-inserted-region))
- )
- (when (not f) (error "Not in a field"))
- (when (not tr) (error "Not in a template region"))
-
- (let ((fields (oref tr fields)))
- (while fields
- ;; Loop over fields till we match. Then move to the next one.
- (when (eq f (car fields))
- (if (cdr fields)
- (srecode-field-goto (car (cdr fields)))
- (srecode-field-goto (car (oref tr fields))))
- (setq fields nil)
- )
- (setq fields (cdr fields))))
- ))
-
-(defun srecode-field-prev ()
- "Move to the prev field."
- (interactive)
- (let* ((f (srecode-overlaid-at-point 'srecode-field))
- (tr (srecode-overlaid-at-point 'srecode-template-inserted-region))
- )
- (when (not f) (error "Not in a field"))
- (when (not tr) (error "Not in a template region"))
-
- (let ((fields (reverse (oref tr fields))))
- (while fields
- ;; Loop over fields till we match. Then move to the next one.
- (when (eq f (car fields))
- (if (cdr fields)
- (srecode-field-goto (car (cdr fields)))
- (srecode-field-goto (car (oref tr fields))))
- (setq fields nil)
- )
- (setq fields (cdr fields))))
- ))
-
-(defun srecode-field-end ()
- "Move to the end of this field."
- (interactive)
- (let* ((f (srecode-overlaid-at-point 'srecode-field)))
- (goto-char (overlay-end (oref f overlay)))))
-
-(defun srecode-field-start ()
- "Move to the end of this field."
- (interactive)
- (let* ((f (srecode-overlaid-at-point 'srecode-field)))
- (goto-char (overlay-start (oref f overlay)))))
-
-(defun srecode-field-exit-ask ()
- "Ask if the user wants to exit field-editing mini-mode."
- (interactive)
- (when (or (not srecode-fields-exit-confirmation)
- (y-or-n-p "Exit field-editing mode? "))
- (srecode-delete (srecode-active-template-region))))
-
-
-(provide 'srecode/fields)
-
-;; Local variables:
-;; generated-autoload-load-name: "srecode/fields"
-;; End:
-
-;;; srecode/fields.el ends here
+++ /dev/null
-;;; srecode/filters.el --- Filters for use in template variables. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Various useful srecoder template functions.
-
-;;; Code:
-
-(require 'newcomment)
-
-(declare-function srecode-dictionary-lookup-name "srecode/dictionary")
-(defvar srecode-inserter-variable-current-dictionary)
-
-(defun srecode-comment-prefix (str)
- "Prefix each line of STR with the comment prefix characters."
- (let* ((dict srecode-inserter-variable-current-dictionary)
- ;; Derive the comment characters to put in front of each line.
- (cs (or (and dict
- (srecode-dictionary-lookup-name dict "comment_prefix"))
- (and comment-multi-line comment-continue)
- (and (not comment-multi-line) comment-start)))
- (strs (split-string str "\n"))
- (newstr "")
- )
- (while strs
- (cond ((and (not comment-multi-line) (string= (car strs) ""))
- ; (setq newstr (concat newstr "\n")))
- )
- (t
- (setq newstr (concat newstr cs " " (car strs)))))
- (setq strs (cdr strs))
- (when strs (setq newstr (concat newstr "\n"))))
- newstr))
-
-(provide 'srecode/filters)
-
-;;; srecode/filters.el ends here
+++ /dev/null
-;;;; srecode/find.el --- Tools for finding templates in the database. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Various routines that search through various template tables
-;; in search of the right template.
-
-(require 'srecode/ctxt)
-(require 'srecode/table)
-(require 'srecode/map)
-(require 'srecode/compile)
-
-;;; Code:
-
-(defun srecode-table (&optional mode)
- "Return the currently active Semantic Recoder table for this buffer.
-Optional argument MODE specifies the mode table to use."
- (let ((modes (derived-mode-all-parents (or mode major-mode)))
- (table nil))
-
- ;; If there isn't one, keep searching backwards for a table.
- (while (and modes (not (setq table (srecode-get-mode-table (car modes)))))
- (setq modes (cdr modes)))
-
- ;; Last ditch effort.
- (when (not table)
- (setq table (srecode-get-mode-table 'default)))
-
- table))
-
-;;; TRACKER
-;;
-;; Template file tracker for between sessions.
-;;
-(defun srecode-load-tables-for-mode (mmode &optional appname)
- "Load all the template files for MMODE.
-Templates are found in the SRecode Template Map.
-See `srecode-get-maps' for more.
-APPNAME is the name of an application. In this case,
-all template files for that application will be loaded."
- (dolist (mmode (cons 'default (reverse (derived-mode-all-parents mmode))))
- (let ((files
- (apply #'append
- (mapcar
- (if appname
- (lambda (map)
- (srecode-map-entries-for-app-and-mode map appname mmode))
- (lambda (map)
- (srecode-map-entries-for-mode map mmode)))
- (srecode-get-maps)))))
-
- ;; Load in templates for our major mode.
- (when files
- (let ((mt (srecode-get-mode-table mmode)))
- (dolist (f files)
- (when (not (and mt (srecode-mode-table-find mt (car f))))
- (srecode-compile-file (car f)))))))))
-
-;;; PROJECT
-;;
-;; Find if a template table has a project set, and if so, is the
-;; current buffer in that project.
-(cl-defmethod srecode-template-table-in-project-p ((tab srecode-template-table))
- "Return non-nil if the table TAB can be used in the current project.
-If TAB has a :project set, check that the directories match.
-If TAB is nil, then always return t."
- (let ((proj (oref tab project)))
- ;; Return t if the project wasn't set.
- (if (not proj) t
- ;; If the project directory was set, let's check it.
- (let ((dd (expand-file-name default-directory))
- (projexp (regexp-quote (directory-file-name proj))))
- (if (string-match (concat "^" projexp) dd)
- t nil)))))
-
-;;; SEARCH
-;;
-;; Find a given template based on name, and features of the current
-;; buffer.
-(cl-defmethod srecode-template-get-table ((tab srecode-template-table)
- template-name &optional
- context _application)
- "Find in the template in table TAB, the template with TEMPLATE-NAME.
-Optional argument CONTEXT specifies that the template should part
-of a particular context.
-The APPLICATION argument is unused."
- (when (srecode-template-table-in-project-p tab)
- (if context
- ;; If a context is specified, then look it up there.
- (let ((ctxth (gethash context (oref tab contexthash))))
- (when ctxth
- (gethash template-name ctxth)))
- ;; No context, perhaps a merged name?
- (gethash template-name (oref tab namehash)))))
-
-(cl-defmethod srecode-template-get-table ((tab srecode-mode-table)
- template-name &optional
- context application)
- "Find in the template in mode table TAB, the template with TEMPLATE-NAME.
-Optional argument CONTEXT specifies a context a particular template
-would belong to.
-Optional argument APPLICATION restricts searches to only template tables
-belonging to a specific application. If APPLICATION is nil, then only
-tables that do not belong to an application will be searched."
- (let* ((mt tab)
- (tabs (oref mt tables))
- (ans nil))
- (while (and (not ans) tabs)
- (let ((app (oref (car tabs) application)))
- (when (or (and (not application) (null app))
- (and application (eq app application)))
- (setq ans (srecode-template-get-table (car tabs) template-name
- context)))
- (setq tabs (cdr tabs))))
- (or ans
- ;; Recurse to the default.
- (when (not (equal (oref tab major-mode) 'default))
- (srecode-template-get-table (srecode-get-mode-table 'default)
- template-name context application)))))
-
-;;
-;; Find a given template based on a key binding.
-;;
-(cl-defmethod srecode-template-get-table-for-binding
- ((tab srecode-template-table) binding &optional context)
- "Find in the template name in table TAB, the template with BINDING.
-Optional argument CONTEXT specifies that the template should part
-of a particular context."
- (when (srecode-template-table-in-project-p tab)
- (let* ((keyout nil)
- (hashfcn (lambda (key value)
- (when (and (slot-boundp value 'binding)
- (oref value binding)
- (= (aref (oref value binding) 0) binding))
- (setq keyout key))))
- (contextstr (cond ((listp context)
- (car-safe context))
- ((stringp context)
- context)
- (t nil)))
- )
- (if context
- (let ((ctxth (gethash contextstr (oref tab contexthash))))
- (when ctxth
- ;; If a context is specified, then look it up there.
- (maphash hashfcn ctxth)
- ;; Context hashes EXCLUDE the context prefix which
- ;; we need to include, so concat it here
- (when keyout
- (setq keyout (concat contextstr ":" keyout)))
- )))
- (when (not keyout)
- ;; No context, or binding in context. Try full hash.
- (maphash hashfcn (oref tab namehash)))
- keyout)))
-
-(cl-defmethod srecode-template-get-table-for-binding
- ((tab srecode-mode-table) binding &optional context application)
- "Find in the template name in mode table TAB, the template with BINDING.
-Optional argument CONTEXT specifies a context a particular template
-would belong to.
-Optional argument APPLICATION restricts searches to only template tables
-belonging to a specific application. If APPLICATION is nil, then only
-tables that do not belong to an application will be searched."
- (let* ((mt tab)
- (tabs (oref mt tables))
- (ans nil))
- (while (and (not ans) tabs)
- (let ((app (oref (car tabs) application)))
- (when (or (and (not application) (null app))
- (and application (eq app application)))
- (setq ans (srecode-template-get-table-for-binding
- (car tabs) binding context)))
- (setq tabs (cdr tabs))))
- (or ans
- ;; Recurse to the default.
- (when (not (equal (oref tab major-mode) 'default))
- (srecode-template-get-table-for-binding
- (srecode-get-mode-table 'default) binding context)))))
-;;; Interactive
-;;
-;; Interactive queries into the template data.
-;;
-(defvar srecode-read-template-name-history nil
- "History for completing reads for template names.")
-
-(defun srecode-user-template-p (_template)
- "Non-nil if TEMPLATE is intended for user insertion.
-Templates not matching this predicate are used for code
-generation or other internal purposes."
- t)
-
-(defun srecode-all-template-hash (&optional mode hash predicate)
- "Create a hash table of all the currently available templates.
-Optional argument MODE is the major mode to look for.
-Optional argument HASH is the hash table to fill in.
-Optional argument PREDICATE can be used to filter the returned
-templates."
- (let* ((mhash (or hash (make-hash-table :test 'equal))))
- (dolist (mmode (cons 'default
- ;; Get the parent hash table filled into our
- ;; current hash.
- (reverse (derived-mode-all-parents
- (or mode major-mode)))))
-
- ;; Load up the hash table for our current mode.
- (let* ((mt (srecode-get-mode-table mmode))
- (tabs (when mt (oref mt tables))))
- (dolist (tab tabs)
- ;; Exclude templates for a particular application.
- (when (and (not (oref tab application))
- (srecode-template-table-in-project-p tab))
- (maphash (lambda (key temp)
- (when (or (not predicate)
- (funcall predicate temp))
- (puthash key temp mhash)))
- (oref tab namehash))))))
- mhash))
-
-(defun srecode-calculate-default-template-string (hash)
- "Calculate the name of the template to use as a DEFAULT.
-Templates are read from HASH.
-Context into which the template is inserted is calculated
-with `srecode-calculate-context'."
- (let* ((ctxt (srecode-calculate-context))
- (ans (concat (nth 0 ctxt) ":" (nth 1 ctxt))))
- (if (gethash ans hash)
- ans
- ;; No hash at the specifics, at least offer
- ;; the prefix for the completing read
- (concat (nth 0 ctxt) ":"))))
-
-(defun srecode-read-template-name (prompt &optional initial hist _default)
- "Completing read for Semantic Recoder template names.
-PROMPT is used to query for the name of the template desired.
-INITIAL is the initial string to use.
-HIST is a history variable to use.
-DEFAULT is what to use if the user presses RET."
- (srecode-load-tables-for-mode major-mode)
- (let* ((hash (srecode-all-template-hash))
- (def (or initial
- (srecode-calculate-default-template-string hash))))
- (completing-read prompt hash
- nil t def
- (or hist
- 'srecode-read-template-name-history))))
-
-(provide 'srecode/find)
-
-;;; srecode/find.el ends here
+++ /dev/null
-;;; srecode/getset.el --- Package for inserting new get/set methods. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; SRecoder application for inserting new get/set methods into a class.
-
-(require 'semantic)
-(require 'semantic/analyze)
-(require 'semantic/find)
-(require 'srecode/insert)
-(require 'srecode/dictionary)
-
-;;; Code:
-(defvar srecode-insert-getset-fully-automatic-flag nil
- "Non-nil means accept choices srecode comes up with without asking.")
-
-(defvar srecode-semantic-selected-tag)
-
-;;;###autoload
-(defun srecode-insert-getset (&optional class-in field-in)
- "Insert get/set methods for the current class.
-CLASS-IN is the semantic tag of the class to update.
-FIELD-IN is the semantic tag, or string name, of the field to add.
-If you do not specify CLASS-IN or FIELD-IN then a class and field
-will be derived."
- (interactive)
-
- (srecode-load-tables-for-mode major-mode)
- (srecode-load-tables-for-mode major-mode 'getset)
-
- (if (not (srecode-table))
- (error "No template table found for mode %s" major-mode))
-
- (if (not (srecode-template-get-table (srecode-table)
- "getset-in-class"
- "declaration"
- 'getset))
- (error "No templates for inserting get/set"))
-
- ;; Step 1: Try to derive the tag for the class we will use
- (semantic-fetch-tags)
- (let* ((class (or class-in (srecode-auto-choose-class (point))))
- (tagstart (when class (semantic-tag-start class)))
- (inclass (eq (semantic-current-tag-of-class 'type) class))
- (field nil)
- )
-
- (when (not class)
- (error "Move point to a class and try again"))
-
- ;; Step 2: Select a name for the field we will use.
- (when field-in
- (setq field field-in))
-
- (when (and inclass (not field))
- (setq field (srecode-auto-choose-field (point))))
-
- (when (not field)
- (setq field (srecode-query-for-field class)))
-
- ;; Step 3: Insert a new field if needed
- (when (stringp field)
-
- (goto-char (point))
- (srecode-position-new-field class inclass)
-
- (let* ((dict (srecode-create-dictionary))
- (temp (srecode-template-get-table (srecode-table)
- "getset-field"
- "declaration"
- 'getset))
- )
- (when (not temp)
- (error "Getset templates for %s not loaded!" major-mode))
- (srecode-resolve-arguments temp dict)
- (srecode-dictionary-set-value dict "NAME" field)
- (when srecode-insert-getset-fully-automatic-flag
- (srecode-dictionary-set-value dict "TYPE" "int"))
- (srecode-insert-fcn temp dict)
-
- (semantic-fetch-tags)
- (save-excursion
- (goto-char tagstart)
- ;; Refresh our class tag.
- (setq class (srecode-auto-choose-class (point)))
- )
-
- (let ((tmptag (semantic-deep-find-tags-by-name-regexp
- field (current-buffer))))
- (setq tmptag (semantic-find-tags-by-class 'variable tmptag))
-
- (if tmptag
- (setq field (car tmptag))
- (error "Could not find new field %s" field)))
- )
-
- ;; Step 3.5: Insert an initializer if needed.
- ;; ...
-
-
- ;; Set up for the rest.
- )
-
- (if (not (semantic-tag-p field))
- (error "Must specify field for get/set. (parts may not be impl'd yet.)"))
-
- ;; Set 4: Position for insertion of methods
- (srecode-position-new-methods class field)
-
- ;; Step 5: Insert the get/set methods
- (if (not (eq (semantic-current-tag) class))
- ;; We are positioned on top of something else.
- ;; insert a /n
- (insert "\n"))
-
- (let* ((dict (srecode-create-dictionary))
- (srecode-semantic-selected-tag field)
- (temp (srecode-template-get-table (srecode-table)
- "getset-in-class"
- "declaration"
- 'getset))
- )
- (if (not temp)
- (error "Getset templates for %s not loaded!" major-mode))
- (srecode-resolve-arguments temp dict)
- (srecode-dictionary-set-value dict "GROUPNAME"
- (concat (semantic-tag-name field)
- " Accessors"))
- (srecode-dictionary-set-value dict "NICENAME"
- (srecode-strip-fieldname
- (semantic-tag-name field)))
- (srecode-insert-fcn temp dict)
- )))
-
-(defun srecode-strip-fieldname (name)
- "Strip the fieldname NAME of polish notation things."
- (cond ((string-match "[a-z]\\([A-Z]\\w+\\)" name)
- (substring name (match-beginning 1)))
- ;; Add more rules here.
- (t
- name)))
-
-(defun srecode-position-new-methods (class field)
- "Position the cursor in CLASS where new getset methods should go.
-FIELD is the field for the get sets.
-INCLASS specifies if the cursor is already in CLASS or not."
- (semantic-go-to-tag field)
-
- (let ((prev (semantic-find-tag-by-overlay-prev))
- (next (semantic-find-tag-by-overlay-next))
- (setname nil)
- (aftertag nil)
- )
- (cond
- ((and prev (semantic-tag-of-class-p prev 'variable))
- (setq setname
- (concat "set"
- (srecode-strip-fieldname (semantic-tag-name prev))))
- )
- ((and next (semantic-tag-of-class-p next 'variable))
- (setq setname
- (concat "set"
- (srecode-strip-fieldname (semantic-tag-name prev)))))
- (t nil))
-
- (setq aftertag (semantic-find-first-tag-by-name
- setname (semantic-tag-type-members class)))
-
- (when (not aftertag)
- (setq aftertag (car-safe
- (semantic--find-tags-by-macro
- (semantic-tag-get-attribute (car tags) :destructor-flag)
- (semantic-tag-type-members class))))
- ;; Make sure the tag is public
- (when (not (eq (semantic-tag-protection aftertag class) 'public))
- (setq aftertag nil))
- )
-
- (if (not aftertag)
- (setq aftertag (car-safe
- (semantic--find-tags-by-macro
- (semantic-tag-get-attribute (car tags) :constructor-flag)
- (semantic-tag-type-members class))))
- ;; Make sure the tag is public
- (when (not (eq (semantic-tag-protection aftertag class) 'public))
- (setq aftertag nil))
- )
-
- (when (not aftertag)
- (setq aftertag (semantic-find-first-tag-by-name
- "public" (semantic-tag-type-members class))))
-
- (when (not aftertag)
- (setq aftertag (car (semantic-tag-type-members class))))
-
- (if aftertag
- (let ((te (semantic-tag-end aftertag)))
- (when (not te)
- (message "Unknown location for tag-end in %s:" (semantic-tag-name aftertag)))
- (goto-char te)
- ;; If there is a comment immediately after aftertag, skip over it.
- (when (looking-at (concat "\\s-*\n?\\s-*" semantic-lex-comment-regex))
- (let ((pos (point))
- (rnext (semantic-find-tag-by-overlay-next (point))))
- (forward-comment 1)
- ;; Make sure the comment we skipped didn't say anything about
- ;; the rnext tag.
- (when (and rnext
- (re-search-backward
- (regexp-quote (semantic-tag-name rnext)) pos t))
- ;; It did mention rnext, so go back to our starting position.
- (goto-char pos)
- )
- ))
- )
-
- ;; At the very beginning of the class.
- (goto-char (semantic-tag-end class))
- (forward-sexp -1)
- (forward-char 1)
-
- )
-
- (end-of-line)
- (forward-char 1)
- ))
-
-(defun srecode-position-new-field (class inclass)
- "Select a position for a new field for CLASS.
-If INCLASS is non-nil, then the cursor is already in the class
-and should not be moved during point selection."
-
- ;; If we aren't in the class, get the cursor there, pronto!
- (when (not inclass)
-
- (error "You must position the cursor where to insert the new field")
-
- (let ((kids (semantic-find-tags-by-class
- 'variable (semantic-tag-type-members class))))
- (cond (kids
- (semantic-go-to-tag (car kids) class))
- (t
- (semantic-go-to-tag class)))
- )
-
- (switch-to-buffer (current-buffer))
-
- ;; Once the cursor is in our class, ask the user to position
- ;; the cursor to keep going.
- )
-
- (if (or srecode-insert-getset-fully-automatic-flag
- (y-or-n-p "Insert new field here? "))
- nil
- (error "You must position the cursor where to insert the new field first"))
- )
-
-
-
-(defun srecode-auto-choose-field (point)
- "Choose a field for the get/set methods.
-Base selection on the field related to POINT."
- (save-excursion
- (when point
- (goto-char point))
-
- (let ((field (semantic-current-tag-of-class 'variable)))
-
- ;; If we get a field, make sure the user gets a chance to choose.
- (when field
- (if srecode-insert-getset-fully-automatic-flag
- nil
- (when (not (y-or-n-p
- (format "Use field %s? " (semantic-tag-name field))))
- (setq field nil))
- ))
- field)))
-
-(defun srecode-query-for-field (class)
- "Query for a field in CLASS."
- (let* ((kids (semantic-find-tags-by-class
- 'variable (semantic-tag-type-members class)))
- (sel (completing-read "Use Field: " kids))
- (fields (semantic-find-tags-by-name sel kids)))
- (if fields
- (car fields)
- sel)
- ))
-
-(defun srecode-auto-choose-class (point)
- "Choose a class based on location of POINT."
- (save-excursion
- (when point
- (goto-char point))
-
- (let ((tag (semantic-current-tag-of-class 'type)))
-
- (when (or (not tag)
- (not (string= (semantic-tag-type tag) "class")))
- ;; The current tag is not a class. Are we in a fcn
- ;; that is a method?
- (setq tag (semantic-current-tag-of-class 'function))
-
- (when (and tag
- (semantic-tag-function-parent tag))
- (let ((p (semantic-tag-function-parent tag)))
- ;; @TODO : Copied below out of semantic-analyze
- ;; Turn into a routine.
-
- (let* ((searchname (cond ((stringp p) p)
- ((semantic-tag-p p)
- (semantic-tag-name p))
- ((and (listp p) (stringp (car p)))
- (car p))))
- (ptag (semantic-analyze-find-tag searchname
- 'type nil)))
- (when ptag (setq tag ptag ))
- ))))
-
- (when (or (not tag)
- (not (semantic-tag-of-class-p tag 'type))
- (not (string= (semantic-tag-type tag) "class")))
- ;; We are not in a class that needs a get/set method.
- ;; Analyze the current context, and derive a class name.
- (let* ((ctxt (semantic-analyze-current-context))
- (pfix nil)
- (ans nil))
- (when ctxt
- (setq pfix (reverse (oref ctxt prefix)))
- (while (and (not ans) pfix)
- ;; Start at the end and back up to the first class.
- (when (and (semantic-tag-p (car pfix))
- (semantic-tag-of-class-p (car pfix) 'type)
- (string= (semantic-tag-type (car pfix))
- "class"))
- (setq ans (car pfix)))
- (setq pfix (cdr pfix))))
- (setq tag ans)))
-
- tag)))
-
-(provide 'srecode/getset)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/getset"
-;; End:
-
-;;; srecode/getset.el ends here
+++ /dev/null
-;;; srecode/insert.el --- Insert srecode templates to an output stream -*- lexical-binding:t -*-
-
-;; Copyright (C) 2005, 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Define and implements specific inserter objects.
-;;
-;; Manage the insertion process for a template.
-;;
-
-(require 'srecode/compile)
-(require 'srecode/find)
-(require 'srecode/dictionary)
-(require 'srecode/args)
-(require 'srecode/filters)
-
-(declare-function srecode-overlaid-activate "srecode/fields")
-(declare-function srecode-template-inserted-region "srecode/fields")
-
-;;; Code:
-
-(defcustom srecode-insert-ask-variable-method 'ask
- "Determine how to ask for a dictionary value when inserting a template.
-Only the ASK style inserter will query the user for a value.
-Dictionary value references that ask begin with the ? character.
-Possible values are:
- `ask' - Prompt in the minibuffer as the value is inserted.
- `field' - Use the dictionary macro name as the inserted value,
- and place a field there. Matched fields change together."
- :group 'srecode
- :type '(choice (const :tag "Ask" ask)
- (const :tag "Field" field)))
-
-(defvar srecode-insert-with-fields-in-progress nil
- "Non-nil means that we are actively inserting a template with fields.")
-
-;;; INSERTION COMMANDS
-;;
-;; User level commands for inserting stuff.
-(defvar srecode-insertion-start-context nil
- "The context that was at point at the beginning of the template insertion.")
-
-(defun srecode-insert-again ()
- "Insert the previously inserted template (by name) again."
- (interactive)
- (let ((prev (car srecode-read-template-name-history)))
- (if prev
- (srecode-insert prev)
- (call-interactively 'srecode-insert))))
-
-;;;###autoload
-(defun srecode-insert (template-name &rest dict-entries)
- "Insert the template TEMPLATE-NAME into the current buffer at point.
-DICT-ENTRIES are additional dictionary values to add."
- (interactive (list (srecode-read-template-name "Template Name: ")))
- (if (not (srecode-table))
- (error "No template table found for mode %s" major-mode))
- (let ((newdict (srecode-create-dictionary))
- (temp (srecode-template-get-table (srecode-table) template-name))
- (srecode-insertion-start-context (srecode-calculate-context))
- )
- (if (not temp)
- (error "No Template named %s" template-name))
- (while dict-entries
- (srecode-dictionary-set-value newdict
- (car dict-entries)
- (car (cdr dict-entries)))
- (setq dict-entries (cdr (cdr dict-entries))))
- (srecode-insert-fcn temp newdict)
- ;; Don't put code here. We need to return the end-mark
- ;; for this insertion step.
- ))
-
-(eieio-declare-slots (point :allocation :class))
-
-(defun srecode-insert-fcn (template dictionary &optional stream skipresolver)
- "Insert TEMPLATE using DICTIONARY into STREAM.
-Optional SKIPRESOLVER means to avoid refreshing the tag list,
-or resolving any template arguments. It is assumed the caller
-has set everything up already."
- ;; Perform the insertion.
- (let ((standard-output (or stream (current-buffer)))
- (end-mark nil))
- ;; Merge any template entries into the input dictionary.
- (when (slot-boundp template 'dictionary)
- (srecode-dictionary-merge dictionary (oref template dictionary)))
-
- (unless skipresolver
- ;; Make sure the semantic tags are up to date.
- (semantic-fetch-tags)
- ;; Resolve the arguments
- (srecode-resolve-arguments template dictionary))
- ;; Insert
- (if (bufferp standard-output)
- ;; If there is a buffer, turn off various hooks. This will cause
- ;; the mod hooks to be buffered up during the insert, but
- ;; prevent tools like font-lock from fontifying mid-template.
- ;; Especially important during insertion of complex comments that
- ;; cause the new font-lock to comment-color stuff after the inserted
- ;; comment.
- ;;
- ;; I'm not sure about the motion hooks. It seems like a good
- ;; idea though.
- ;;
- ;; Borrowed these concepts out of font-lock.
- ;;
- ;; I tried `combine-after-change-calls', but it did not have
- ;; the effect I wanted.
- (let ((start (point)))
- (let ((inhibit-modification-hooks t))
- (srecode--insert-into-buffer template dictionary)
- )
- ;; Now call those after change functions.
- (run-hook-with-args 'after-change-functions
- start (point) 0)
- )
- (srecode-insert-method template dictionary))
- ;; Handle specialization of the POINT inserter.
- (when (bufferp standard-output)
- (let ((point (oref-default 'srecode-template-inserter-point point)))
- (when point
- (set-buffer standard-output)
- (setq end-mark (point-marker))
- (goto-char point))))
- (oset-default 'srecode-template-inserter-point point nil)
-
- ;; Return the end-mark.
- (or end-mark (point)))
- )
-
-(defun srecode--insert-into-buffer (template dictionary)
- "Insert a TEMPLATE with DICTIONARY into a buffer.
-Do not call this function yourself. Instead use:
- `srecode-insert' - Inserts by name.
- `srecode-insert-fcn' - Insert with objects.
-This function handles the case from one of the above functions when
-the template is inserted into a buffer. It looks
-at `srecode-insert-ask-variable-method' to decide if unbound dictionary
-entries ask questions or insert editable fields.
-
-Buffer based features related to change hooks is handled one level up."
- ;; This line prevents the field archive from being let bound
- ;; while the field insert tool is loaded via autoloads during
- ;; the insert.
- (when (eq srecode-insert-ask-variable-method 'field)
- (require 'srecode/fields))
-
- (let ((srecode-field-archive nil) ; Prevent field leaks during insert
- (start (point)) ; Beginning of the region.
- )
- ;; This sub-let scopes the 'in-progress' piece so we know
- ;; when to setup the end-template.
- (let ((srecode-insert-with-fields-in-progress
- (if (eq srecode-insert-ask-variable-method 'field) t nil))
- )
- (srecode-insert-method template dictionary)
- )
- ;; If we are not in-progress, and we insert fields, then
- ;; create the end-template with fields editable area.
- (when (and (not srecode-insert-with-fields-in-progress)
- (eq srecode-insert-ask-variable-method 'field) ; Only if user asked
- srecode-field-archive ; Only if there were fields created
- )
- (let ((reg
- ;; Create the field-driven editable area.
- (srecode-template-inserted-region :start start :end (point))))
- (srecode-overlaid-activate reg))
- )
- ;; We return with 'point being the end of the template insertion
- ;; area. Return value is not important.
- ))
-
-(declare-function data-debug-new-buffer "data-debug" (name))
-(declare-function data-debug-insert-stuff-list "data-debug" (stufflist prefix))
-(declare-function data-debug-insert-thing "data-debug"
- (thing prefix prebuttontext &optional parent))
-
-(defun srecode-insert-show-error-report (dictionary format &rest args)
- "Display an error report based on DICTIONARY, FORMAT and ARGS.
-This is intended to diagnose problems with failed template
-insertions."
- (with-current-buffer (data-debug-new-buffer "*SRECODE INSERTION ERROR*")
- (erase-buffer)
- ;; Insert the stack of templates that are currently being
- ;; inserted.
- (insert (propertize "Template Stack" 'face '(:weight bold))
- (propertize " (most recent at bottom)" 'face '(:slant italic))
- ":\n")
- (data-debug-insert-stuff-list
- (reverse (oref-default 'srecode-template active)) "> ")
- ;; Show the current dictionary.
- (insert (propertize "Dictionary" 'face '(:weight bold)) "\n")
- (data-debug-insert-thing dictionary "" "> ")
- ;; Show the error message.
- (insert (propertize "Error" 'face '(:weight bold)) "\n")
- (insert (apply #'format-message format args))
- (pop-to-buffer (current-buffer))))
-
-(defun srecode-insert-report-error (dictionary format &rest args)
- ;; TODO only display something when inside an interactive call?
- (srecode-insert-show-error-report dictionary format args)
- (apply #'error format args))
-
-;;; TEMPLATE ARGUMENTS
-;;
-;; Some templates have arguments. Each argument is associated with
-;; a function that can resolve the inputs needed.
-(defun srecode-resolve-arguments (temp dict)
- "Resolve all the arguments needed by the template TEMP.
-Apply anything learned to the dictionary DICT."
- (srecode-resolve-argument-list (oref temp args) dict temp))
-
-(defun srecode-resolve-argument-list (args dict &optional temp)
- "Resolve arguments in the argument list ARGS.
-ARGS is a list of symbols, such as :blank, or :file.
-Apply values to DICT.
-Optional argument TEMP is the template that is getting its arguments resolved."
- (let ((fcn nil))
- (while args
- (setq fcn (intern-soft (concat "srecode-semantic-handle-"
- (symbol-name (car args)))))
- (if (not fcn)
- (error "Error resolving template argument %S" (car args)))
- (if temp
- (condition-case nil
- ;; Allow some to accept a 2nd argument optionally.
- ;; They throw an error if not available, so try again.
- (funcall fcn dict temp)
- (wrong-number-of-arguments (funcall fcn dict)))
- (funcall fcn dict))
- (setq args (cdr args)))
- ))
-
-;;; INSERTION STACK & METHOD
-;;
-;; Code managing the top-level insert method and the current
-;; insertion stack.
-;;
-(cl-defmethod srecode-push ((st srecode-template))
- "Push the srecoder template ST onto the active stack."
- (oset st active (cons st (oref st active))))
-
-(cl-defmethod srecode-pop ((st srecode-template))
- "Pop the srecoder template ST onto the active stack."
- (oset st active (cdr (oref st active))))
-
-(cl-defmethod srecode-peek ((st srecode-template))
- "Fetch the topmost active template record."
- (car (oref st active)))
-
-(cl-defmethod srecode-insert-method ((st srecode-template) dictionary)
- "Insert the srecoder template ST."
- ;; Merge any template entries into the input dictionary.
- ;; This may happen twice since some templates arguments need
- ;; these dictionary values earlier, but these values always
- ;; need merging for template inserting in other templates.
- (when (slot-boundp st 'dictionary)
- (srecode-dictionary-merge dictionary (oref st dictionary)))
- ;; Do an insertion.
- (unwind-protect
- (let ((c (oref st code)))
- (srecode-push st)
- (srecode-insert-code-stream c dictionary))
- ;; Popping the stack is protected.
- (srecode-pop st)))
-
-(defun srecode-insert-code-stream (code dictionary)
- "Insert the CODE from a template into `standard-output'.
-Use DICTIONARY to resolve any macros."
- (while code
- (cond ((stringp (car code))
- (princ (car code)))
- (t
- (srecode-insert-method (car code) dictionary)))
- (setq code (cdr code))))
-
-;;; INSERTERS
-;;
-;; Specific srecode inserters.
-;; The base class is from srecode-compile.
-;;
-;; Each inserter handles various macro codes from the template.
-;; The `code' slot specifies a character used to identify which
-;; inserter is to be created.
-;;
-(defclass srecode-template-inserter-newline (srecode-template-inserter)
- ((key :initform "\n"
- :allocation :class
- :documentation
- "The character code used to identify inserters of this style.")
- (hard :initform nil
- :initarg :hard
- :documentation
- "Is this a hard newline (always inserted) or optional?
-Optional newlines don't insert themselves if they are on a blank line
-by themselves.")
- )
- "Insert a newline, and possibly do indenting.
-Specify the :indent argument to enable automatic indentation when newlines
-occur in your template.")
-
-(cl-defmethod srecord-compile-inserter-newline-p
- ((_ srecode-template-inserter-newline))
- t)
-
-(cl-defmethod srecode-insert-method ((sti srecode-template-inserter-newline)
- dictionary)
- "Insert the STI inserter."
- ;; To be safe, indent the previous line since the template will
- ;; change what is there to indent
- (let ((i (srecode-dictionary-lookup-name dictionary "INDENT"))
- (inbuff (bufferp standard-output))
- (doit t)
- (pm (point-marker)))
- (when (and inbuff (not (oref sti hard)))
- ;; If this is not a hard newline, we need do the calculation
- ;; and set "doit" to nil.
- (beginning-of-line)
- (save-restriction
- (narrow-to-region (point) pm)
- (when (looking-at "\\s-*$")
- (setq doit nil)))
- (goto-char pm)
- )
- ;; Do indentation regardless of the newline.
- (when (and (eq i t) inbuff)
- (indent-according-to-mode)
- (goto-char pm))
-
- (when doit
- (princ "\n")
- ;; Indent after the newline, particularly for numeric indents.
- (cond ((and (eq i t) (bufferp standard-output))
- ;; WARNING - indent according to mode requires that standard-output
- ;; is a buffer!
- ;; @todo - how to indent in a string???
- (setq pm (point-marker))
- (indent-according-to-mode)
- (goto-char pm))
- ((numberp i)
- (princ (make-string i " ")))
- ((stringp i)
- (princ i))))))
-
-(cl-defmethod srecode-dump ((ins srecode-template-inserter-newline) _indent)
- "Dump the state of the SRecode template inserter INS."
- (cl-call-next-method)
- (when (oref ins hard)
- (princ " : hard")
- ))
-
-(defclass srecode-template-inserter-blank (srecode-template-inserter)
- ((key :initform "\r"
- :allocation :class
- :documentation
- "The character representing this inserter style.
-Can't be blank, or it might be used by regular variable insertion.")
- (where :initform 'begin
- :initarg :where
- :documentation
- "This should be `begin' or `end', indicating where to insert a CR.
-When `begin', insert a CR if not at `bol'.
-When `end', insert a CR if not at `eol'.")
- ;; @TODO - Add slot and control for the number of blank
- ;; lines before and after point.
- )
- "Insert a newline before and after a template, and possibly do indenting.
-Specify the :blank argument to enable this inserter.")
-
-(cl-defmethod srecode-insert-method ((sti srecode-template-inserter-blank)
- dictionary)
- "Make sure there is no text before or after point."
- (let ((i (srecode-dictionary-lookup-name dictionary "INDENT"))
- (inbuff (bufferp standard-output))
- (pm (point-marker)))
- (when (and inbuff
- ;; Don't do this if we are not the active template.
- (= (length (oref-default 'srecode-template active)) 1))
-
- (when (and (eq i t) inbuff (not (eq (oref sti where) 'begin)))
- (indent-according-to-mode)
- (goto-char pm))
-
- (cond ((and (eq (oref sti where) 'begin) (not (bolp)))
- (princ "\n"))
- ((eq (oref sti where) 'end)
- ;; If there is whitespace after pnt, then clear it out.
- (when (looking-at "\\s-*$")
- (delete-region (point) (line-end-position)))
- (when (not (eolp))
- (princ "\n")))
- )
- (setq pm (point-marker))
- (when (and (eq i t) inbuff (not (eq (oref sti where) 'end)))
- (indent-according-to-mode)
- (goto-char pm))
- )))
-
-(defclass srecode-template-inserter-comment (srecode-template-inserter)
- ((key :initform ?!
- :allocation :class
- :documentation
- "The character code used to identify inserters of this style.")
- )
- "Allow comments within template coding. This inserts nothing.")
-
-(cl-defmethod srecode-inserter-prin-example ((_ins (subclass srecode-template-inserter-comment))
- escape-start escape-end)
- "Insert an example using inserter INS.
-Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
- (princ " ")
- (princ escape-start)
- (princ "! Miscellaneous text commenting in your template. ")
- (princ escape-end)
- (terpri)
- )
-
-(cl-defmethod srecode-insert-method ((_sti srecode-template-inserter-comment)
- _dictionary)
- "Don't insert anything for comment macros in STI."
- nil)
-
-
-(defclass srecode-template-inserter-variable (srecode-template-inserter)
- ((key :initform nil
- :allocation :class
- :documentation
- "The character code used to identify inserters of this style."))
- "Insert the value of a dictionary entry.
-If there is no entry, insert nothing.")
-
-(defvar srecode-inserter-variable-current-dictionary nil
- "The active dictionary when calling a variable filter.")
-
-(cl-defmethod srecode-insert-variable-secondname-handler
- ((sti srecode-template-inserter-variable) dictionary value secondname)
- "For VALUE handle SECONDNAME behaviors for this variable inserter.
-Return the result as a string.
-By default, treat as a function name.
-If SECONDNAME is nil, return VALUE."
- (if secondname
- (let ((fcnpart (read secondname)))
- (if (fboundp fcnpart)
- (let ((srecode-inserter-variable-current-dictionary dictionary))
- (funcall fcnpart value))
- ;; Else, warn.
- (srecode-insert-report-error
- dictionary
- "Variable inserter %s: second argument `%s' is not a function"
- (cl-prin1-to-string sti) secondname)))
- value))
-
-(cl-defmethod srecode-insert-method ((sti srecode-template-inserter-variable)
- dictionary)
- "Insert the STI inserter."
- ;; Convert the name into a name/fcn pair
- (let* ((name (oref sti object-name))
- (fcnpart (oref sti secondname))
- (val (srecode-dictionary-lookup-name
- dictionary name))
- (do-princ t))
- ;; Alert if a macro wasn't found.
- (when (not val)
- (message "Warning: macro %S was not found in the dictionary." name)
- (setq val ""))
- ;; If there was a functional part, call that function.
- (cond ;; Strings
- ((stringp val)
- (setq val (srecode-insert-variable-secondname-handler
- sti dictionary val fcnpart)))
- ;; Compound data value
- ((cl-typep val 'srecode-dictionary-compound-value)
- ;; Force FCN to be a symbol
- (when fcnpart (setq fcnpart (read fcnpart)))
- ;; Convert compound value to a string with the fcn.
- (setq val (srecode-compound-toString val fcnpart dictionary))
- ;; If the value returned is nil, then it may be a special
- ;; field inserter that requires us to set do-princ to nil.
- (when (not val)
- (setq do-princ nil)))
-
- ;; Dictionaries... not allowed in this style
- ((cl-typep val 'srecode-dictionary)
- (srecode-insert-report-error
- dictionary
- "Macro %s cannot insert a dictionary - use section macros instead"
- name))
-
- ;; Other stuff... convert
- (t
- (srecode-insert-report-error
- dictionary
- "Macro %s cannot insert arbitrary data" name)))
- ;; Output the dumb thing unless the type of thing specifically
- ;; did the inserting for us.
- (when do-princ
- (princ val))))
-
-(defclass srecode-template-inserter-ask (srecode-template-inserter-variable)
- ((key :initform ??
- :allocation :class
- :documentation
- "The character code used to identify inserters of this style.")
- (prompt :initarg :prompt
- :initform nil
- :documentation
- "The prompt used to query for this dictionary value.")
- (defaultfcn :initarg :defaultfcn
- :initform nil
- :documentation
- "The function which can calculate a default value.")
- (read-fcn :initarg :read-fcn
- :initform 'read-string
- :documentation
- "The function used to read in the text for this prompt.")
- )
- "Insert the value of a dictionary entry.
-If there is no entry, prompt the user for the value to use.
-The prompt text used is derived from the previous PROMPT command in the
-template file.")
-
-(cl-defmethod srecode-inserter-apply-state
- ((ins srecode-template-inserter-ask) STATE)
- "For the template inserter INS, apply information from STATE.
-Loop over the prompts to see if we have a match."
- (let ((prompts (oref STATE prompts))
- )
- (while prompts
- (when (string= (semantic-tag-name (car prompts))
- (oref ins object-name))
- (oset ins prompt
- (semantic-tag-get-attribute (car prompts) :text))
- (oset ins defaultfcn
- (semantic-tag-get-attribute (car prompts) :default))
- (oset ins read-fcn
- (or (semantic-tag-get-attribute (car prompts) :read)
- 'read-string))
- )
- (setq prompts (cdr prompts)))
- ))
-
-(cl-defmethod srecode-insert-method ((sti srecode-template-inserter-ask)
- dictionary)
- "Insert the STI inserter."
- (let ((val (srecode-dictionary-lookup-name
- dictionary (oref sti object-name))))
- (if val
- ;; Does some extra work. Oh well.
- (cl-call-next-method)
-
- ;; How is our -ask value determined?
- (if srecode-insert-with-fields-in-progress
- ;; Setup editable fields.
- (setq val (srecode-insert-method-field sti dictionary))
- ;; Ask the question...
- (setq val (srecode-insert-method-ask sti dictionary)))
-
- ;; After asking, save in the dictionary so that
- ;; the user can use the same name again later.
- (srecode-dictionary-set-value
- (srecode-root-dictionary dictionary)
- (oref sti object-name) val)
-
- ;; Now that this value is safely stowed in the dictionary,
- ;; we can do what regular inserters do.
- (cl-call-next-method))))
-
-(cl-defmethod srecode-insert-ask-default ((sti srecode-template-inserter-ask)
- dictionary)
- "Derive the default value for an askable inserter STI.
-DICTIONARY is used to derive some values."
- (let ((defaultfcn (oref sti defaultfcn)))
- (cond
- ((stringp defaultfcn)
- defaultfcn)
-
- ((functionp defaultfcn)
- (funcall defaultfcn))
-
- ((and (listp defaultfcn)
- (eq (car defaultfcn) 'macro))
- (srecode-dictionary-lookup-name
- dictionary (cdr defaultfcn)))
-
- ((null defaultfcn)
- "")
-
- (t
- (srecode-insert-report-error
- dictionary
- "Unknown default for prompt: %S" defaultfcn)))))
-
-(cl-defmethod srecode-insert-method-ask ((sti srecode-template-inserter-ask)
- dictionary)
- "Do the \"asking\" for the template inserter STI.
-Use DICTIONARY to resolve values."
- (let* ((prompt (oref sti prompt))
- (default (srecode-insert-ask-default sti dictionary))
- (reader (oref sti read-fcn))
- (val nil)
- )
- (cond ((eq reader 'y-or-n-p)
- (if (y-or-n-p (or prompt
- (format "%s? "
- (oref sti object-name))))
- (setq val default)
- (setq val "")))
- ((eq reader 'read-char)
- (setq val (format
- "%c"
- (read-char (or prompt
- (format "Char for %s: "
- (oref sti object-name))))))
- )
- (t
- (save-excursion
- (setq val (funcall reader
- (or prompt
- (format "Specify %s: "
- (oref sti object-name)))
- default
- )))))
- ;; Return our derived value.
- val)
- )
-
-(cl-defmethod srecode-insert-method-field ((sti srecode-template-inserter-ask)
- dictionary)
- "Create an editable field for the template inserter STI.
-Use DICTIONARY to resolve values."
- (let* ((default (srecode-insert-ask-default sti dictionary))
- (compound-value
- (srecode-field-value (oref sti object-name)
- :firstinserter sti
- :defaultvalue default))
- )
- ;; Return this special compound value as the thing to insert.
- ;; This special compound value will repeat our asked question
- ;; across multiple locations.
- compound-value))
-
-(cl-defmethod srecode-dump ((ins srecode-template-inserter-ask) _indent)
- "Dump the state of the SRecode template inserter INS."
- (cl-call-next-method)
- (princ " : \"")
- (princ (oref ins prompt))
- (princ "\"")
- )
-
-(defclass srecode-template-inserter-width (srecode-template-inserter-variable)
- ((key :initform ?|
- :allocation :class
- :documentation
- "The character code used to identify inserters of this style.")
- )
- "Inserts the value of a dictionary variable with a specific width.
-The second argument specifies the width, and a pad, separated by a colon.
-Thus a specification of `10:left' will insert the value of A
-to 10 characters, with spaces added to the left. Use `right' for adding
-spaces to the right.")
-
-(cl-defmethod srecode-insert-variable-secondname-handler
- ((_sti srecode-template-inserter-width) dictionary value width)
- "For VALUE handle WIDTH behaviors for this variable inserter.
-Return the result as a string.
-By default, treat as a function name."
- ;; Cannot work without width.
- (unless width
- (srecode-insert-report-error
- dictionary
- "Width not specified for variable/width inserter"))
-
- ;; Trim or pad to new length
- (let* ((split (split-string width ":"))
- (width (string-to-number (nth 0 split)))
- (second (nth 1 split))
- (pad (cond
- ((or (null second) (string= "right" second))
- 'right)
- ((string= "left" second)
- 'left)
- (t
- (srecode-insert-report-error
- dictionary
- "Unknown pad type %s" second)))))
- (if (>= (length value) width)
- ;; Simple case - too long.
- (substring value 0 width)
- ;; We need to pad on one side or the other.
- (let ((padchars (make-string (- width (length value)) ? )))
- (if (eq pad 'left)
- (concat padchars value)
- (concat value padchars))))))
-
-(cl-defmethod srecode-inserter-prin-example ((_ins (subclass srecode-template-inserter-width))
- escape-start escape-end)
- "Insert an example using inserter INS.
-Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
- (princ " ")
- (princ escape-start)
- (princ "|A:10:right")
- (princ escape-end)
- (terpri)
- )
-
-(defvar srecode-template-inserter-point-override nil
- "Point-positioning method for the SRecode template inserter.
-When nil, perform normal point-positioning behavior.
-When the value is a cons cell (DEPTH . FUNCTION), call FUNCTION
-instead, unless the template nesting depth, measured
-by (length (oref srecode-template active)), is greater than
-DEPTH.")
-
-
-(defclass srecode-template-inserter-point (srecode-template-inserter)
- ((key :initform ?^
- :allocation :class
- :documentation
- "The character code used to identify inserters of this style.")
- (point :type (or null marker)
- :allocation :class
- :initform nil
- :documentation
- "Record the value of (point) in this class slot.
-It is the responsibility of the inserter algorithm to clear this
-after a successful insertion."))
- "Record the value of (point) when inserted.
-The cursor is placed at the ^ macro after insertion.
-Some inserter macros, such as `srecode-template-inserter-include-wrap'
-will place text at the ^ macro from the included macro.")
-
-(cl-defmethod srecode-inserter-prin-example ((_ins (subclass srecode-template-inserter-point))
- escape-start escape-end)
- "Insert an example using inserter INS.
-Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
- (princ " ")
- (princ escape-start)
- (princ "^")
- (princ escape-end)
- (terpri)
- )
-
-(cl-defmethod srecode-insert-method ((sti srecode-template-inserter-point)
- dictionary)
- "Insert the STI inserter.
-Save point in the class allocated `point' slot.
-If `srecode-template-inserter-point-override' non-nil then this
-generalized marker will do something else. See
-`srecode-template-inserter-include-wrap' as an example."
- ;; If `srecode-template-inserter-point-override' is non-nil, its car
- ;; is the maximum template nesting depth for which the override is
- ;; valid. Compare this to the actual template nesting depth and
- ;; maybe use the override function which is stored in the cdr.
- (if (and srecode-template-inserter-point-override
- (<= (length (oref-default 'srecode-template active))
- (car srecode-template-inserter-point-override)))
- ;; Disable the old override while we do this.
- (let ((over (cdr srecode-template-inserter-point-override))
- (srecode-template-inserter-point-override nil))
- (funcall over dictionary))
- (oset sti point (point-marker))
- ))
-
-(defclass srecode-template-inserter-subtemplate (srecode-template-inserter)
- ()
- "Wrap a section of a template under the control of a macro."
- :abstract t)
-
-(cl-defmethod srecode-inserter-prin-example ((_ins (subclass srecode-template-inserter-subtemplate))
- escape-start escape-end)
- "Insert an example using inserter INS.
-Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
- (cl-call-next-method)
- (princ " Template Text to control")
- (terpri)
- (princ " ")
- (princ escape-start)
- (princ "/VARNAME")
- (princ escape-end)
- (terpri)
- )
-
-(cl-defmethod srecode-insert-subtemplate ((sti srecode-template-inserter-subtemplate)
- dict slot)
- "Insert a subtemplate for the inserter STI with dictionary DICT."
- ;; Make sure that only dictionaries are used.
- (unless (cl-typep dict 'srecode-dictionary)
- (srecode-insert-report-error
- dict
- "Only section dictionaries allowed for `%s'"
- (eieio-object-name-string sti)))
-
- ;; Output the code from the sub-template.
- (srecode-insert-method (slot-value sti slot) dict))
-
-(cl-defmethod srecode-insert-method-helper ((sti srecode-template-inserter-subtemplate)
- dictionary slot)
- "Do the work for inserting the STI inserter.
-Loops over the embedded CODE which was saved here during compilation.
-The template to insert is stored in SLOT."
- (let ((dicts (srecode-dictionary-lookup-name
- dictionary (oref sti object-name))))
- (when (not (listp dicts))
- (srecode-insert-report-error
- dictionary
- "Cannot insert section %S from non-section variable."
- (oref sti object-name)))
- ;; If there is no section dictionary, then don't output anything
- ;; from this section.
- (while dicts
- (when (not (srecode-dictionary-p (car dicts)))
- (srecode-insert-report-error
- dictionary
- "Cannot insert section %S from non-section variable."
- (oref sti object-name)))
- (srecode-insert-subtemplate sti (car dicts) slot)
- (setq dicts (cdr dicts)))))
-
-(cl-defmethod srecode-insert-method ((sti srecode-template-inserter-subtemplate)
- dictionary)
- "Insert the STI inserter.
-Calls back to `srecode-insert-method-helper' for this class."
- (srecode-insert-method-helper sti dictionary 'template))
-
-
-(defclass srecode-template-inserter-section-start (srecode-template-inserter-subtemplate)
- ((key :initform ?#
- :allocation :class
- :documentation
- "The character code used to identify inserters of this style.")
- (template :initarg :template
- :documentation
- "A template used to frame the codes from this inserter.")
- )
- "Apply values from a sub-dictionary to a template section.
-The dictionary saved at the named dictionary entry will be
-applied to the text between the section start and the
-`srecode-template-inserter-section-end' macro.")
-
-(cl-defmethod srecode-parse-input ((ins srecode-template-inserter-section-start)
- tag input STATE)
- "For the section inserter INS, parse INPUT.
-Shorten input until the END token is found.
-Return the remains of INPUT."
- (let* ((out (srecode-compile-split-code tag input STATE
- (oref ins object-name))))
- (oset ins template (srecode-template
- (eieio-object-name-string ins)
- :context nil
- :args nil
- :code (cdr out)))
- (car out)))
-
-(cl-defmethod srecode-dump ((ins srecode-template-inserter-section-start) indent)
- "Dump the state of the SRecode template inserter INS."
- (cl-call-next-method)
- (princ "\n")
- (srecode-dump-code-list (oref (oref ins template) code)
- (concat indent " "))
- )
-
-(defclass srecode-template-inserter-section-end (srecode-template-inserter)
- ((key :initform ?/
- :allocation :class
- :documentation
- "The character code used to identify inserters of this style.")
- )
- "All template segments between the section-start and section-end
-are treated specially.")
-
-(cl-defmethod srecode-insert-method ((_sti srecode-template-inserter-section-end)
- _dictionary)
- "Insert the STI inserter."
- )
-
-(cl-defmethod srecode-match-end ((ins srecode-template-inserter-section-end) name)
-
- "For the template inserter INS, do I end a section called NAME?"
- (string= name (oref ins object-name)))
-
-(defclass srecode-template-inserter-include (srecode-template-inserter-subtemplate)
- ((key :initform ?>
- :allocation :class
- :documentation
- "The character code used to identify inserters of this style.")
- (includedtemplate
- :initarg :includedtemplate
- :documentation
- "The template included for this inserter."))
- "Include a different template into this one.
-The included template will have additional dictionary entries from the subdictionary
-stored specified by this macro.")
-
-(cl-defmethod srecode-inserter-prin-example ((_ins (subclass srecode-template-inserter-include))
- escape-start escape-end)
- "Insert an example using inserter INS.
-Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
- (princ " ")
- (princ escape-start)
- (princ ">DICTNAME:contextname:templatename")
- (princ escape-end)
- (terpri)
- )
-
-(cl-defmethod srecode-insert-include-lookup ((sti srecode-template-inserter-include)
- dictionary)
- "For the template inserter STI, lookup the template to include.
-Finds the template with this macro function part and stores it in
-this template instance."
- (let ((templatenamepart (oref sti secondname)))
- ;; If there was no template name, throw an error.
- (unless templatenamepart
- (srecode-insert-report-error
- dictionary
- "Include macro `%s' needs a template name"
- (oref sti object-name)))
-
- ;; NOTE: We used to cache the template and not look it up a second time,
- ;; but changes in the template tables can change which template is
- ;; eventually discovered, so now we always lookup that template.
-
- ;; Calculate and store the discovered template
- (let ((tmpl (srecode-template-get-table (srecode-table)
- templatenamepart))
- (active (oref-default 'srecode-template active))
- ctxt)
- (when (not tmpl)
- ;; If it isn't just available, scan back through
- ;; the active template stack, searching for a matching
- ;; context.
- (while (and (not tmpl) active)
- (setq ctxt (oref (car active) context))
- (setq tmpl (srecode-template-get-table (srecode-table)
- templatenamepart
- ctxt))
- (when (not tmpl)
- (when (slot-boundp (car active) 'table)
- (let ((app (oref (oref (car active) table) application)))
- (when app
- (setq tmpl (srecode-template-get-table
- (srecode-table)
- templatenamepart
- ctxt app)))
- )))
- (setq active (cdr active)))
- (when (not tmpl)
- ;; If it wasn't in this context, look to see if it
- ;; defines its own context
- (setq tmpl (srecode-template-get-table (srecode-table)
- templatenamepart)))
- )
-
- ;; Store the found template into this object for later use.
- (oset sti includedtemplate tmpl))
-
- (unless (oref sti includedtemplate)
- ;; @todo - Call into a debugger to help find the template in question.
- (srecode-insert-report-error
- dictionary
- "No template \"%s\" found for include macro `%s'"
- templatenamepart (oref sti object-name)))))
-
-(cl-defmethod srecode-insert-method ((sti srecode-template-inserter-include)
- dictionary)
- "Insert the STI inserter.
-Finds the template with this macro function part, and inserts it
-with the dictionaries found in the dictionary."
- (srecode-insert-include-lookup sti dictionary)
- ;; Insert the template.
- ;; Our baseclass has a simple way to do this.
- (if (srecode-dictionary-lookup-name dictionary (oref sti object-name))
- ;; If we have a value, then call the next method
- (srecode-insert-method-helper sti dictionary 'includedtemplate)
- ;; If we don't have a special dictionary, then just insert with the
- ;; current dictionary.
- (srecode-insert-subtemplate sti dictionary 'includedtemplate))
- )
-
-;;
-;; This template combines the include template and the sectional template.
-;; It will first insert the included template, then insert the embedded
-;; template wherever the $^$ in the included template was.
-;;
-;; Since it uses dual inheritance, it will magically get the end-matching
-;; behavior of #, with the including feature of >.
-;;
-(defclass srecode-template-inserter-include-wrap (srecode-template-inserter-include srecode-template-inserter-section-start)
- ((key :initform ?<
- :allocation :class
- :documentation
- "The character code used to identify inserters of this style.")
- )
- "Include a different template into this one, and add text at the ^ macro.
-The included template will have additional dictionary entries from the subdictionary
-stored specified by this macro. If the included macro includes a ^ macro,
-then the text between this macro and the end macro will be inserted at
-the ^ macro.")
-
-(cl-defmethod srecode-inserter-prin-example ((_ins (subclass srecode-template-inserter-include-wrap))
- escape-start escape-end)
- "Insert an example using inserter INS.
-Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
- (princ " ")
- (princ escape-start)
- (princ "<DICTNAME:contextname:templatename")
- (princ escape-end)
- (terpri)
- (princ " Template Text to insert at ^ macro")
- (terpri)
- (princ " ")
- (princ escape-start)
- (princ "/DICTNAME")
- (princ escape-end)
- (terpri)
- )
-
-(cl-defmethod srecode-insert-method ((sti srecode-template-inserter-include-wrap)
- dictionary)
- "Insert the template STI.
-This will first insert the include part via inheritance, then
-insert the section it wraps into the location in the included
-template where a ^ inserter occurs."
- ;; Step 1: Look up the included inserter
- (srecode-insert-include-lookup sti dictionary)
- ;; Step 2: Temporarily override the point inserter.
- ;; We bind `srecode-template-inserter-point-override' to a cons cell
- ;; (DEPTH . FUNCTION) that has the maximum template nesting depth,
- ;; for which the override is valid, in DEPTH and a lambda function
- ;; which implements the wrap insertion behavior in FUNCTION. The
- ;; maximum valid nesting depth is just the current depth + 1.
- (let ((srecode-template-inserter-point-override
- (cons
- ;; DEPTH
- (+ (length (oref-default 'srecode-template active)) 1)
- ;; FUNCTION
- (lambda (dict)
- (let ((srecode-template-inserter-point-override nil))
- (if (srecode-dictionary-lookup-name
- dict (oref sti object-name))
- ;; Insert our sectional part with looping.
- (srecode-insert-method-helper
- sti dict 'template)
- ;; Insert our sectional part just once.
- (srecode-insert-subtemplate
- sti dict 'template)))))))
- ;; Do a regular insertion for an include, but with our override in
- ;; place.
- (cl-call-next-method)))
-
-(cl-defmethod srecode-inserter-prin-example ((ins (subclass srecode-template-inserter))
- escape-start escape-end)
- "Insert an example using inserter INS.
-Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use."
- (princ " ")
- (princ escape-start)
- (when (and (slot-exists-p ins 'key) (oref ins key))
- (princ (format "%c" (oref ins key))))
- (princ "VARNAME")
- (princ escape-end)
- (terpri)
- )
-
-(provide 'srecode/insert)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/insert"
-;; End:
-
-;;; srecode/insert.el ends here
+++ /dev/null
-;;; srecode/java.el --- Srecode Java support -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Special support for the Java language.
-
-;;; Code:
-
-(require 'srecode/dictionary)
-(require 'semantic/find)
-(require 'ede)
-
-;;;###autoload
-(defun srecode-semantic-handle-:java (dict)
- "Add macros into the dictionary DICT based on the current java file.
-Adds the following:
-FILENAME_AS_PACKAGE - file/dir converted into a java package name.
-FILENAME_AS_CLASS - file converted to a Java class name."
- ;; Symbols needed by empty files.
- (let* ((fsym (file-name-nondirectory (buffer-file-name)))
- (fnox (file-name-sans-extension fsym))
- (dir (file-name-directory (buffer-file-name)))
- (fpak fsym)
- (proj (ede-current-project))
- (pths (ede-source-paths proj 'java-mode))
- )
- (while (string-match "\\.\\| " fpak)
- (setq fpak (replace-match "_" t t fpak)))
- ;; We can extract package from:
- ;; 1) a java EDE project source paths,
- (cond ((and proj pths)
- (let* ((pth) (res))
- (while (and (not res)
- (setq pth (expand-file-name (car pths))))
- (when (string-match pth dir)
- (setq res (substring dir (match-end 0))))
- (setq pths (cdr pths)))
- (setq dir res)))
- ;; 2) a simple heuristic
- ((string-match "src/" dir)
- (setq dir (substring dir (match-end 0))))
- ;; 3) outer directory as a fallback
- (t (setq dir (file-name-nondirectory (directory-file-name dir)))))
- (setq dir (directory-file-name dir))
- (while (string-match "/" dir)
- (setq dir (replace-match "." t t dir)))
- (srecode-dictionary-set-value dict "FILENAME_AS_PACKAGE" dir)
- (srecode-dictionary-set-value dict "FILENAME_AS_CLASS" fnox)
- )
- ;; Symbols needed for most other files with stuff in them.
- (let ((pkg (semantic-find-tags-by-class 'package (current-buffer))))
- (when pkg
- (srecode-dictionary-set-value dict "CURRENT_PACKAGE" (semantic-tag-name (car pkg)))
- ))
- )
-
-(provide 'srecode/java)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/java"
-;; End:
-
-;;; srecode/java.el ends here
+++ /dev/null
-;;; srecode/map.el --- Manage a template file map -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Read template files, and build a map of where they can be found.
-;; Save the map to disk, and refer to it when bootstrapping a new
-;; Emacs session with srecode.
-
-(require 'semantic)
-(require 'eieio-base)
-(require 'srecode)
-
-;;; Code:
-
-;; The defcustom is given at the end of the file.
-(defvar srecode-map-load-path)
-
-(defun srecode-map-base-template-dir ()
- "Find the base template directory for SRecode."
- (expand-file-name "srecode" data-directory))
-\f
-;;; Current MAP
-;;
-
-(defvar srecode-current-map nil
- "The current map for global SRecode templates.")
-
-(defcustom srecode-map-save-file
- (locate-user-emacs-file "srecode-map.el" ".srecode/srecode-map")
- "The save location for SRecode's map file.
-If the save file is nil, then the MAP is not saved between sessions."
- :group 'srecode
- :type '(choice (const :tag "Don't save" nil)
- file))
-
-(defclass srecode-map (eieio-persistent)
- ((fileheaderline :initform ";; SRECODE TEMPLATE MAP")
- (files :initarg :files
- :initform nil
- :type list
- :documentation
- "An alist of files and the major-mode that they cover.")
- (apps :initarg :apps
- :initform nil
- :type list
- :documentation
- "An alist of applications.
-Each app keys to an alist of files and modes (as above.)")
- )
- "A map of srecode templates.")
-
-(cl-defmethod srecode-map-entry-for-file ((map srecode-map) file)
- "Return the entry in MAP for FILE."
- (assoc file (oref map files)))
-
-(cl-defmethod srecode-map-entries-for-mode ((map srecode-map) mode)
- "Return the entries in MAP for major MODE."
- (let ((ans nil))
- (dolist (f (oref map files))
- (when (provided-mode-derived-p mode (cdr f))
- (setq ans (cons f ans))))
- ans))
-
-(cl-defmethod srecode-map-entry-for-app ((map srecode-map) app)
- "Return the entry in MAP for APP."
- (assoc app (oref map apps))
- )
-
-(cl-defmethod srecode-map-entries-for-app-and-mode ((map srecode-map) app mode)
- "Return the entries in MAP for major MODE."
- (let ((ans nil)
- (appentry (srecode-map-entry-for-app map app)))
- (dolist (f (cdr appentry))
- (when (eq (cdr f) mode)
- (setq ans (cons f ans))))
- ans))
-
-(cl-defmethod srecode-map-entry-for-file-anywhere ((map srecode-map) file)
- "Search in all entry points in MAP for FILE.
-Return a list ( APP . FILE-ASSOC ) where APP is nil
-in the global map."
- (or
- ;; Look in the global entry
- (let ((globalentry (srecode-map-entry-for-file map file)))
- (when globalentry
- (cons nil globalentry)))
- ;; Look in each app.
- (let ((match nil))
- (dolist (app (oref map apps))
- (let ((appmatch (assoc file (cdr app))))
- (when appmatch
- (setq match (cons app appmatch)))))
- match)
- ;; Other?
- ))
-
-(cl-defmethod srecode-map-delete-file-entry ((map srecode-map) file)
- "Update MAP to exclude FILE from the file list."
- (let ((entry (srecode-map-entry-for-file map file)))
- (when entry
- (object-remove-from-list map 'files entry))))
-
-(cl-defmethod srecode-map-update-file-entry ((map srecode-map) file mode)
- "Update a MAP entry for FILE to be used with MODE.
-Return non-nil if the MAP was changed."
- (let ((entry (srecode-map-entry-for-file map file))
- (dirty t))
- (cond
- ;; It is already a match.. do nothing.
- ((and entry (eq (cdr entry) mode))
- (setq dirty nil))
- ;; We have a non-matching entry. Change the cdr.
- (entry
- (setcdr entry mode))
- ;; No entry, just add it to the list.
- (t
- (object-add-to-list map 'files (cons file mode))
- ))
- dirty))
-
-(cl-defmethod srecode-map-delete-file-entry-from-app ((map srecode-map) file app)
- "Delete from MAP the FILE entry within the APP."
- (let* ((appe (srecode-map-entry-for-app map app))
- (fentry (assoc file (cdr appe))))
- (setcdr appe (delete fentry (cdr appe))))
- )
-
-(cl-defmethod srecode-map-update-app-file-entry ((map srecode-map) file mode app)
- "Update the MAP entry for FILE to be used with MODE within APP.
-Return non-nil if the map was changed."
- (let* ((appentry (srecode-map-entry-for-app map app))
- (appfileentry (assoc file (cdr appentry)))
- (dirty t)
- )
- (cond
- ;; Option 1 - We have this file in this application already
- ;; with the correct mode.
- ((and appfileentry (eq (cdr appfileentry) mode))
- (setq dirty nil)
- )
- ;; Option 2 - We have a non-matching entry. Change Cdr.
- (appfileentry
- (setcdr appfileentry mode))
- (t
- ;; For option 3 & 4 - remove the entry from any other lists
- ;; we can find.
- (let ((any (srecode-map-entry-for-file-anywhere map file)))
- (when any
- (if (null (car any))
- ;; Global map entry
- (srecode-map-delete-file-entry map file)
- ;; Some app
- (let ((appentry (srecode-map-entry-for-app map app)))
- (setcdr appentry (delete (cdr any) (cdr appentry))))
- )))
- ;; Now do option 3 and 4
- (cond
- ;; Option 3 - No entry for app. Add to the list.
- (appentry
- (setcdr appentry (cons (cons file mode) (cdr appentry)))
- )
- ;; Option 4 - No app entry. Add app to list with this file.
- (t
- (object-add-to-list map 'apps (list app (cons file mode)))
- )))
- )
- dirty))
-
-\f
-;;; MAP Updating
-;;
-;;;###autoload
-(defun srecode-get-maps (&optional reset)
- "Get a list of maps relevant to the current buffer.
-Optional argument RESET forces a reset of the current map."
- (interactive "P")
- ;; Always update the map, but only do a full reset if
- ;; the user asks for one.
- (srecode-map-update-map (not reset))
-
- (if (called-interactively-p 'any)
- ;; Dump this map.
- (with-output-to-temp-buffer "*SRECODE MAP*"
- (princ " -- SRecode Global map --\n")
- (srecode-maps-dump-file-list (oref srecode-current-map files))
- (princ "\n -- Application Maps --\n")
- (dolist (ap (oref srecode-current-map apps))
- (let ((app (car ap))
- (files (cdr ap)))
- (princ app)
- (princ " :\n")
- (srecode-maps-dump-file-list files))
- (princ "\n"))
- (princ "\nUse:\n\n M-x customize-variable RET srecode-map-load-path RET")
- (princ "\n To change the path where SRecode loads templates from.")
- )
- ;; Eventually, I want to return many maps to search through.
- (list srecode-current-map)))
-
-(declare-function data-debug-new-buffer "data-debug")
-(declare-function data-debug-insert-stuff-list "data-debug")
-
-(defun srecode-adebug-maps ()
- "Run ADEBUG on the output of `srecode-get-maps'."
- (interactive)
- (require 'data-debug)
- (let ((start (current-time))
- (p (srecode-get-maps t)) ;; Time the reset.
- )
- (message "Updating the map took %.2f seconds."
- (semantic-elapsed-time start nil))
- (data-debug-new-buffer "*SRECODE ADEBUG*")
- (data-debug-insert-stuff-list p "*")))
-
-(defun srecode-maps-dump-file-list (flist)
- "Dump a file list FLIST to `standard-output'."
- (princ "Mode\t\t\tFilename\n")
- (princ "------\t\t\t------------------\n")
- (dolist (fe flist)
- (prin1 (cdr fe))
- (princ "\t")
- (when (> (* 2 8) (length (symbol-name (cdr fe))))
- (princ "\t"))
- (when (> 8 (length (symbol-name (cdr fe))))
- (princ "\t"))
- (princ (car fe))
- (princ "\n")
- ))
-
-(defun srecode-map-file-still-valid-p (filename _map)
- "Return t if FILENAME should be in MAP still."
- (let ((valid nil))
- (and (file-exists-p filename)
- (progn
- (dolist (p srecode-map-load-path)
- (when (and (< (length p) (length filename))
- (string= p (substring filename 0 (length p))))
- (setq valid t))
- )
- valid))
- ))
-
-(defun srecode-map-update-map (&optional fast)
- "Update the current map from `srecode-map-load-path'.
-Scans all the files on the path, and makes sure we have entries
-for them.
-If option FAST is non-nil, then only parse a file for the mode-string
-if that file is NEW, otherwise assume the mode has not changed."
- (interactive)
-
- ;; When no map file, we are configured to not use a save file.
- (if (not srecode-map-save-file)
- ;; 0) Create a MAP when in no save file mode.
- (when (not srecode-current-map)
- (setq srecode-current-map (srecode-map))
- (message "SRecode map created in non-save mode.")
- )
-
- ;; 1) Do we even have a MAP or save file?
- (when (and (not srecode-current-map)
- (not (file-exists-p srecode-map-save-file)))
- (when (not (file-exists-p (file-name-directory srecode-map-save-file)))
- ;; Only bother with this interactively, not during a build
- ;; or test.
- (when (not noninteractive)
- ;; No map, make the dir?
- (if (y-or-n-p (format "Create dir %s? "
- (file-name-directory srecode-map-save-file)))
- (make-directory (file-name-directory srecode-map-save-file))
- ;; No make, change save file
- (customize-variable 'srecode-map-save-file)
- (error "Change your SRecode map file"))))
- ;; Have a dir. Make the object.
- (setq srecode-current-map
- (srecode-map :file srecode-map-save-file)))
-
- ;; 2) Do we not have a current map? If so load.
- (when (not srecode-current-map)
- (condition-case nil
- (setq srecode-current-map
- (eieio-persistent-read srecode-map-save-file 'srecode-map))
- (error
- ;; There was an error loading the old map. Create a new one.
- (setq srecode-current-map
- (srecode-map :file srecode-map-save-file))))
- )
-
- )
-
- ;;
- ;; We better have a MAP object now.
- ;;
- (let ((dirty nil))
- ;; 3) - Purge dead files from the file list.
- (dolist (entry (copy-sequence (oref srecode-current-map files)))
- (when (not (srecode-map-file-still-valid-p
- (car entry) srecode-current-map))
- (srecode-map-delete-file-entry srecode-current-map (car entry))
- (setq dirty t)
- ))
- (dolist (app (copy-sequence (oref srecode-current-map apps)))
- (dolist (entry (copy-sequence (cdr app)))
- (when (not (srecode-map-file-still-valid-p
- (car entry) srecode-current-map))
- (srecode-map-delete-file-entry-from-app
- srecode-current-map (car entry) (car app))
- (setq dirty t)
- )))
- ;; 4) - Find new files and add them to the map.
- (dolist (dir srecode-map-load-path)
- (when (file-exists-p dir)
- (dolist (f (directory-files dir t "\\.srt\\'"))
- (when (and (not (backup-file-name-p f))
- (not (auto-save-file-name-p f))
- (file-readable-p f))
- (let ((fdirty (srecode-map-validate-file-for-mode f fast)))
- (setq dirty (or dirty fdirty))))
- )))
- ;; Only do the save if we are dirty, or if we are in an interactive
- ;; Emacs.
- (when (and dirty (not noninteractive)
- (slot-boundp srecode-current-map :file))
- (eieio-persistent-save srecode-current-map))
- ))
-
-(defun srecode-map-validate-file-for-mode (file fast)
- "Read and validate FILE via the parser. Return the mode.
-Argument FAST implies that the file should not be reparsed if there
-is already an entry for it.
-Return non-nil if the map changed."
- (unless (and fast
- (srecode-map-entry-for-file-anywhere srecode-current-map file))
- (let ((buff-orig (get-file-buffer file))
- (dirty nil))
- (save-excursion
- (if buff-orig
- (set-buffer buff-orig)
- (set-buffer (get-buffer-create " *srecode-map-tmp*"))
- (insert-file-contents file nil nil nil t)
- ;; Force it to be ready to parse.
- (srecode-template-mode)
- (let ((semantic-init-hook nil))
- (semantic-new-buffer-fcn))
- )
- ;; Force semantic to be enabled in this buffer.
- (unless (semantic-active-p)
- (semantic-new-buffer-fcn))
-
- (semantic-fetch-tags)
- (let* ((mode-tag
- (semantic-find-first-tag-by-name "mode" (current-buffer)))
- (val nil)
- (app-tag
- (semantic-find-first-tag-by-name "application" (current-buffer)))
- (app nil))
- (if mode-tag
- (setq val (car (semantic-tag-variable-default mode-tag)))
- (error "There should be a mode declaration in %s" file))
- (when app-tag
- (setq app (car (semantic-tag-variable-default app-tag))))
-
- (setq dirty
- (if app
- (srecode-map-update-app-file-entry srecode-current-map
- file
- (read val)
- (read app))
- (srecode-map-update-file-entry srecode-current-map
- file
- (read val))))
- )
- )
- dirty)))
-
-\f
-;;; THE PATH
-;;
-;; We need to do this last since the setter needs the above code.
-
-(defun srecode-map-load-path-set (sym val)
- "Set SYM to the new VAL, then update the srecode map."
- (set-default sym val)
- (srecode-map-update-map t))
-
-(defcustom srecode-map-load-path
- (list (srecode-map-base-template-dir)
- (expand-file-name "~/.srecode/")
- )
- "Global load path for SRecode template files."
- :group 'srecode
- :type '(repeat file)
- :set #'srecode-map-load-path-set)
-
-(provide 'srecode/map)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/map"
-;; End:
-
-;;; srecode/map.el ends here
+++ /dev/null
-;;; srecode/mode.el --- Minor mode for managing and using SRecode templates -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Minor mode for working with SRecode template files.
-;;
-;; Depends on Semantic for minor-mode convenience functions.
-
-(require 'mode-local)
-(require 'srecode)
-(require 'srecode/insert)
-(require 'srecode/find)
-(require 'srecode/map)
-(require 'semantic/decorate)
-(require 'semantic/wisent)
-(require 'semantic/senator)
-(require 'semantic/wisent)
-
-(eval-when-compile
- (require 'semantic/find))
-
-;;; Code:
-
-(defcustom srecode-minor-mode-hook nil
- "Hook run at the end of the function `srecode-minor-mode'."
- :group 'srecode
- :type 'hook)
-
-;; We don't want to waste space. There is a menu after all.
-;;(add-to-list 'minor-mode-alist '(srecode-minor-mode ""))
-
-(defvar srecode-prefix-key [(control ?c) ?/]
- "The common prefix key in srecode minor mode.")
-
-(defvar srecode-prefix-map
- (let ((km (make-sparse-keymap)))
- ;; Basic template codes
- (define-key km "/" #'srecode-insert)
- (define-key km [insert] #'srecode-insert)
- (define-key km "." #'srecode-insert-again)
- (define-key km "E" #'srecode-edit)
- ;; Template indirect binding
- (let ((k ?a))
- (while (<= k ?z)
- (define-key km (format "%c" k) #'srecode-bind-insert)
- (setq k (1+ k))))
- km)
- "Keymap used behind the srecode prefix key in srecode minor mode.")
-
-(defvar srecode-menu-bar
- (list
- "SRecoder"
- ["Insert Template"
- srecode-insert
- :active t
- :help "Insert a template by name."]
- ["Insert Template Again"
- srecode-insert-again
- :active t
- :help "Run the same template as last time again."]
- ["Edit Template"
- srecode-edit
- :active t
- :help "Edit a template for this language by name."]
- "---"
- '( "Insert ..." :filter srecode-minor-mode-templates-menu )
- '( "Generate ..." :filter srecode-minor-mode-generate-menu )
- "---"
- ["Customize..."
- (customize-group "srecode")
- :active t
- :help "Customize SRecode options"]
- (list
- "Debugging Tools..."
- ["Dump Template MAP"
- srecode-get-maps
- :active t
- :help "Calculate (if needed) and display the current template file map."]
- ["Dump Tables"
- srecode-dump-templates
- :active t
- :help "Dump the current template table."]
- ["Dump Dictionary"
- srecode-dictionary-dump
- :active t
- :help "Calculate and dump a dictionary for point."]
- ["Show Macro Help"
- srecode-macro-help
- :active t
- :help "Display the different types of macros available."]))
- "Menu for srecode minor mode.")
-
-(defvar srecode-minor-menu nil
- "Menu keymap build from `srecode-menu-bar'.")
-
-(defcustom srecode-takeover-INS-key nil
- "Use the insert key for inserting templates."
- :group 'srecode
- :type 'boolean)
-
-(defvar srecode-mode-map
- (let ((km (make-sparse-keymap)))
- (define-key km srecode-prefix-key srecode-prefix-map)
- (easy-menu-define srecode-minor-menu km "Srecode Minor Mode Menu"
- srecode-menu-bar)
- (when srecode-takeover-INS-key
- (define-key km [insert] srecode-prefix-map))
- km)
- "Keymap for srecode minor mode.")
-
-;;;###autoload
-(define-minor-mode srecode-minor-mode
- "Toggle srecode minor mode.
-
-The minor mode can be turned on only if semantic feature is
-available and the current buffer was set up for parsing. Return
-non-nil if the minor mode is enabled.
-
-\\{srecode-mode-map}"
- :keymap srecode-mode-map
- ;; If we are turning things on, make sure we have templates for
- ;; this mode first.
- (if srecode-minor-mode
- (if (not (apply
- #'append
- (mapcar (lambda (map)
- (srecode-map-entries-for-mode map major-mode))
- (srecode-get-maps))))
- (setq srecode-minor-mode nil)
- ;; Else, we have success, do stuff
- ;; FIXME: Where are `cedet-m3-menu-do-hooks' nor `srecode-m3-items'?
- (when (fboundp 'srecode-m3-items)
- (add-hook 'cedet-m3-menu-do-hooks #'srecode-m3-items nil t)))
- (when (fboundp 'srecode-m3-items)
- (remove-hook 'cedet-m3-menu-do-hooks #'srecode-m3-items t)))
- ;; Run hooks if we are turning this on.
- (when srecode-minor-mode
- (run-hooks 'srecode-minor-mode-hook))
- srecode-minor-mode)
-
-;;;###autoload
-(define-minor-mode global-srecode-minor-mode
- "Toggle global use of srecode minor mode."
- :global t :group 'srecode
- ;; Not needed because it's autoloaded instead.
- ;; :require 'srecode/mode
- (semantic-toggle-minor-mode-globally
- 'srecode-minor-mode (if global-srecode-minor-mode 1 -1)))
-
-;; Use the semantic minor mode magic stuff.
-(semantic-add-minor-mode 'srecode-minor-mode "")
-
-;;; Menu Filters
-;;
-(defun srecode-minor-mode-templates-menu (_menu-def)
- "Create a menu item of cascading filters active for this mode.
-MENU-DEF is the menu to bind this into."
- ;; Doing this SEGVs Emacs on windows.
- ;;(srecode-load-tables-for-mode major-mode)
-
- (let* ((modetable (srecode-get-mode-table major-mode))
- (subtab (when modetable (oref modetable tables)))
- (context nil)
- (active nil)
- (ltab nil)
- (temp nil)
- (alltabs nil)
- )
- (if (not subtab)
- ;; No tables, show a "load the tables" option.
- (list (vector "Load Mode Tables..."
- (lambda ()
- (interactive)
- (srecode-load-tables-for-mode major-mode))
- ))
- ;; Build something
- (setq context (car-safe (srecode-calculate-context)))
-
- (while subtab
- (when (srecode-template-table-in-project-p (car subtab))
- (setq ltab (oref (car subtab) templates))
- (while ltab
- (setq temp (car ltab))
-
- ;; Do something with this template.
-
- (let* ((ctxt (oref temp context))
- (ctxtcons (assoc ctxt alltabs))
- (bind (if (slot-boundp temp 'binding)
- (oref temp binding)))
- (name (eieio-object-name-string temp)))
-
- (when (not ctxtcons)
- (if (string= context ctxt)
- ;; If this context is not in the current list of contexts
- ;; is equal to the current context, then manage the
- ;; active list instead
- (setq active
- (setq ctxtcons (or active (cons ctxt nil))))
- ;; This is not an active context, add it to alltabs.
- (setq ctxtcons (cons ctxt nil))
- (setq alltabs (cons ctxtcons alltabs))))
-
- (let ((new (vector
- (if bind
- (concat name " (" bind ")")
- name)
- (lambda () (interactive)
- (srecode-insert (concat ctxt ":" name)))
- t)))
-
- (push new (cdr ctxtcons))))
-
- (setq ltab (cdr ltab))))
- (setq subtab (cdr subtab)))
-
- ;; Now create the menu
- (easy-menu-filter-return
- (easy-menu-create-menu
- "Semantic Recoder Filters"
- (append (cdr active)
- alltabs)
- ))
- )))
-
-(defvar srecode-minor-mode-generators nil
- "List of code generators to be displayed in the srecoder menu.")
-
-(defun srecode-minor-mode-generate-menu (_menu-def)
- "Create a menu item of cascading filters active for this mode.
-MENU-DEF is the menu to bind this into."
- ;; Doing this SEGVs Emacs on windows.
- ;;(srecode-load-tables-for-mode major-mode)
- (let ((allgeneratorapps nil))
-
- (dolist (gen srecode-minor-mode-generators)
- (setq allgeneratorapps
- (cons (vector (cdr gen) (car gen))
- allgeneratorapps))
- (message "Adding %S to srecode menu" (car gen))
- )
-
- (easy-menu-filter-return
- (easy-menu-create-menu
- "Semantic Recoder Generate Filters"
- allgeneratorapps)))
- )
-
-;;; Minor Mode commands
-;;
-(defun srecode-bind-insert ()
- "Bound insert for Srecode macros.
-This command will insert whichever srecode template has a binding
-to the current key."
- (interactive)
- (srecode-load-tables-for-mode major-mode)
- (let* ((k last-command-event)
- (ctxt (srecode-calculate-context))
- ;; Find the template with the binding K
- (template (srecode-template-get-table-for-binding
- (srecode-table) k ctxt)))
- ;; test it.
- (when (not template)
- (error "No template bound to %c" k))
- ;; insert
- (srecode-insert template)
- ))
-
-(defun srecode-edit (template-name)
- "Switch to the template buffer for TEMPLATE-NAME.
-Template is chosen based on the mode of the starting buffer."
- ;; @todo - Get a template stack from the last run template, and show
- ;; those too!
- (interactive (list (srecode-read-template-name
- "Template Name: "
- (car srecode-read-template-name-history))))
- (if (not (srecode-table))
- (error "No template table found for mode %s" major-mode))
- (let ((temp (srecode-template-get-table (srecode-table) template-name)))
- (if (not temp)
- (error "No Template named %s" template-name))
- ;; We need a template specific table, since tables chain.
- (let ((tab (oref temp table))
- (names nil)
- )
- (find-file (oref tab file))
- (setq names (semantic-find-tags-by-name (oref temp object-name)
- (current-buffer)))
- (cond ((= (length names) 1)
- (semantic-go-to-tag (car names))
- (semantic-momentary-highlight-tag (car names)))
- ((> (length names) 1)
- (let* ((ctxt (semantic-find-tags-by-name (oref temp context)
- (current-buffer)))
- (cls (semantic-find-tags-by-class 'context ctxt))
- )
- (while (and names
- (< (semantic-tag-start (car names))
- (semantic-tag-start (car cls))))
- (setq names (cdr names)))
- (if names
- (progn
- (semantic-go-to-tag (car names))
- (semantic-momentary-highlight-tag (car names)))
- (error "Can't find template %s" template-name))
- ))
- (t (error "Can't find template %s" template-name)))
- )))
-
-(defun srecode-add-code-generator (function name &optional binding)
- "Add the srecoder code generator FUNCTION with NAME to the menu.
-Optional BINDING specifies the keybinding to use in the srecoder map.
-BINDING should be a capital letter. Lower case letters are reserved
-for individual templates.
-Optional MODE specifies a major mode this function applies to.
-Do not specify a mode if this function could be applied to most
-programming modes."
- ;; Update the menu generating part.
- (let ((remloop nil))
- (while (setq remloop (assoc function srecode-minor-mode-generators))
- (setq srecode-minor-mode-generators
- (remove remloop srecode-minor-mode-generators))))
-
- (add-to-list 'srecode-minor-mode-generators
- (cons function name))
-
- ;; Remove this function from any old bindings.
- (when binding
- (let ((oldkey (where-is-internal function
- (list srecode-prefix-map)
- t t t)))
- (if (or (not oldkey)
- (and (= (length oldkey) 1)
- (= (length binding) 1)
- (= (aref oldkey 0) (aref binding 0))))
- ;; Its the same.
- nil
- ;; Remove the old binding
- (define-key srecode-prefix-map oldkey nil)
- )))
-
- ;; Update Keybindings
- (let ((oldbinding (lookup-key srecode-prefix-map binding)))
-
- ;; During development, allow overrides.
- (when (and oldbinding
- (not (eq oldbinding function))
- (or (eq this-command 'eval-defun) (eq this-command 'checkdoc-eval-defun))
- (y-or-n-p (format "Override old binding %s? " oldbinding)))
- (setq oldbinding nil))
-
- (if (not oldbinding)
- (define-key srecode-prefix-map binding function)
- (if (eq function oldbinding)
- nil
- ;; Not the same.
- (message "Conflict binding %S binding to srecode map."
- binding))))
- )
-
-;; Add default code generators:
-(srecode-add-code-generator 'srecode-document-insert-comment "Comments" "C")
-(srecode-add-code-generator 'srecode-insert-getset "Get/Set" "G")
-
-(provide 'srecode/mode)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/mode"
-;; End:
-
-;;; srecode/mode.el ends here
+++ /dev/null
-;;; srecode/semantic.el --- Semantic specific extensions to SRecode -*- lexical-binding:t -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic specific extensions to the Semantic Recoder.
-;;
-;; I realize it is the "Semantic Recoder", but most of srecode
-;; is a template library and set of user interfaces unrelated to
-;; semantic in the specific.
-;;
-;; This file defines the following:
-;; - :tag argument handling.
-;; - <more goes here>
-
-;;; Code:
-
-(require 'srecode/insert)
-(require 'srecode/dictionary)
-(require 'semantic/find)
-(require 'semantic/format)
-(require 'semantic/senator)
-(require 'ring)
-
-\f
-;;; The SEMANTIC TAG inserter
-;;
-;; Put a tag into the dictionary that can be used with arbitrary
-;; Lisp expressions.
-
-(defclass srecode-semantic-tag (srecode-dictionary-compound-value)
- ((prime :initarg :prime
- :type semantic-tag
- :documentation
- "This is the primary insertion tag.")
- )
- "Wrap up a collection of semantic tag information.
-This class will be used to derive dictionary values.")
-
-(cl-defmethod srecode-compound-toString((cp srecode-semantic-tag)
- function
- _dictionary)
- "Convert the compound dictionary value CP to a string.
-If FUNCTION is non-nil, then FUNCTION is somehow applied to an
-aspect of the compound value."
- (if (not function)
- ;; Just format it in some handy dandy way.
- (semantic-format-tag-prototype (oref cp prime))
- ;; Otherwise, apply the function to the tag itself.
- (funcall function (oref cp prime))))
-
-\f
-;;; Managing the `current' tag
-;;
-
-(defvar srecode-semantic-selected-tag nil
- "The tag selected by a :tag template argument.
-If this is nil, then `senator-tag-ring' is used.")
-
-(defun srecode-semantic-tag-from-kill-ring ()
- "Create an `srecode-semantic-tag' from the senator kill ring."
- (if (ring-empty-p senator-tag-ring)
- (error "You must use `senator-copy-tag' to provide a tag to this template"))
- (ring-ref senator-tag-ring 0))
-
-\f
-;;; TAG in a DICTIONARY
-;;
-(defvar srecode-semantic-apply-tag-augment-hook nil
- "A function called for each tag added to a dictionary.
-The hook is called with two arguments, the TAG and DICT
-to be augmented.")
-
-(define-overloadable-function srecode-semantic-apply-tag-to-dict (tagobj dict)
- "Insert features of TAGOBJ into the dictionary DICT.
-TAGOBJ is an object of class `srecode-semantic-tag'. This class
-is a compound inserter value.
-DICT is a dictionary object.
-At a minimum, this function will create dictionary macro for NAME.
-It is also likely to create macros for TYPE (data type), function arguments,
-variable default values, and other things."
- )
-
-(defun srecode-semantic-apply-tag-to-dict-default (tagobj dict)
- "Insert features of TAGOBJ into dictionary DICT."
- ;; Store the sst into the dictionary.
- (srecode-dictionary-set-value dict "TAG" tagobj)
-
- ;; Pull out the tag for the individual pieces.
- (let ((tag (oref tagobj prime)))
-
- (srecode-dictionary-set-value dict "NAME" (semantic-tag-name tag))
- (srecode-dictionary-set-value dict "TYPE" (semantic-format-tag-type tag nil))
-
- (run-hook-with-args 'srecode-semantic-apply-tag-augment-hook tag dict)
-
- (cond
- ;;
- ;; FUNCTION
- ;;
- ((eq (semantic-tag-class tag) 'function)
- ;; FCN ARGS
- (let ((args (semantic-tag-function-arguments tag)))
- (while args
- (let ((larg (car args))
- (subdict (srecode-dictionary-add-section-dictionary
- dict "ARGS")))
- ;; Clean up elements in the arg list.
- (if (stringp larg)
- (setq larg (semantic-tag-new-variable
- larg nil nil)))
- ;; Apply the sub-argument to the subdictionary.
- (srecode-semantic-apply-tag-to-dict
- (srecode-semantic-tag (semantic-tag-name larg)
- :prime larg)
- subdict)
- )
- ;; Next!
- (setq args (cdr args))))
- ;; PARENTS
- (let ((p (semantic-tag-function-parent tag)))
- (when p
- (srecode-dictionary-set-value dict "PARENT" p)
- ))
- ;; EXCEPTIONS (java/c++)
- (let ((exceptions (semantic-tag-get-attribute tag :throws)))
- (while exceptions
- (let ((subdict (srecode-dictionary-add-section-dictionary
- dict "THROWS")))
- (srecode-dictionary-set-value subdict "NAME" (car exceptions))
- )
- (setq exceptions (cdr exceptions)))
- )
- )
- ;;
- ;; VARIABLE
- ;;
- ((eq (semantic-tag-class tag) 'variable)
- (when (semantic-tag-variable-default tag)
- (let ((subdict (srecode-dictionary-add-section-dictionary
- dict "HAVEDEFAULT")))
- (srecode-dictionary-set-value
- subdict "VALUE" (semantic-tag-variable-default tag))))
- )
- ;;
- ;; TYPE
- ;;
- ((eq (semantic-tag-class tag) 'type)
- (dolist (p (semantic-tag-type-superclasses tag))
- (let ((sd (srecode-dictionary-add-section-dictionary
- dict "PARENTS")))
- (srecode-dictionary-set-value sd "NAME" p)
- ))
- (dolist (i (semantic-tag-type-interfaces tag))
- (let ((sd (srecode-dictionary-add-section-dictionary
- dict "INTERFACES")))
- (srecode-dictionary-set-value sd "NAME" i)
- ))
-; NOTE : The members are too complicated to do via a template.
-; do it via the insert-tag solution instead.
-;
-; (dolist (mem (semantic-tag-type-members tag))
-; (let ((subdict (srecode-dictionary-add-section-dictionary
-; dict "MEMBERS")))
-; (when (stringp mem)
-; (setq mem (semantic-tag-new-variable mem nil nil)))
-; (srecode-semantic-apply-tag-to-dict
-; (srecode-semantic-tag (semantic-tag-name mem)
-; :prime mem)
-; subdict)))
- ))))
-
-\f
-;;; ARGUMENT HANDLERS
-
-;;; :tag ARGUMENT HANDLING
-;;
-;; When a :tag argument is required, identify the current :tag,
-;; and apply its parts into the dictionary.
-(defun srecode-semantic-handle-:tag (dict)
- "Add macros into the dictionary DICT based on the current :tag."
- ;; We have a tag, start adding "stuff" into the dictionary.
- (let ((tag (or srecode-semantic-selected-tag
- (srecode-semantic-tag-from-kill-ring))))
- (when (not tag)
- (error "No tag for current template. Use the semantic kill-ring"))
- (srecode-semantic-apply-tag-to-dict
- (srecode-semantic-tag (semantic-tag-name tag)
- :prime tag)
- dict)))
-
-;;; :tagtype ARGUMENT HANDLING
-;;
-;; When a :tagtype argument is required, identify the current tag, of
-;; class 'type'. Apply those parameters to the dictionary.
-
-(defun srecode-semantic-handle-:tagtype (dict)
- "Add macros into the dictionary DICT based on a tag of class type at point.
-Assumes the cursor is in a tag of class type. If not, throw an error."
- (let ((typetag (or srecode-semantic-selected-tag
- (semantic-current-tag-of-class 'type))))
- (when (not typetag)
- (error "Cursor is not in a TAG of class `type'"))
- (srecode-semantic-apply-tag-to-dict
- typetag
- dict)))
-
-\f
-;;; INSERT A TAG API
-;;
-;; Routines that take a tag, and insert into a buffer.
-(define-overloadable-function srecode-semantic-find-template (class prototype ctxt)
- "Find a template for a tag of class CLASS based on context.
-PROTOTYPE is non-nil if we want a prototype template instead."
- )
-
-(defun srecode-semantic-find-template-default (class prototype ctxt)
- "Find a template for tag CLASS based on context.
-PROTOTYPE is non-nil if we need a prototype.
-CTXT is the pre-calculated context."
- (let* ((top (car ctxt))
- (tname (if (stringp class)
- class
- (symbol-name class)))
- (temp nil)
- )
- ;; Try to find a template.
- (setq temp (or
- (when prototype
- (srecode-template-get-table (srecode-table)
- (concat tname "-tag-prototype")
- top))
- (when prototype
- (srecode-template-get-table (srecode-table)
- (concat tname "-prototype")
- top))
- (srecode-template-get-table (srecode-table)
- (concat tname "-tag")
- top)
- (srecode-template-get-table (srecode-table)
- tname
- top)
- (when (and (not (string= top "declaration"))
- prototype)
- (srecode-template-get-table (srecode-table)
- (concat tname "-prototype")
- "declaration"))
- (when (and (not (string= top "declaration"))
- prototype)
- (srecode-template-get-table (srecode-table)
- (concat tname "-tag-prototype")
- "declaration"))
- (when (not (string= top "declaration"))
- (srecode-template-get-table (srecode-table)
- (concat tname "-tag")
- "declaration"))
- (when (not (string= top "declaration"))
- (srecode-template-get-table (srecode-table)
- tname
- "declaration"))
- ))
- temp))
-
-(defun srecode-semantic-insert-tag (tag &optional style-option
- point-insert-fcn
- &rest dict-entries)
- "Insert TAG into a buffer using srecode templates at point.
-
-Optional STYLE-OPTION is a list of minor configuration of styles,
-such as the symbol `prototype' for prototype functions, or
-`system' for system includes, and `doxygen', for a doxygen style
-comment.
-
-Optional third argument POINT-INSERT-FCN is a hook that is run after
-TAG is inserted that allows an opportunity to fill in the body of
-some thing. This hook function is called with one argument, the TAG
-being inserted.
-
-The rest of the arguments are DICT-ENTRIES. DICT-ENTRIES
-is of the form ( NAME1 VALUE1 NAME2 VALUE2 ... NAMEn VALUEn).
-
-The exact template used is based on the current context.
-The template used is found within the toplevel context as calculated
-by `srecode-calculate-context', such as `declaration', `classdecl',
-or `code'.
-
-For various conditions, this function looks for a template with
-the name CLASS-tag, where CLASS is the tag class. If it cannot
-find that, it will look for that template in the `declaration'
-context (if the current context was not `declaration').
-
-If PROTOTYPE is specified, it will first look for templates with
-the name CLASS-tag-prototype, or CLASS-prototype as above.
-
-See `srecode-semantic-apply-tag-to-dict' for details on what is in
-the dictionary when the templates are called.
-
-This function returns to location in the buffer where the
-inserted tag ENDS, and will leave point inside the inserted
-text based on any occurrence of a point-inserter. Templates such
-as `function' will leave point where code might be inserted."
- (srecode-load-tables-for-mode major-mode)
- (let* ((ctxt (srecode-calculate-context))
- (top (car ctxt))
- (tname (symbol-name (semantic-tag-class tag)))
- (dict (srecode-create-dictionary))
- (temp nil)
- (errtype tname)
- (prototype (memq 'prototype style-option))
- )
- ;; Try some special cases.
- (cond ((and (semantic-tag-of-class-p tag 'function)
- (semantic-tag-get-attribute tag :constructor-flag))
- (setq temp (srecode-semantic-find-template
- "constructor" prototype ctxt))
- )
-
- ((and (semantic-tag-of-class-p tag 'function)
- (semantic-tag-get-attribute tag :destructor-flag))
- (setq temp (srecode-semantic-find-template
- "destructor" prototype ctxt))
- )
-
- ((and (semantic-tag-of-class-p tag 'function)
- (semantic-tag-function-parent tag))
- (setq temp (srecode-semantic-find-template
- "method" prototype ctxt))
- )
-
- ((and (semantic-tag-of-class-p tag 'variable)
- (semantic-tag-get-attribute tag :constant-flag))
- (setq temp (srecode-semantic-find-template
- "variable-const" prototype ctxt))
- )
-
- ((and (semantic-tag-of-class-p tag 'include)
- (semantic-tag-get-attribute tag :system-flag))
- (setq temp (srecode-semantic-find-template
- "system-include" prototype ctxt))
- )
- )
-
- (when (not temp)
- ;; Try the basics
- (setq temp (srecode-semantic-find-template
- tname prototype ctxt)))
-
- ;; Try some backup template names.
- (when (not temp)
- (cond
- ;; Types might split things up based on the type's type.
- ((and (eq (semantic-tag-class tag) 'type)
- (semantic-tag-type tag))
- (setq temp (srecode-semantic-find-template
- (semantic-tag-type tag) prototype ctxt))
- (setq errtype (concat errtype " or " (semantic-tag-type tag)))
- )
- ;; A function might be an externally declared method.
- ((and (eq (semantic-tag-class tag) 'function)
- (semantic-tag-function-parent tag))
- (setq temp (srecode-semantic-find-template
- "method" prototype ctxt)))
- (t
- nil)
- ))
-
- ;; Can't find one? Drat!
- (when (not temp)
- (error "Cannot find template %s in %s for inserting tag %S"
- errtype top (semantic-format-tag-summarize tag)))
-
- ;; Resolve arguments
- (let ((srecode-semantic-selected-tag tag))
- (srecode-resolve-arguments temp dict))
-
- ;; Resolve TAG into the dictionary. We may have a :tag arg
- ;; from the macro such that we don't need to do this.
- (when (not (srecode-dictionary-lookup-name dict "TAG"))
- (let ((tagobj (srecode-semantic-tag (semantic-tag-name tag) :prime tag))
- )
- (srecode-semantic-apply-tag-to-dict tagobj dict)))
-
- ;; Insert dict-entries into the dictionary LAST so that previous
- ;; items can be overridden.
- (let ((entries dict-entries))
- (while entries
- (srecode-dictionary-set-value dict
- (car entries)
- (car (cdr entries)))
- (setq entries (cdr (cdr entries)))))
-
- ;; Insert the template.
- (let ((endpt (srecode-insert-fcn temp dict nil t)))
-
- (if (functionp point-insert-fcn)
- (funcall point-insert-fcn tag)
- (dolist (f point-insert-fcn) (funcall f tag)))
- ;;(sit-for 1)
-
- (cond
- ((semantic-tag-of-class-p tag 'type)
- ;; Insert all the members at the current insertion point.
- (dolist (m (semantic-tag-type-members tag))
-
- (when (stringp m)
- (setq m (semantic-tag-new-variable m nil nil)))
-
- ;; We do prototypes w/in the class decl?
- (let ((me (srecode-semantic-insert-tag m '(prototype))))
- (goto-char me))
-
- ))
- )
-
- endpt)
- ))
-
-(provide 'srecode/semantic)
-
-;;; srecode/semantic.el ends here
+++ /dev/null
-;;; srecode/srt-mode.el --- Major mode for writing screcode macros -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2005, 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Originally named srecode-template-mode.el in the CEDET repository.
-
-(require 'srecode/compile)
-(require 'srecode/ctxt)
-(require 'srecode/template)
-
-(require 'semantic)
-(require 'semantic/analyze)
-(require 'semantic/wisent)
-(eval-when-compile
- (require 'semantic/find))
-
-(declare-function srecode-create-dictionary "srecode/dictionary")
-(declare-function srecode-resolve-argument-list "srecode/insert")
-(declare-function srecode-inserter-prin-example "srecode/insert")
-
-;;; Code:
-(defvar srecode-template-mode-syntax-table
- (let ((table (make-syntax-table (standard-syntax-table))))
- (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
- (modify-syntax-entry ?\n ">" table) ;; Comment end
- (modify-syntax-entry ?$ "." table) ;; Punctuation
- (modify-syntax-entry ?: "." table) ;; Punctuation
- (modify-syntax-entry ?< "." table) ;; Punctuation
- (modify-syntax-entry ?> "." table) ;; Punctuation
- (modify-syntax-entry ?# "." table) ;; Punctuation
- (modify-syntax-entry ?! "." table) ;; Punctuation
- (modify-syntax-entry ?? "." table) ;; Punctuation
- (modify-syntax-entry ?\" "\"" table) ;; String
- (modify-syntax-entry ?\- "_" table) ;; Symbol
- (modify-syntax-entry ?\\ "\\" table) ;; Quote
- (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
- (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
- (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
-
- table)
- "Syntax table used in semantic recoder macro buffers.")
-
-(defface srecode-separator-face
- '((t (:weight bold :strike-through t)))
- "Face used for decorating separators in srecode template mode."
- :group 'srecode)
-
-(defvar srecode-font-lock-keywords
- '(
- ;; Template
- ("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\)*\\)$"
- (1 font-lock-keyword-face)
- (2 font-lock-function-name-face)
- (3 font-lock-builtin-face ))
- ("^\\(sectiondictionary\\)\\s-+\""
- (1 font-lock-keyword-face))
- ("^\\s\s*\\(section\\)\\s-+\""
- (1 font-lock-keyword-face))
- ("^\\s\s*\\(end\\)"
- (1 font-lock-keyword-face))
- ("^\\(bind\\)\\s-+\""
- (1 font-lock-keyword-face))
- ;; Variable type setting
- ("^\\s\s*\\(set\\)\\s-+\\(\\w+\\)\\s-+"
- (1 font-lock-keyword-face)
- (2 font-lock-variable-name-face))
- ("^\\s\s*\\(show\\)\\s-+\\(\\w+\\)\\s-*$"
- (1 font-lock-keyword-face)
- (2 font-lock-variable-name-face))
- ("\\<\\(macro\\)\\s-+\""
- (1 font-lock-keyword-face))
- ;; Context type setting
- ("^\\(context\\)\\s-+\\(\\w+\\)"
- (1 font-lock-keyword-face)
- (2 font-lock-builtin-face))
- ;; Prompting setting
- ("^\\(prompt\\)\\s-+\\(\\w+\\)"
- (1 font-lock-keyword-face)
- (2 font-lock-variable-name-face))
- ("\\(default\\(macro\\)?\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
- (1 font-lock-keyword-face)
- (3 font-lock-type-face))
- ("\\<\\(default\\(macro\\)?\\)\\>" (1 font-lock-keyword-face))
- ("\\<\\(read\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
- (1 font-lock-keyword-face)
- (2 font-lock-type-face))
-
- ;; Macro separators
- ("^----\n" 0 'srecode-separator-face)
-
- ;; Macro Matching
- (srecode-template-mode-macro-escape-match 1 font-lock-string-face)
- ((lambda (limit)
- (srecode-template-mode-font-lock-macro-helper
- limit "\\(\\??\\w+\\)[^ \t\n{}$#@&*()]*"))
- 1 font-lock-variable-name-face)
- ((lambda (limit)
- (srecode-template-mode-font-lock-macro-helper
- limit "\\([#/]\\w+\\)[^ \t\n{}$#@&*()]*"))
- 1 font-lock-keyword-face)
- ((lambda (limit)
- (srecode-template-mode-font-lock-macro-helper
- limit "\\([<>]\\w*\\):\\(\\w+\\):\\(\\w+\\)"))
- (1 font-lock-keyword-face)
- (2 font-lock-builtin-face)
- (3 font-lock-type-face))
- ((lambda (limit)
- (srecode-template-mode-font-lock-macro-helper
- limit "\\([<>?]?\\w*\\):\\(\\w+\\)"))
- (1 font-lock-keyword-face)
- (2 font-lock-type-face))
- ((lambda (limit)
- (srecode-template-mode-font-lock-macro-helper
- limit "!\\([^{}$]*\\)"))
- 1 font-lock-comment-face)
-
- )
- "Keywords for use with srecode macros and font-lock.")
-
-(defun srecode-template-mode-font-lock-macro-helper (limit expression)
- "Match against escape characters.
-Don't scan past LIMIT. Match with EXPRESSION."
- (let* ((done nil)
- (md nil)
- (es (regexp-quote (srecode-template-get-escape-start)))
- (ee (regexp-quote (srecode-template-get-escape-end)))
- (regex (concat es expression ee))
- )
- (while (not done)
- (save-match-data
- (if (re-search-forward regex limit t)
- (when (equal (car (srecode-calculate-context)) "code")
- (setq md (match-data)
- done t))
- (setq done t))))
- (set-match-data md)
- ;; (when md (message "Found a match!"))
- (when md t)))
-
-(defun srecode-template-mode-macro-escape-match (limit)
- "Match against escape characters.
-Don't scan past LIMIT."
- (let* ((done nil)
- (md nil)
- (es (regexp-quote (srecode-template-get-escape-start)))
- (ee (regexp-quote (srecode-template-get-escape-end)))
- (regex (concat "\\(" es "\\|" ee "\\)"))
- )
- (while (not done)
- (save-match-data
- (if (re-search-forward regex limit t)
- (when (equal (car (srecode-calculate-context)) "code")
- (setq md (match-data)
- done t))
- (setq done t))))
- (set-match-data md)
- ;;(when md (message "Found a match!"))
- (when md t)))
-
-(defvar srecode-font-lock-macro-keywords nil
- "Dynamically generated `font-lock' keywords for srecode templates.
-Once the escape_start, and escape_end sequences are known, then
-we can tell font lock about them.")
-
-(defvar-keymap srecode-template-mode-map
- :doc "Keymap used in srecode mode."
- "C-c C-c" #'srecode-compile-templates
- "C-c C-m" #'srecode-macro-help
- "/" #'srecode-self-insert-complete-end-macro)
-
-;;;###autoload
-(define-derived-mode srecode-template-mode fundamental-mode "SRecode"
- ;; FIXME: Shouldn't it derive from prog-mode?
- "Major-mode for writing SRecode macros."
- (setq-local comment-start ";;")
- (setq-local comment-end "")
- (setq-local parse-sexp-ignore-comments t)
- (setq-local comment-start-skip
- "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
- (setq-local font-lock-defaults
- '(srecode-font-lock-keywords
- nil ;; perform string/comment fontification
- nil ;; keywords are case sensitive.
- ;; This puts _ & - as a word constituent,
- ;; simplifying our keywords significantly
- ((?_ . "w") (?- . "w")))))
-
-;;;###autoload
-(defalias 'srt-mode #'srecode-template-mode)
-
-;;; Template Commands
-;;
-(defun srecode-self-insert-complete-end-macro ()
- "Self insert the current key, then autocomplete the end macro."
- (interactive)
- (call-interactively 'self-insert-command)
- (when (and (semantic-current-tag)
- (semantic-tag-of-class-p (semantic-current-tag) 'function)
- )
- (let* ((es (srecode-template-get-escape-start))
- (ee (srecode-template-get-escape-end))
- (name (save-excursion
- (forward-char (- (length es)))
- (forward-char -1)
- (if (looking-at (regexp-quote es))
- (srecode-up-context-get-name (point) t))))
- )
- (when name
- (insert name)
- (insert ee))))
- )
-
-(eieio-declare-slots key)
-
-(defun srecode-macro-help ()
- "Provide help for working with macros in a template."
- (interactive)
- (require 'srecode/insert)
- (let* ((root 'srecode-template-inserter)
- (chl (eieio-class-children root))
- (ess (srecode-template-get-escape-start))
- (ees (srecode-template-get-escape-end))
- )
- (with-output-to-temp-buffer "*SRecode Macros*"
- (princ "Description of known SRecode Template Macros.")
- (terpri)
- (terpri)
- (while chl
- (let* ((C (car chl))
- (name (symbol-name C))
- (key (when (slot-exists-p C 'key)
- (oref C key)))
- (showexample t))
- (setq chl (cdr chl))
- (setq chl (append (eieio-class-children C) chl))
-
- (catch 'skip
- (when (eq C 'srecode-template-inserter-section-end)
- (throw 'skip nil))
-
- (when (class-abstract-p C)
- (throw 'skip nil))
-
- (princ (substitute-quotes "`"))
- (princ name)
- (princ (substitute-quotes "'"))
- (when (slot-exists-p C 'key)
- (when key
- (princ " - Character Key: ")
- (if (stringp key)
- (progn
- (setq showexample nil)
- (cond ((string= key "\n")
- (princ "\"\\n\"")
- )
- (t
- (prin1 key)
- )))
- (prin1 (format "%c" key))
- )))
- (terpri)
- (princ (documentation-property C 'variable-documentation))
- (terpri)
- (when showexample
- (princ "Example:")
- (terpri)
- (srecode-inserter-prin-example C ess ees)
- )
-
- (terpri)
-
- ) ;; catch
- );; let*
- ))))
-
-\f
-;;; Misc Language Overrides
-;;
-(define-mode-local-override semantic-ia-insert-tag
- srecode-template-mode (tag)
- "Insert the SRecode TAG into the current buffer."
- (insert (semantic-tag-name tag)))
-
-\f
-;;; Local Context Parsing.
-
-(defun srecode-in-macro-p (&optional point)
- "Non-nil if POINT is inside a macro bounds.
-If the ESCAPE_START and END are different sequences,
-a simple search is used. If ESCAPE_START and END are the same
-characters, start at the beginning of the line, and find out
-how many occur."
- (let ((tag (semantic-current-tag))
- (es (regexp-quote (srecode-template-get-escape-start)))
- (ee (regexp-quote (srecode-template-get-escape-end)))
- (start (or point (point)))
- )
- (when (and tag (semantic-tag-of-class-p tag 'function))
- (if (string= es ee)
- (save-excursion
- (beginning-of-line)
- (while (re-search-forward es start t 2))
- (if (re-search-forward es start t)
- ;; If there is a single, the answer is yes.
- t
- ;; If there wasn't another, then the answer is no.
- nil)
- )
- ;; ES And EE are not the same.
- (save-excursion
- (and (re-search-backward es (semantic-tag-start tag) t)
- (>= (or (re-search-forward ee (semantic-tag-end tag) t)
- ;; No end match means an incomplete macro.
- start)
- start)))
- ))))
-
-(defun srecode-up-context-get-name (&optional point find-unmatched)
- "Move up one context as for `semantic-up-context', and return the name.
-Moves point to the opening characters of the section macro text.
-If there is no upper context, return nil.
-Starts at POINT if provided.
-If FIND-UNMATCHED is specified as non-nil, then we are looking for an unmatched
-section."
- (when point (goto-char (point)))
- (let* ((tag (semantic-current-tag))
- (es (regexp-quote (srecode-template-get-escape-start)))
- (start (concat es "[#<]\\(\\w+\\)"))
- (orig (point))
- (name nil)
- (res nil))
- (when (semantic-tag-of-class-p tag 'function)
- (while (and (not res)
- (re-search-backward start (semantic-tag-start tag) t))
- (when (save-excursion
- (setq name (match-string 1))
- (let ((endr (concat es "/" name)))
- (if (re-search-forward endr (semantic-tag-end tag) t)
- (< orig (point))
- (if (not find-unmatched)
- (error "Unmatched Section Template")
- ;; We found what we want.
- t))))
- (setq res (point)))
- )
- ;; Restore in no result found.
- (goto-char (or res orig))
- name)))
-
-(define-mode-local-override semantic-up-context
- srecode-template-mode (&optional point)
- "Move up one context in the current code.
-Moves out one named section."
- (not (srecode-up-context-get-name point)))
-
-(define-mode-local-override semantic-beginning-of-context
- srecode-template-mode (&optional point)
- "Move to the beginning of the current context.
-Moves to the beginning of one named section."
- (if (semantic-up-context point)
- t
- (let ((es (regexp-quote (srecode-template-get-escape-start)))
- (ee (regexp-quote (srecode-template-get-escape-end))))
- (re-search-forward es) ;; move over the start chars.
- (re-search-forward ee) ;; Move after the end chars.
- nil)))
-
-(define-mode-local-override semantic-end-of-context
- srecode-template-mode (&optional point)
- "Move to the end of the current context.
-Moves to the end of one named section."
- (let ((name (srecode-up-context-get-name point))
- (tag (semantic-current-tag))
- (es (regexp-quote (srecode-template-get-escape-start))))
- (if (not name)
- t
- (unless (re-search-forward (concat es "/" name) (semantic-tag-end tag) t)
- (error "Section %s has no end" name))
- (goto-char (match-beginning 0))
- nil)))
-
-(define-mode-local-override semantic-get-local-variables
- srecode-template-mode (&optional point)
- "Get local variables from an SRecode template."
- (save-excursion
- (when point (goto-char (point)))
- (let* ((tag (semantic-current-tag))
- (name (save-excursion
- (srecode-up-context-get-name (point))))
- (subdicts (semantic-tag-get-attribute tag :dictionaries))
- (global nil)
- )
- (dolist (D subdicts)
- (setq global (cons (semantic-tag-new-variable (car D) nil)
- global)))
- (if name
- ;; Lookup any subdictionaries in TAG.
- (let ((res nil))
-
- (while (and (not res) subdicts)
- ;; Find the subdictionary with the same name. Those variables
- ;; are now local to this section.
- (when (string= (car (car subdicts)) name)
- (setq res (cdr (car subdicts))))
- (setq subdicts (cdr subdicts)))
- ;; Prepend our global vars.
- (append global res))
- ;; If we aren't in a subsection, just do the global variables
- global
- ))))
-
-(define-mode-local-override semantic-get-local-arguments
- srecode-template-mode (&optional point)
- "Get local arguments from an SRecode template."
- (require 'srecode/insert)
- (save-excursion
- (when point (goto-char (point)))
- (let* ((tag (semantic-current-tag))
- (args (semantic-tag-function-arguments tag))
- (argsym (mapcar #'intern args))
- (argvars nil)
- ;; Create a temporary dictionary in which the
- ;; arguments can be resolved so we can extract
- ;; the results.
- (dict (srecode-create-dictionary t))
- )
- ;; Resolve args into our temp dictionary
- (srecode-resolve-argument-list argsym dict)
-
- (maphash
- (lambda (key entry)
- (setq argvars
- (cons (semantic-tag-new-variable key nil entry)
- argvars)))
- (oref dict namehash))
-
- argvars)))
-
-(define-mode-local-override semantic-ctxt-current-symbol
- srecode-template-mode (&optional point)
- "Return the current symbol under POINT.
-Return nil if point is not on/in a template macro."
- (let ((macro (srecode-parse-this-macro point)))
- (cdr macro))
- )
-
-(defun srecode-parse-this-macro (&optional point)
- "Return the current symbol under POINT.
-Return nil if point is not on/in a template macro.
-The first element is the key for the current macro, such as # for a
-section or ? for an ask variable."
- (save-excursion
- (if point (goto-char point))
- (let ((tag (semantic-current-tag))
- (es (regexp-quote (srecode-template-get-escape-start)))
- (ee (regexp-quote (srecode-template-get-escape-end)))
- (start (point))
- (macrostart nil)
- ;; (raw nil)
- )
- (when (and tag (semantic-tag-of-class-p tag 'function)
- (srecode-in-macro-p point)
- (re-search-backward es (semantic-tag-start tag) t))
- (setq macrostart (match-end 0))
- (goto-char macrostart)
- ;; We have a match
- (when (not (re-search-forward ee (semantic-tag-end tag) t))
- (goto-char start) ;; Pretend we are ok for completion
- (set-match-data (list start start))
- )
-
- (if (> start (point))
- ;; If our starting point is after the found point, that
- ;; means we are not inside the macro. Return nil.
- nil
- ;; We are inside the macro, extract the text so far.
- (let* ((macroend (match-beginning 0))
- (raw (buffer-substring-no-properties
- macrostart macroend))
- (STATE (srecode-compile-state))
- (inserter (condition-case nil
- (srecode-compile-parse-inserter
- raw STATE)
- (error nil)))
- )
- (when inserter
- (let ((base
- (cons (oref inserter object-name)
- (if (and (slot-boundp inserter :secondname)
- (oref inserter secondname))
- (split-string (oref inserter secondname)
- ":")
- nil)))
- (key (when (slot-exists-p inserter 'key)
- (oref inserter key))))
- (cond ((null key)
- ;; A plain variable
- (cons nil base))
- (t
- ;; A complex variable thingy.
- (cons (format "%c" key)
- base)))))
- )
- )))
- ))
-
-(define-mode-local-override semantic-analyze-current-context
- srecode-template-mode (point)
- "Provide a Semantic analysis in SRecode template mode."
- (let* ((context-return nil)
- (prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
- (prefix (car prefixandbounds))
- (bounds (nth 2 prefixandbounds))
- (key (car (srecode-parse-this-macro (point))))
- (prefixsym nil)
- (prefix-var nil)
- (prefix-context nil)
- (prefix-function nil)
- (prefixclass (semantic-ctxt-current-class-list))
- (globalvar (semantic-find-tags-by-class 'variable (current-buffer)))
- (argtype 'macro)
- (scope (semantic-calculate-scope point))
- )
-
- (oset scope fullscope (append (oref scope localvar) globalvar))
-
- (when prefix
- ;; First, try to find the variable for the first
- ;; entry in the prefix list.
- (setq prefix-var (semantic-find-first-tag-by-name
- (car prefix) (oref scope fullscope)))
-
- (cond
- ((and (or (not key) (string= key "?"))
- (> (length prefix) 1))
- ;; Variables can have lisp function names.
- (with-mode-local emacs-lisp-mode
- (let ((fcns (semanticdb-find-tags-by-name (car (last prefix)))))
- (setq prefix-function (car (semanticdb-find-result-nth fcns 0)))
- (setq argtype 'elispfcn)))
- )
- ((or (string= key "<") (string= key ">"))
- ;; Includes have second args that is the template name.
- (if (= (length prefix) 3)
- (let ((contexts (semantic-find-tags-by-class
- 'context (current-buffer))))
- (setq prefix-context
- (or (semantic-find-first-tag-by-name
- (nth 1 prefix) contexts)
- ;; Calculate from location
- (semantic-tag
- (symbol-name
- (srecode-template-current-context))
- 'context)))
- (setq argtype 'template))
- (setq prefix-context
- ;; Calculate from location
- (semantic-tag
- (symbol-name (srecode-template-current-context))
- 'context))
- (setq argtype 'template)
- )
- ;; The last one?
- (when (> (length prefix) 1)
- (let ((toc (srecode-template-find-templates-of-context
- (read (semantic-tag-name prefix-context))))
- )
- (setq prefix-function
- (or (semantic-find-first-tag-by-name
- (car (last prefix)) toc)
- ;; Not in this buffer? Search the master
- ;; templates list.
- nil))
- ))
- )
- )
-
- (setq prefixsym
- (cond ((= (length prefix) 3)
- (list (or prefix-var (nth 0 prefix))
- (or prefix-context (nth 1 prefix))
- (or prefix-function (nth 2 prefix))))
- ((= (length prefix) 2)
- (list (or prefix-var (nth 0 prefix))
- (or prefix-function (nth 1 prefix))))
- ((= (length prefix) 1)
- (list (or prefix-var (nth 0 prefix)))
- )))
-
- (setq context-return
- (semantic-analyze-context-functionarg
- :buffer (current-buffer)
- :scope scope
- :bounds bounds
- :prefix (or prefixsym
- prefix)
- :prefixtypes nil
- :prefixclass prefixclass
- :errors nil
- ;; Use the functionarg analyzer class so we
- ;; can save the current key, and the index
- ;; into the macro part we are completing on.
- :function (list key)
- :index (length prefix)
- :argument (list argtype)
- ))
-
- context-return)))
-
-(define-mode-local-override semantic-analyze-possible-completions
- srecode-template-mode (context &rest _flags)
- "Return a list of possible completions based on NONTEXT."
- (with-current-buffer (oref context buffer)
- (let* ((prefix (car (last (oref context prefix))))
- (prefixstr (cond ((stringp prefix)
- prefix)
- ((semantic-tag-p prefix)
- (semantic-tag-name prefix))))
-; (completetext (cond ((semantic-tag-p prefix)
-; (semantic-tag-name prefix))
-; ((stringp prefix)
-; prefix)
-; ((stringp (car prefix))
-; (car prefix))))
- (argtype (car (oref context argument)))
- (matches nil))
-
- ;; Depending on what the analyzer is, we have different ways
- ;; of creating completions.
- (cond ((eq argtype 'template)
- (setq matches (semantic-find-tags-for-completion
- prefixstr (current-buffer)))
- (setq matches (semantic-find-tags-by-class
- 'function matches))
- )
- ((eq argtype 'elispfcn)
- (with-mode-local emacs-lisp-mode
- (setq matches (semanticdb-find-tags-for-completion
- prefixstr))
- (setq matches (semantic-find-tags-by-class
- 'function matches))
- )
- )
- ((eq argtype 'macro)
- (let ((scope (oref context scope)))
- (setq matches
- (semantic-find-tags-for-completion
- prefixstr (oref scope fullscope))))
- )
- )
-
- matches)))
-
-
-\f
-;;; Utils
-;;
-(defun srecode-template-get-mode ()
- "Get the supported major mode for this template file."
- (let ((m (semantic-find-first-tag-by-name "mode" (current-buffer))))
- (when m (read (semantic-tag-variable-default m)))))
-
-(defun srecode-template-get-escape-start ()
- "Get the current escape_start characters."
- (let ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
- )
- (if es (car (semantic-tag-get-attribute es :default-value))
- "{{")))
-
-(defun srecode-template-get-escape-end ()
- "Get the current escape_end characters."
- (let ((ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
- )
- (if ee (car (semantic-tag-get-attribute ee :default-value))
- "}}")))
-
-(defun srecode-template-current-context (&optional point)
- "Calculate the context encompassing POINT."
- (save-excursion
- (when point (goto-char (point)))
- (let ((ct (semantic-current-tag)))
- (when (not ct)
- (setq ct (semantic-find-tag-by-overlay-prev)))
-
- ;; Loop till we find the context.
- (while (and ct (not (semantic-tag-of-class-p ct 'context)))
- (setq ct (semantic-find-tag-by-overlay-prev
- (semantic-tag-start ct))))
-
- (if ct
- (read (semantic-tag-name ct))
- 'declaration))))
-
-(defun srecode-template-find-templates-of-context (context &optional buffer)
- "Find all the templates belonging to a particular CONTEXT.
-When optional BUFFER is provided, search that buffer."
- (save-excursion
- (when buffer (set-buffer buffer))
- (let ((tags (semantic-fetch-available-tags))
- (cc 'declaration)
- (scan nil)
- (ans nil))
-
- (when (eq cc context)
- (setq scan t))
-
- (dolist (T tags)
- ;; Handle contexts
- (when (semantic-tag-of-class-p T 'context)
- (setq cc (read (semantic-tag-name T)))
- (when (eq cc context)
- (setq scan t)))
-
- ;; Scan
- (when (and scan (semantic-tag-of-class-p T 'function))
- (setq ans (cons T ans)))
- )
-
- (nreverse ans))))
-
-(provide 'srecode/srt-mode)
-
-;; The autoloads in this file must go into the global loaddefs.el, not
-;; the srecode one, so that srecode-template-mode can be called from
-;; auto-mode-alist.
-
-;; Local variables:
-;; generated-autoload-load-name: "srecode/srt-mode"
-;; End:
-
-;;; srecode/srt-mode.el ends here
+++ /dev/null
-;;; srecode/srt.el --- argument handlers for SRT files -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Filters for SRT files, the Semantic Recoder template files.
-
-;;; Code:
-
-(require 'eieio)
-(require 'srecode/dictionary)
-(require 'srecode/insert)
-
-(defvar srecode-read-variable-name-history nil
- "History for `srecode-read-variable-name'.")
-
-(defun srecode-read-variable-name (prompt &optional initial hist default)
- "Read in the name of a declared variable in the current SRT file.
-PROMPT is the prompt to use.
-INITIAL is the initial string.
-HIST is the history value, otherwise `srecode-read-variable-name-history'
- is used.
-DEFAULT is the default if RET is hit."
- (let* ((newdict (srecode-create-dictionary))
- (currfcn (semantic-current-tag))
- )
- (srecode-resolve-argument-list
- (mapcar #'read
- (semantic-tag-get-attribute currfcn :arguments))
- newdict)
-
- (with-slots (namehash) newdict
- (completing-read prompt namehash nil nil initial
- (or hist 'srecode-read-variable-name-history)
- default))
- ))
-
-(defvar srecode-read-major-mode-history nil
- "History for `srecode-read-variable-name'.")
-
-(defun srecode-read-major-mode-name (prompt &optional initial hist _default)
- "Read in the name of a desired `major-mode'.
-PROMPT is the prompt to use.
-INITIAL is the initial string.
-HIST is the history value, otherwise `srecode-read-variable-name-history'
- is used.
-DEFAULT is the default if RET is hit."
- (completing-read prompt obarray
- (lambda (s) (string-match "-mode\\'" (symbol-name s)))
- nil initial (or hist 'srecode-read-major-mode-history))
- )
-
-;;;###autoload
-(defun srecode-semantic-handle-:srt (dict)
- "Add macros into the dictionary DICT based on the current SRT file.
-Adds the following:
-ESCAPE_START - This files value of escape_start
-ESCAPE_END - This files value of escape_end
-MODE - The mode of this buffer. If not declared yet, guess."
- (let* ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
- (ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
- (mode-var (semantic-find-first-tag-by-name "mode" (current-buffer)))
- (mode (if mode-var
- (semantic-tag-variable-default mode-var)
- nil))
- )
- (srecode-dictionary-set-value dict "ESCAPE_START"
- (if es
- (car (semantic-tag-variable-default es))
- "{{"))
- (srecode-dictionary-set-value dict "ESCAPE_END"
- (if ee
- (car (semantic-tag-variable-default ee))
- "}}"))
- (when (not mode)
- (let* ((fname (file-name-nondirectory
- (buffer-file-name (current-buffer))))
- )
- (when (string-match "-\\(\\w+\\)\\.srt" fname)
- (setq mode (concat (match-string 1 fname) "-mode")))))
-
- (when mode
- (srecode-dictionary-set-value dict "MAJORMODE" mode))
-
- ))
-
-(provide 'srecode/srt)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/srt"
-;; End:
-
-;;; srecode/srt.el ends here
+++ /dev/null
-;;; srecode/table.el --- Tables of Semantic Recoders -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic Recoder tables manage lists of templates and the major
-;; modes they are associated with.
-;;
-
-(require 'eieio)
-(require 'cl-generic)
-(require 'eieio-base)
-(require 'mode-local)
-(require 'srecode)
-
-(declare-function srecode-load-tables-for-mode "srecode/find")
-(declare-function srecode-template-table-in-project-p "srecode/find")
-
-;;; Code:
-
-;;; TEMPLATE TABLE
-;;
-(defclass srecode-template-table ()
- (;;
- ;; Raw file tracking
- ;;
- (file :initarg :file
- :type string
- :documentation
- "The name of the file this table was built from.")
- (filesize :initarg :filesize
- :type number
- :documentation
- "The size of the file when it was parsed.")
- (filedate :initarg :filedate
- :type cons
- :documentation
- "Date from the inode of the file when it was last edited.
-Format is from the `file-attributes' function.")
- (major-mode :initarg :major-mode
- :documentation
- "The major mode this table of templates is associated with.")
- ;;
- ;; Template file sorting data
- ;;
- (application :initarg :application
- :type symbol
- :documentation
- "Tracks the name of the application these templates belong to.
-If this is nil, then this template table belongs to a set of generic
-templates that can be used with no additional dictionary values.
-When it is non-nil, it is assumed the template macros need specialized
-Emacs Lisp code to fill in the dictionary.")
- (framework :initarg :framework
- :type symbol
- :documentation
- "Tracks the name of the framework these templates belong to.
-If nil, then this template table belongs to any framework, or can be
-considered generic for all files of this language.
-A framework might be a specific library or build environment for which
-special templates are desired. OpenGL might be a framework that
-exists for multiple languages.")
- (priority :initarg :priority
- :type number
- :documentation
- "For file of this Major Mode, what is the priority of this file.
-When there are multiple template files with similar names, templates with
-the highest priority are scanned last, allowing them to override values in
-previous template files.")
- (project :initarg :project
- :type (or null string)
- :documentation
- "Scope some project files to a specific project.
-The value is a directory which forms the root of a particular project,
-or a subset of a particular project.")
- ;;
- ;; Parsed Data from the template file
- ;;
- (templates :initarg :templates
- :type list
- :documentation
- "The list of templates compiled into this table.")
- (namehash :initarg :namehash
- :documentation
- "Hash table containing the names of all the templates.")
- (contexthash :initarg :contexthash
- :documentation
- "")
- (variables :initarg :variables
- :documentation
- "AList of variables.
-These variables are used to initialize dictionaries.")
- )
- "Semantic recoder template table.
-A Table contains all templates from a single .srt file.
-Tracks various lookup hash tables.")
-
-;;; MODE TABLE
-;;
-(defvar srecode-mode-table-list nil
- "List of all the SRecode mode table classes that have been built.")
-
-(defclass srecode-mode-table (eieio-instance-tracker)
- ((tracking-symbol :initform 'srecode-mode-table-list)
- (major-mode :initarg :major-mode
- :documentation
- "Table of template tables for this major-mode.")
- (modetables :initarg :modetables
- :documentation
- "All that tables unique to this major mode.")
- (tables :initarg :tables
- :documentation
- "All the tables that can be used for this major mode.")
- )
- "Track template tables for a particular major mode.
-Tracks all the template-tables for a specific major mode.")
-
-(defun srecode-get-mode-table (mode)
- "Get the SRecoder mode table for the major mode MODE.
-This will find the mode table specific to MODE, and then
-calculate all inherited templates from parent modes."
- (let ((table nil))
- (dolist (mode (derived-mode-all-parents mode))
- (let ((tmptable (eieio-instance-tracker-find
- mode 'major-mode 'srecode-mode-table-list)))
- (when tmptable
- (if (not table)
- (progn
- ;; If this is the first, update tables to have
- ;; all the mode specific tables in it.
- (setq table tmptable)
- (oset table tables (oref table modetables)))
- ;; If there already is a table, then reset the tables
- ;; slot to include all the tables belonging to this new child node.
- (oset table tables (append (oref table modetables)
- (oref tmptable modetables)))))
- ))
- table))
-
-(defun srecode-make-mode-table (mode)
- "Get the SRecoder mode table for the major mode MODE."
- (let ((old (eieio-instance-tracker-find
- mode 'major-mode 'srecode-mode-table-list)))
- (or old
- (let* ((new (srecode-mode-table :major-mode mode
- :modetables nil
- :tables nil)))
- ;; Save this new mode table in that mode's variable.
- (eval `(setq-mode-local ,mode srecode-table ,new) t)
-
- new))))
-
-(cl-defmethod srecode-mode-table-find ((mt srecode-mode-table) file)
- "Look in the mode table MT for a template table from FILE.
-Return nil if there was none."
- (object-assoc file 'file (oref mt modetables)))
-
-(defun srecode-mode-table-new (mode file &rest init)
- "Create a new template table for MODE in FILE.
-INIT are the initialization parameters for the new template table."
- (let* ((mt (srecode-make-mode-table mode))
- (old (srecode-mode-table-find mt file))
- (attr (file-attributes file))
- (new (apply #'srecode-template-table
- (file-name-nondirectory file)
- :file file
- :filesize (file-attribute-size attr)
- :filedate (file-attribute-modification-time attr)
- :major-mode mode
- init
- )))
- ;; Whack the old table.
- (when old (object-remove-from-list mt 'modetables old))
- ;; Add the new table
- (object-add-to-list mt 'modetables new)
- ;; Sort the list in reverse order. When other routines
- ;; go front-to-back, the highest priority items are put
- ;; into the search table first, allowing lower priority items
- ;; to be the items found in the search table.
- (srecode-object-sort-list mt 'modetables (lambda (a b)
- (> (oref a priority)
- (oref b priority))))
- ;; Return it.
- new))
-
-(defun srecode-object-sort-list (object slot predicate)
- "Sort the items in OBJECT's SLOT.
-Use PREDICATE is the same as for the `sort' function."
- (when (slot-boundp object slot)
- (when (listp (eieio-oref object slot))
- (eieio-oset object slot (sort (eieio-oref object slot) predicate)))))
-
-;;; DEBUG
-;;
-;; Dump out information about the current srecoder compiled templates.
-;;
-(defun srecode-dump-templates (mode)
- "Dump a list of the current templates for MODE."
- (interactive "sMode: ")
- (require 'srecode/find)
- (let ((modesym (cond ((string= mode "")
- major-mode)
- ((not (string-match "-mode" mode))
- (intern-soft (concat mode "-mode")))
- (t
- (intern-soft mode)))))
- (srecode-load-tables-for-mode modesym)
- (let ((tmp (srecode-get-mode-table modesym))
- )
- (if (not tmp)
- (error "No table found for mode %S" modesym))
- (with-output-to-temp-buffer "*SRECODE DUMP*"
- (srecode-dump tmp))
- )))
-
-(cl-defmethod srecode-dump ((tab srecode-mode-table))
- "Dump the contents of the SRecode mode table TAB."
- (princ "MODE TABLE FOR ")
- (princ (oref tab major-mode))
- (princ "\n--------------------------------------------\n\nNumber of tables: ")
- (let ((subtab (oref tab tables)))
- (princ (length subtab))
- (princ "\n\n")
- (while subtab
- (srecode-dump (car subtab))
- (setq subtab (cdr subtab)))
- ))
-
-(cl-defmethod srecode-dump ((tab srecode-template-table))
- "Dump the contents of the SRecode template table TAB."
- (princ "Template Table for ")
- (princ (eieio-object-name-string tab))
- (princ "\nPriority: ")
- (prin1 (oref tab priority))
- (when (oref tab application)
- (princ "\nApplication: ")
- (princ (oref tab application)))
- (when (oref tab framework)
- (princ "\nFramework: ")
- (princ (oref tab framework)))
- (when (oref tab project)
- (require 'srecode/find) ; For srecode-template-table-in-project-p
- (princ "\nProject Directory: ")
- (princ (oref tab project))
- (when (not (srecode-template-table-in-project-p tab))
- (princ "\n ** Not Usable in this file. **")))
- (princ "\n\nVariables:\n")
- (let ((vars (oref tab variables)))
- (while vars
- (princ (car (car vars)))
- (princ "\t")
- (if (< (length (car (car vars))) 9)
- (princ "\t"))
- (prin1 (cdr (car vars)))
- (princ "\n")
- (setq vars (cdr vars))))
- (princ "\n\nTemplates:\n")
- (let ((temp (oref tab templates)))
- (while temp
- (srecode-dump (car temp))
- (setq temp (cdr temp))))
- )
-
-(define-obsolete-function-alias 'object-sort-list
- #'srecode-object-sort-list "29.1")
-
-(provide 'srecode/table)
-
-;;; srecode/table.el ends here
+++ /dev/null
-;;; srecode/template.el --- SRecoder template language parser support. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2005, 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Parser setup for the semantic recoder template parser.
-
-;;; Code:
-(require 'semantic)
-(require 'semantic/ctxt)
-(require 'semantic/wisent)
-(require 'srecode/srt-wy)
-
-(define-mode-local-override semantic-tag-components
- srecode-template-mode (tag)
- "Return sectiondictionary tags."
- (when (semantic-tag-of-class-p tag 'function)
- (let ((dicts (semantic-tag-get-attribute tag :dictionaries))
- (ans nil))
- (while dicts
- (setq ans (append ans (cdr (car dicts))))
- (setq dicts (cdr dicts)))
- ans)
- ))
-
-;; In semantic-imenu.el, not part of Emacs.
-(defvar semantic-imenu-summary-function)
-
-;;;###autoload
-(defun srecode-template-setup-parser ()
- "Setup buffer for parse."
- (srecode-template-wy--install-parser)
-
- (setq
- ;; Lexical Analysis
- semantic-lex-analyzer #'wisent-srecode-template-lexer
- ;; Parsing
- ;; Environment
- semantic-imenu-summary-function #'semantic-format-tag-name
- imenu-create-index-function #'semantic-create-imenu-index
- semantic-command-separation-character "\n"
- semantic-lex-comment-regex ";;"
- ;; Speedbar
- semantic-symbol->name-assoc-list
- '((function . "Template")
- (variable . "Variable")
- )
- ;; Navigation
- senator-step-at-tag-classes '(function variable)
- ))
-
-(provide 'srecode/template)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/template"
-;; End:
-
-;;; srecode/template.el ends here
+++ /dev/null
-;;; srecode/texi.el --- Srecode texinfo support. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Texinfo semantic recoder support.
-;;
-;; Contains some handlers, and a few simple texinfo srecoder applications.
-
-(require 'semantic)
-(require 'semantic/texi)
-(require 'srecode/semantic)
-
-;;; Code:
-
-(defun srecode-texi-add-menu (newnode)
- "Add an item into the current menu. Add @node statements as well.
-Argument NEWNODE is the name of the new node."
- (interactive "sName of new node: ")
- (srecode-load-tables-for-mode major-mode)
- (semantic-fetch-tags)
- (let ((currnode (reverse (semantic-find-tag-by-overlay)))
- (nodebounds nil))
- (when (not currnode)
- (error "Cannot find node to put menu item into"))
- (setq currnode (car currnode))
- (setq nodebounds (semantic-tag-texi-section-text-bounds currnode))
- ;; Step 1:
- ;; Limit search within this node.
- ;; Step 2:
- ;; Find the menu. If there isn't one, add one to the end.
- ;; Step 3:
- ;; Add new item to end of menu list.
- ;; Step 4:
- ;; Find correct node new item should show up after, and stick
- ;; the new node there.
- (if (string= (semantic-texi-current-environment) "menu")
- ;; We are already in a menu, so insert the new item right here.
- (beginning-of-line)
- ;; Else, try to find a menu item to append to.
- (goto-char (car nodebounds))
- (if (not (re-search-forward "^@menu" (car (cdr nodebounds)) t))
- (progn
- (goto-char (car (cdr nodebounds)))
- (if (not (y-or-n-p "Add menu here? "))
- (error "Abort"))
- (srecode-insert "declaration:menu"))
- ;; Else, find the end
- (re-search-forward "@end menu")
- (beginning-of-line)))
- ;; At this point, we are in a menu... or not.
- ;; If we are, do stuff, else error.
- (when (string= (semantic-texi-current-environment) "menu")
- (let ((menuname newnode)
- (returnpoint nil))
- (srecode-insert "declaration:menuitem" "NAME" menuname)
- (set-mark (point))
- (setq returnpoint (make-marker))
- ;; Update the bound since we added text
- (setq nodebounds (semantic-tag-texi-section-text-bounds currnode))
- (beginning-of-line)
- (forward-char -1)
- (beginning-of-line)
- (let ((end nil))
- (if (not (looking-at "\\* \\([^:]+\\):"))
- (setq end (car (cdr nodebounds)))
- (let* ((nname (match-string 1))
- (tag
- (semantic-deep-find-tags-by-name nname (current-buffer))))
- (when tag
- (setq end (semantic-tag-end (car tag))))
- ))
- (when (not end)
- (goto-char returnpoint)
- (error "Could not find location for new node" ))
- (when end
- (goto-char end)
- (when (bolp) (forward-char -1))
- (insert "\n")
- (if (eq (semantic-current-tag) currnode)
- (srecode-insert "declaration:subnode" "NAME" menuname)
- (srecode-insert "declaration:node" "NAME" menuname))
- )
- )))
- ))
-
-;;;###autoload
-(defun srecode-semantic-handle-:texi (dict)
- "Add macros into the dictionary DICT based on the current texinfo file.
-Adds the following:
- LEVEL - chapter, section, subsection, etc
- NEXTLEVEL - One below level"
-
- ;; LEVEL and NEXTLEVEL calculation
- (semantic-fetch-tags)
- (let ((tags (reverse (semantic-find-tag-by-overlay)))
- (level nil))
- (while (and tags (not (semantic-tag-of-class-p (car tags) 'section)))
- (setq tags (cdr tags)))
- (when tags
- (save-excursion
- (goto-char (semantic-tag-start (car tags)))
- (when (looking-at "@node")
- (forward-line 1)
- (beginning-of-line))
- (when (looking-at "@\\(\\w+\\)")
- (setq level (match-string 1))
- )))
- (srecode-dictionary-set-value dict "LEVEL" (or level "chapter"))
- (let ((nl (assoc level '( ( nil . "top" )
- ("top" . "chapter")
- ("chapter" . "section")
- ("section" . "subsection")
- ("subsection" . "subsubsection")
- ("subsubsection" . "subsubsection")
- ))))
- (srecode-dictionary-set-value dict "NEXTLEVEL" (cdr nl))))
- )
-
-;;;###autoload
-(defun srecode-semantic-handle-:texitag (dict)
- "Add macros into the dictionary DICT based on the current :tag file.
-Adds the following:
- TAGDOC - Texinfo formatted doc string for :tag."
-
- ;; If we also have a TAG, what is the doc?
- (let ((tag (srecode-dictionary-lookup-name dict "TAG"))
- (doc nil)
- )
-
- ;; If the user didn't apply :tag, then do so now.
- (when (not tag)
- (srecode-semantic-handle-:tag dict))
-
- (setq tag (srecode-dictionary-lookup-name dict "TAG"))
-
- (when (not tag)
- (error "No tag to insert for :texitag template argument"))
-
- ;; Extract the tag out of the compound object.
- (setq tag (oref tag prime))
-
- ;; Extract the doc string
- (setq doc (semantic-documentation-for-tag tag))
-
- (when doc
- (srecode-dictionary-set-value dict "TAGDOC"
- (srecode-texi-massage-to-texinfo
- tag (semantic-tag-buffer tag)
- doc)))
- ))
-
-;;; OVERRIDES
-;;
-;; Override some semantic and srecode features with texi specific
-;; versions.
-
-(define-mode-local-override semantic-insert-foreign-tag
- texinfo-mode (foreign-tag)
- "Insert FOREIGN-TAG from a foreign buffer in TAGFILE.
-Assume TAGFILE is a source buffer, and create a documentation
-thingy from it using the `document' tool."
- (srecode-texi-insert-tag-as-doc foreign-tag))
-
-(defun srecode-texi-insert-tag-as-doc (tag)
- "Insert TAG into the current buffer with SRecode."
- (when (not (eq major-mode 'texinfo-mode))
- (error "Can only insert tags into texinfo in texinfo mode"))
- (let ((srecode-semantic-selected-tag tag))
- (srecode-load-tables-for-mode major-mode)
- ;; @todo - choose of the many types of tags to insert,
- ;; or put all that logic into srecode.
- (srecode-insert "declaration:function")))
-
-
-\f
-;;; Texinfo mangling.
-
-(define-overloadable-function srecode-texi-texify-docstring
- (docstring)
- "Texify the doc string DOCSTRING.
-Takes plain text formatting that may exist, and converts it to
-using TeXinfo formatting.")
-
-(defun srecode-texi-texify-docstring-default (docstring)
- "Texify the doc string DOCSTRING.
-Takes a few very generic guesses as to what the formatting is."
- (let ((case-fold-search nil)
- (start 0))
- (while (string-match
- "\\(^\\|[^{]\\)\\<\\([A-Z0-9_-]+\\)\\>\\($\\|[^}]\\)"
- docstring start)
- (let ((ms (match-string 2 docstring)))
- ;(when (eq mode 'emacs-lisp-mode)
- ; (setq ms (downcase ms)))
-
- (when (not (or (string= ms "A")
- (string= ms "a")
- ))
- (setq docstring (concat (substring docstring 0 (match-beginning 2))
- "@var{"
- ms
- "}"
- (substring docstring (match-end 2))))))
- (setq start (match-end 2)))
- ;; Return our modified doc string.
- docstring))
-
-(defun srecode-texi-massage-to-texinfo (_tag buffer string)
- "Massage TAG's documentation from BUFFER as STRING.
-This is to take advantage of TeXinfo's markup symbols."
- (save-excursion
- (if buffer
- (progn (set-buffer buffer)
- (srecode-texi-texify-docstring string))
- ;; Else, no buffer, so let's do something else
- (with-mode-local texinfo-mode
- (srecode-texi-texify-docstring string)))))
-
-(define-mode-local-override srecode-texi-texify-docstring emacs-lisp-mode
- (string)
- "Take STRING, (a normal doc string), and convert it into a texinfo string.
-For instances where CLASS is the class being referenced, do not Xref
-that class.
-
- function => @dfn{function}
- variable => @code{variable}
- class => @code{class} @xref{class}
- unknown => @code{unknown}
- \"text\" => \\=`\\=`text\\='\\='
- \\='quoteme => @code{quoteme}
- non-nil => non-@code{nil}
- t => @code{t}
- :tag => @code{:tag}
- [ stuff ] => @code{[ stuff ]}
- Key => @kbd{Key} (key is C\\-h, M\\-h, SPC, RET, TAB and the like)
- ... => @dots{}"
- (while (string-match "[`‘]\\([-a-zA-Z0-9<>.]+\\)['’]" string)
- (let* ((vs (substring string (match-beginning 1) (match-end 1)))
- (v (intern-soft vs)))
- (setq string
- (concat
- (replace-match (concat
- (if (fboundp v)
- "@dfn{" "@code{")
- vs "}")
- nil t string)))))
- (while (string-match "\\( \\|^\\)\\(nil\\|t\\|'[-a-zA-Z0-9]+\\|:[-a-zA-Z0-9]+\\)\\([. ,]\\|$\\)" string)
- (setq string (replace-match "@code{\\2}" t nil string 2)))
- (while (string-match "\\( \\|^\\)\\(\\(non-\\)\\(nil\\)\\)\\([. ,]\\|$\\)" string)
- (setq string (replace-match "\\3@code{\\4}" t nil string 2)))
- (while (string-match "\\( \\|^\\)\\(\\[[^]]+\\]\\)\\( \\|$\\)" string)
- (setq string (replace-match "@code{\\2}" t nil string 2)))
- (while (string-match "\\( \\|^\\)\\(\\(\\(C-\\|M-\\|S-\\)+\\([^ \t\n]\\|RET\\|SPC\\|TAB\\)\\)\\|\\(RET\\|SPC\\|TAB\\)\\)\\( \\|\\s.\\|$\\)" string)
- (setq string (replace-match "@kbd{\\2}" t nil string 2)))
- (while (string-match "\"\\(.+\\)\"" string)
- (setq string (replace-match "``\\1''" t nil string 0)))
- (while (string-match "\\.\\.\\." string)
- (setq string (replace-match "@dots{}" t nil string 0)))
- ;; Also do base docstring type.
- (srecode-texi-texify-docstring-default string))
-
-(provide 'srecode/texi)
-
-;; Local variables:
-;; generated-autoload-file: "loaddefs.el"
-;; generated-autoload-load-name: "srecode/texi"
-;; End:
-
-;;; srecode/texi.el ends here
+++ /dev/null
-;;; eieio-datadebug.el --- EIEIO extensions to the data debugger. -*- lexical-binding:t -*-
-
-;; Copyright (C) 2007-2024 Free Software Foundation, Inc.
-
-;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Keywords: OO, lisp
-;; Package: eieio
-
-;; 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Extensions to data-debug for EIEIO objects.
-;;
-
-(require 'eieio)
-(require 'data-debug)
-
-;;; Code:
-
-(declare-function data-debug/eieio-insert-slots "eieio-datadebug"
- (obj eieio-default-superclass))
-
-(defun data-debug-insert-object-slots (object prefix)
- "Insert all the slots of OBJECT.
-PREFIX specifies what to insert at the start of each line."
- (let ((attrprefix (concat (make-string (length prefix) ? ) "] ")))
- (data-debug/eieio-insert-slots object attrprefix)))
-
-(defun data-debug-insert-object-slots-from-point (point)
- "Insert the object slots found at the object button at POINT."
- (let ((object (get-text-property point 'ddebug))
- (indent (get-text-property point 'ddebug-indent))
- start)
- (end-of-line)
- (setq start (point))
- (forward-char 1)
- (data-debug-insert-object-slots object
- (concat (make-string indent ? )
- "~ "))
- (goto-char start)))
-
-(defun data-debug-insert-object-button (object prefix prebuttontext)
- "Insert a button representing OBJECT.
-PREFIX is the text that precedes the button.
-PREBUTTONTEXT is some text between PREFIX and the object button."
- (let* ((start (point))
- (end nil)
- (str (cl-prin1-to-string object))
- (class (eieio-object-class object))
- (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
- (eieio-object-name-string object)
- class
- (eieio-class-parents class)
- (length (eieio-class-slots class))
- ))
- )
- (insert prefix prebuttontext str)
- (setq end (point))
- (put-text-property (- end (length str)) end 'face 'font-lock-keyword-face)
- (put-text-property start end 'ddebug object)
- (put-text-property start end 'ddebug-indent(length prefix))
- (put-text-property start end 'ddebug-prefix prefix)
- (put-text-property start end 'help-echo tip)
- (put-text-property start end 'ddebug-function
- 'data-debug-insert-object-slots-from-point)
- (insert "\n")))
-
-;;; METHODS
-;;
-;; Each object should have an opportunity to show stuff about itself.
-
-(cl-defmethod data-debug/eieio-insert-slots ((obj eieio-default-superclass)
- prefix)
- "Insert the slots of OBJ into the current DDEBUG buffer."
- (let ((inhibit-read-only t))
- (data-debug-insert-thing (eieio-object-name-string obj)
- prefix
- "Name: ")
- (let* ((cv (eieio--object-class obj)))
- (data-debug-insert-thing (eieio--class-name cv)
- prefix
- "Class: ")
- ;; Loop over all the public slots
- (let ((slots (eieio--class-slots cv)))
- (dotimes (i (length slots))
- (let* ((slot (aref slots i))
- (sname (cl--slot-descriptor-name slot))
- (i (eieio--class-slot-initarg cv sname))
- (sstr (concat (symbol-name (or i sname)) " ")))
- (if (slot-boundp obj sname)
- (let* ((v (eieio-oref obj sname)))
- (data-debug-insert-thing v prefix sstr))
- ;; Unbound case
- (data-debug-insert-custom
- "#unbound" prefix sstr
- 'font-lock-keyword-face)
- )))))))
-
-;;; Augment the Data debug thing display list.
-(data-debug-add-specialized-thing (lambda (thing) (eieio-object-p thing))
- #'data-debug-insert-object-button)
-
-;;; DEBUG METHODS
-;;
-;; A generic function to run DDEBUG on an object and popup a new buffer.
-;;
-(cl-defmethod data-debug-show ((obj eieio-default-superclass))
- "Run ddebug against any EIEIO object OBJ."
- (data-debug-new-buffer (format "*%s DDEBUG*" (eieio-object-name obj)))
- (data-debug-insert-object-slots obj "]"))
-
-(provide 'eieio-datadebug)
-
-;;; eieio-datadebug.el ends here
("\\.f0[38]\\'" . f90-mode)
("\\.indent\\.pro\\'" . fundamental-mode) ; to avoid idlwave-mode
("\\.\\(pro\\|PRO\\)\\'" . idlwave-mode)
- ("\\.srt\\'" . srecode-template-mode)
("\\.prolog\\'" . prolog-mode)
("\\.tar\\'" . tar-mode)
;; The list of archive file extensions should be in sync with
("\\.har\\'" . javascript-mode)
("\\.json\\'" . js-json-mode)
("\\.[ds]?va?h?\\'" . verilog-mode)
- ("\\.by\\'" . bovine-grammar-mode)
- ("\\.wy\\'" . wisent-grammar-mode)
("\\.erts\\'" . erts-mode)
;; .emacs or .gnus or .viper following a directory delimiter in
;; Unix or MS-DOS syntax.
(defvar finder--builtins-alist
'(("calc" . calc)
- ("ede" . ede)
("erc" . erc)
("eshell" . eshell)
("gnus" . gnus)
("quail" . emacs)
("mh-e" . mh-e)
("obsolete" . emacs)
- ("semantic" . semantic)
- ("analyze" . semantic)
- ("bovine" . semantic)
- ("decorate" . semantic)
- ("symref" . semantic)
- ("wisent" . semantic)
;; This should really be ("nxml" . nxml-mode), because nxml-mode.el
;; is the main file for the package. Then we would not need an
;; entry in finder--builtins-descriptions. But I do not know if
;; it is safe to change this, in case it is already in use.
("nxml" . nxml)
("org" . org)
- ("srecode" . srecode)
("term" . emacs)
("use-package" . use-package)
("url" . url))
("reftex" "Index")
("sasl" "Variable Index" "Function Index")
("sc" "Variable Index")
- ("semantic" "Index")
("ses" "Index")
("sieve" "Index")
("smtpmail" "Function and Variable Index")
- ("srecode" "Index")
("tramp" "Variable Index" "Function Index")
("url" "Variable Index" "Function Index")
("vhdl" "(vhdl-mode)Variable Index" "(vhdl-mode)Command Index")
("viper" "Variable Index" "Function Index")
("vtable" "Index")
("widget" "Index")
- ("wisent" "Index")
("woman" "Variable Index" "Command Index")))
;; docstrings talk about elisp, so have apropos-mode follow emacs-lisp-mode
(bindings--define-key menu [separator-prog]
menu-bar-separator)
- (bindings--define-key menu [semantic]
- '(menu-item "Source Code Parsers (Semantic)"
- semantic-mode
- :help "Toggle automatic parsing in source code buffers (Semantic mode)"
- :button (:toggle . (bound-and-true-p semantic-mode))))
-
(bindings--define-key menu [eglot]
'(menu-item "Language Server Support (Eglot)" eglot
:help "Start language server suitable for this buffer's major-mode"))
(bindings--define-key menu [project]
menu-bar-project-item)
- (bindings--define-key menu [ede]
- '(menu-item "Project Support (EDE)"
- global-ede-mode
- :help "Toggle the Emacs Development Environment (Global EDE mode)"
- :button (:toggle . (bound-and-true-p global-ede-mode))))
-
(bindings--define-key menu [gdb]
'(menu-item "Debugger (GDB)..." gdb
:help "Debug a program from within Emacs with GDB"))
(cond
((re-search-forward " [-+=]?> \\([^\n]+\\)" (line-end-position) t)
(let* ((tag (match-string 1))
- (attr (speedbar-line-token))
- (item nil)
- (semantic-tagged (if (fboundp 'semantic-tag-p)
- (semantic-tag-p attr))))
- (if semantic-tagged
- (with-no-warnings
- (save-excursion
- (when (and (semantic-tag-overlay attr)
- (semantic-tag-buffer attr))
- (set-buffer (semantic-tag-buffer attr)))
- (dframe-message
- (funcall semantic-sb-info-format-tag-function attr)
- )))
- (looking-at "\\([0-9]+\\):")
- (setq item (file-name-nondirectory (speedbar-line-directory)))
- (dframe-message "Tag: %s in %s" tag item))))
+ (item nil))
+ (looking-at "\\([0-9]+\\):")
+ (setq item (file-name-nondirectory (speedbar-line-directory)))
+ (dframe-message "Tag: %s in %s" tag item)))
((re-search-forward "{[+-]} \\([^\n]+\\)$" (line-end-position) t)
(dframe-message "Group of tags \"%s\"" (match-string 1)))
((re-search-forward " [+-]?[()|@] \\([^\n]+\\)$" nil t)
(speedbar-line-token)
nil))))
(cond
- ((featurep 'semantic)
- (with-no-warnings
- (if (semantic-tag-p detail)
- (dframe-message
- (funcall semantic-sb-info-format-tag-function detail parent))
- (if parent
- (dframe-message "Detail: %s of tag %s" detail
- (if (semantic-tag-p parent)
- (semantic-format-tag-name parent nil t)
- parent))
- (dframe-message "Detail: %s" detail)))))
- ;; Not using `semantic':
(parent
(dframe-message "Detail: %s of tag %s" detail parent))
(t
+++ /dev/null
-;;; cedet-files-tests.el --- Tests for cedet-files.el -*- lexical-binding:t -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Moved here from test/manual/cedet/cedet-utests.el
-
-;;; Code:
-
-(require 'ert)
-(require 'cedet-files)
-
-(defvar cedet-files-utest-list
- '(("/home/me/src/myproj/src/foo.c" . "!home!me!src!myproj!src!foo.c")
- ("c:/work/myproj/foo.el" . "!drive_c!work!myproj!foo.el")
- ("//windows/proj/foo.java" . "!!windows!proj!foo.java")
- ("/home/me/proj!bang/foo.c" . "!home!me!proj!!bang!foo.c"))
- "List of file names to test.
-Each entry is a cons cell of (FNAME . CONVERTED)
-where FNAME is some file name, and CONVERTED is what it should be
-converted into.")
-
-(ert-deftest cedet-files-utest ()
- "Test some file name conversions."
- (dolist (FT cedet-files-utest-list)
- (let ((dir->file (cedet-directory-name-to-file-name (car FT) t))
- (file->dir (cedet-file-name-to-directory-name (cdr FT) t)))
- (should (string= (cdr FT) dir->file))
- (should (string= file->dir (car FT))))))
-
-(provide 'cedet-files-tests)
-
-;;; cedet-files-tests.el ends here
+++ /dev/null
-;;; semantic-utest-c.el --- C based parsing tests. -*- lexical-binding:t -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Run some C based parsing tests.
-
-(require 'ert)
-(require 'semantic)
-
-(defvar semantic-utest-c-comparisons
- '( ("testsppreplace.c" . "testsppreplaced.c")
- )
- "List of files to parse and compare against each other.")
-
-(defvar cedet-utest-directory
- (let* ((C (file-name-directory (locate-library "cedet")))
- (D (expand-file-name "../../test/manual/cedet/" C)))
- D)
- "Location of test files for this test suite.")
-
-(defvar semantic-utest-c-test-directory (expand-file-name "tests" cedet-utest-directory)
- "Location of test files.")
-
-(defvar semantic-lex-c-nested-namespace-ignore-second)
-
-;;; Code:
-(ert-deftest semantic-test-c-preprocessor-simulation ()
- "Run parsing test for C from the test directory."
- :tags '(:expensive-test)
- (semantic-mode 1)
- (dolist (fp semantic-utest-c-comparisons)
- (let* ((semantic-lex-c-nested-namespace-ignore-second nil)
- (tags-actual
- (with-current-buffer
- (find-file-noselect (expand-file-name (car fp) semantic-utest-c-test-directory))
- (semantic-clear-toplevel-cache)
- (semantic-fetch-tags)))
- (tags-expected
- (with-current-buffer (find-file-noselect (expand-file-name (cdr fp) semantic-utest-c-test-directory))
- (semantic-clear-toplevel-cache)
- (semantic-fetch-tags))))
- (when (or (not tags-expected) (not tags-actual))
- (message "Tried to find test files in: %s" semantic-utest-c-test-directory)
- (error "Failed: Discovered no tags in test files or test file not found"))
-
- ;; Now that we have the tags, compare them for SPP accuracy.
- (dolist (tag tags-actual)
- (if (and (semantic-tag-of-class-p tag 'variable)
- (semantic-tag-variable-constant-p tag))
- nil ; skip the macros.
-
- (if (semantic-tag-similar-with-subtags-p tag (car tags-expected))
- (setq tags-expected (cdr tags-expected))
- (with-mode-local c-mode
- (should nil) ;; this is a fail condition
- (message "Error: Found: >> %s << Expected: >> %s <<"
- (semantic-format-tag-prototype tag nil t)
- (semantic-format-tag-prototype (car tags-expected) nil t)
- )))
- ))
- )))
-
-(require 'semantic/bovine/gcc)
-
-;; 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.")
-
-(ert-deftest semantic-test-gcc-output-parser ()
- "Test the output parser against some collected strings."
- (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)
- ))
- (should (and v h))
- ))
- (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)))
- )
- ;; negative test
- (should-not (and v h p))
- ))
- )
-
-
-(provide 'semantic-utest-c)
-
-;;; semantic-utest-c.el ends here
+++ /dev/null
-# A Test Makefile. -*-makefile-*-
-
-# This test is for a file in this test directory. Just a random one.
-FILES=testdoub # -1-
-# #1# ("testdoublens.cpp" "testdoublens.hpp" )
-
-all: optional
-
-# This one completes on a variable name.
-optional: $FIL # -2-
- # #2# ("FILES")
- compile $@
-
-notoptional: opt # -3-
- # #3# ("optional")
- echo "Done."
-
-#end
+++ /dev/null
-;; test.srt --- unit test support file for semantic-utest-ia
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-;;
-
-set mode "c++-mode"
-set escape_start "{{"
-set escape_end "}}"
-
-context file
-
-template class :blank
-"A test template for emacs lisp"
-----
-----
-
-template classic :blank
-"A test template for emacs lisp"
-----
-----
-
-template variable :blank
-"A test template for emacs lisp"
-----
-----
-
-template function :blank
-"A test template for emacs lisp"
-----
-----
-
-template testarea :blank
-"A test template for emacs lisp"
-----
-{{<A:cla}} -1-
- }} #1# ( "class" "classic" )
- {{^}}
-
-{{/A}}
-----
-
-;; This is a bad hack - In order for the text to parse, but also get a completion
-;; moniker into the right spot, we need to pretend a comment is the same as the
-;; escape_end.
-;; Local variables:
-;; comment-start-skip: "}}"
-;; End:
+++ /dev/null
-\input texinfo
-@setfilename test.info
-@set TITLE TEST
-@set AUTHOR Eric Ludlam
-@settitle @value{TITLE}
-
-@ifinfo
-@format
-START-INFO-DIR-ENTRY
-* test: (test). TEST
-END-INFO-DIR-ENTRY
-@end format
-@end ifinfo
-
-@titlepage
-@sp 10
-@center @titlefont{test}
-@vskip 0pt plus 1 fill
-Copyright @copyright{} 2015 Eric Ludlam
-@end titlepage
-
-@node Top
-@top @value{TITLE}
-
-This is a simple manual filled with stuff that should test completion in texinfo mode.
-
-@m@c -1-
-@c #1# ( "@majorheading" "@macro" "@menu" "@multitable" )
-
-@menu
-* Index::
-@end menu
-
-
-@node Index
-@chapter Index
-
-@contents
-
-@bye
+++ /dev/null
-// testdoublens.cpp --- semantic-ia-utest completion engine unit tests
-
-// Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-#include "testdoublens.hpp"
-
-namespace Name1 {
- namespace Name2 {
-
- Foo::Foo()
- {
- p// -1-
- // #1# ( "pMumble" "publishStuff" )
- ;
- }
-
- int Foo::get() // ^1^
- {
- p// -2-
- // #2# ( "pMumble" "publishStuff" )
- ;
- return 0;
- }
-
- void Foo::publishStuff(int a, int b) // ^2^
- {
- int foo = a;
- int bar = b;
- }
-
- // Test polymorphism on arg types. Note that order is
- // mixed to maximize failure cases
- void Foo::publishStuff(char a, char b) // ^4^
- {
- int foo = a;
- int bar = b;
- }
-
- void Foo::sendStuff(int a, int b) // ^3^
- {
- int foo = a;
- int bar = b;
-
- Foo::publishStuff(1,2)
-
- }
-
- } // namespace Name2
-} // namespace Name1
-
-// Test multiple levels of metatype expansion
-int test_fcn () {
- stage3_Foo MyFoo;
-
- MyFoo.// -3-
- // #3# ( "Mumble" "get" )
- ;
-
- Name1::Name2::F//-4-
- // #4# ( "Foo" )
- ;
-
- // @TODO - get this working...
- Name1::stage2_Foo::M//-5-
- /// #5# ( "Mumble" )
- ;
-}
-
-stage3_Foo foo_fcn() {
- // Can we go "up" to foo with senator-go-to-up-reference?
-}
-
-
-// Second test from Ravikiran Rajagopal
-
-namespace A {
- class foo {
- public:
- void aa();
- void bb();
- };
-}
-namespace A {
- class bar {
- public:
- void xx();
- public:
- foo myFoo;
- };
-
- void bar::xx()
- {
- myFoo.// -6- <--- cursor is here after the dot
- // #6# ( "aa" "bb" )
- ;
- }
-}
-
-// Double namespace example from Hannu Koivisto
-//
-// This is tricky because the parent class "Foo" is found within the
-// scope of B, so the scope calculation needs to put that together
-// before searching for parents in scope.
-namespace a {
- namespace b {
-
- class Bar : public Foo
- {
- int baz();
- };
-
- int Bar::baz()
- {
- return dum// -7-
- // #7# ( "dumdum" )
- ;
- }
-
- } // namespace b
-} // namespace a
-
-// Three namespace example from Hannu Koivisto
-//
-// This one is special in that the name e::Foo, where "e" is in
-// the scope, and not referenced from the global namespace. This
-// wasn't previously handled, so the fullscope needed to be added
-// to the list of things searched when in split-name decent search mode
-// for scopes.
-
-namespace d {
- namespace e {
-
- class Foo
- {
- public:
- int write();
- };
-
- } // namespace d
-} // namespace e
-
-
-namespace d {
- namespace f {
-
- class Bar
- {
- public:
- int baz();
-
- private:
- e::Foo &foo;
- };
-
- int Bar::baz()
- {
- return foo.w// -8-
- // #8# ( "write" )
- ;
- }
-
- } // namespace f
-} // namespace d
-
-// Fully qualified const struct function arguments
-class ContainsStruct
-{
- struct TheStruct
- {
- int memberOne;
- int memberTwo;
- };
-};
-
-void someFunc(const struct ContainsStruct::TheStruct *foo)
-{
- foo->// -9-
- // #9# ("memberOne" "memberTwo")
-}
-
-// Class with structure tag
-class ContainsNamedStruct
-{
- struct _fooStruct
- {
- int memberOne;
- int memberTwo;
- } member;
-};
-
-void someOtherFunc(void)
-{
- ContainsNamedStruct *someClass;
- // This has to find ContainsNamedStruct::_fooStruct
- someClass->member.// -10-
- // #10# ("memberOne" "memberTwo")
-}
+++ /dev/null
-// testdoublens.hpp --- Header file used in one of the Semantic tests
-
-// Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-namespace Name1 {
- namespace Name2 {
-
- class Foo
- {
- typedef unsigned int Mumble;
- public:
- Foo();
- ~Foo();
- int get();
-
- private:
- void publishStuff(char /* a */, char /* b */);
-
- void publishStuff(int q, int r); // Purposely different names.
-
- void sendStuff(int a, int b);
-
- Mumble* pMumble;
- };
-
- typedef Foo stage1_Foo;
-
- } // namespace Name2
-
- typedef Name2::stage1_Foo stage2_Foo;
-
- typedef Name2::Foo decl_stage1_Foo;
-
-} // namespace Name1
-
-typedef Name1::stage2_Foo stage3_Foo;
-
-
-// Double namespace from Hannu Koivisto
-namespace a {
- namespace b {
-
- class Foo
- {
- struct Dum {
- int diDum;
- };
-
- protected:
- mutable a::b::Foo::Dum dumdum;
- };
-
- } // namespace b
-} // namespace a
+++ /dev/null
-// Test parsing of friends and how they are used in completion.
-/*
- >> Thanks Damien Profeta for the nice example.
- >
- > I paste a small example.
- > It would be great if friend can be well parsed and even greater if
- > class B can access to all the members of A.
-*/
-
-class Af // %2% ( ( "testfriends.cpp" ) ( "Af" "B::testB" ) )
-{
-public:
- int pubVar;
-private:
- int privateVar;
-
- friend class B;
-
-};
-
-class B
-{
-public:
- int testB();
- int testAB();
-
-};
-
-
-int B::testB() {
- Af classA;
- classA.//-1-
- ; //#1# ( "privateVar" "pubVar" )
-}
-
-int B::testAB() { // %1% ( ( "testfriends.cpp" ) ( "B" "B::testAB" ) )
-}
+++ /dev/null
-// testjavacomp.java --- Semantic unit test for Java
-
-// Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-package tests.testjavacomp;
-
-class secondClass {
- private void scFuncOne() { }
- public void scFuncOne() { }
-
- int package_protected_field;
- public int public_protected_field;
- private int private_protected_field;
-}
-
-
-public class testjavacomp {
-
- private int funcOne() { }
- private int funcTwo() { }
- private char funcThree() { }
-
- class nestedClass {
- private void ncFuncOne() { }
- public void ncFuncOne() { }
- }
-
- public void publicFunc() {
-
- int i;
-
- i = fu// -1-
- // #1# ( "funcOne" "funcTwo" )
- ;
-
- fu// -2-
- // #2# ( "funcOne" "funcThree" "funcTwo" )
- ;
-
- secondClass SC;
-
- SC.s//-3-
- // #3# ( "scFuncOne" )
- ;
-
- // @TODO - to make this test complete, we need an import
- // with a package protected field that is excluded
- // from the completion list.
- SC.p//-4-
- // #4# ( "package_protected_field" "public_protected_field" )
-
- nestedClass NC;
-
- // @todo - need to fix this? I don't know if this is legal java.
- NC.// - 5-
- // #5# ( "ncFuncOne" )
- ;
- }
-
-} // testjavacomp
+++ /dev/null
-// testlocalvars.java --- Semantic unit test for Java
-
-// Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-
-class foo {
- foo *member;
- char anArray[10];
-};
-
-void func()
-{
- foo local1;
- foo* local2 = localvar.member;
- foo* local3 = new foo();
- foo local4[10];
- char local5[5] = {'1','2','3','4','5'};
- char *local6 = "12345";
- char local7 = local.anArray[0];
- char local8 = true ? 10 : 11 ;
-
- // Check that all of the above was parsed
- local//-1-
- ; //#1# ("local1" "local2" "local3" "local4" "local5" "local6" "local7" "local8" )
-
- local1.//-2-
- ; //#2# ("anArray" "member")
-
- local2->//-3-
- ; //#3# ("anArray" "member")
-
- local3->//-4-
- ; //#4# ("anArray" "member")
-
- local4[0].//-5-
- ; //#5# ("anArray" "member")
-}
+++ /dev/null
-/* testnsp.cpp --- semantic-ia-utest completion engine unit tests
-
- Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-*/
-
-namespace nsp {
-
- class rootclass {
- public:
- int fromroot() {};
- };
-
-}
-
-namespace nsp {
- class childclass : public rootclass {
- public:
- int fromchild() {};
- };
-}
-
-void myfcn_not_in_ns (void) {
- nsp::childclass test;
-
- test.// -1-
- ; // #1# ( "fromchild" "fromroot" )
-}
-
-// Test a class declared in a class, where the contents
-// are in a qualified name.
-//
-// Thanks Michael Reiher for the concise example.
-
-class AAA
-{
-public:
- AAA();
-
- void aaa();
-
-private:
- class Private;
- Private * const d;
-};
-
-class AAA::Private
-{
- Private() : bbb(0) {
- }
-
- BBB* bbb;
-};
-
-void AAA::aaa()
-{
- d->// -2-
- ; // #2# ( "bbb" )
-}
-
-// #include files inside a namespace
-// David Engster <deng@randomsample.de>
-// See revisions 8034-8037 which implement this.
-
-namespace another {
- #include "testdoublens.hpp"
-}
-
-void foo(void) {
-
- another::// -3-
- ; // #3# ( "Name1" "a" "stage3_Foo" )
-
- another::Name1::Name2::Foo a;
-
- a.// -4-
- ; // #4# ( "Mumble" "get" )
-}
-
-// What happens if a type your looking for is scoped within a type,
-// but you are one level into the completion so the originating scope
-// excludes the type of the variable you are completing through?
-// Thanks Martin Stein for this nice example.
-
-namespace ms_structs
-{
- struct ms_aaa
- {
- int xx;
- };
-
- struct ms_bbb
- {
- struct ms_aaa yy;
- };
-};
-
-int fun()
-{
- using namespace ms_structs;
- struct ms_bbb mszz;
- int uu = mszz.// -5-
- ; // #5# ( "yy" )
- int kk = mszz.yy.// - 6- @TODO - bring in patch from SF
- ; // #6# ( "xx" )
-}
+++ /dev/null
-/* testesppcomplete.cpp --- semantic-ia-utest completion engine unit tests
-
- Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-*/
-
-/* Example provided by Hannes Janetzek */
-
-struct Test { int test; };
-
-#define BLA(_type) \
- _type *bla = (_type*) malloc(sizeof(_type));
-
-#define BLUB(_type) \
- (_type*)malloc(sizeof(_type));
-
-#define FOO(_type) \
- _type *foo = BLUB(_type);
-
-#define BAR(_type) \
- _type *bar = (*_type)BLUB(_type);
-
-int main(int argc, char *argv[]) {
- BLA(Test);
- bla->// -1-
- ; // #1# ( "test" )
-
- FOO(Test);
- foo->// -2-
- ; // #2# ( "test" )
-
- BAR(Test);
- bar->// -3-
- ; // #3# ( "test" )
-}
-
-/* Test symref and macros together. */
-
-// This function exists only so we can have a comment in a tag with this name.
-void function_with_macro_name ()
-// %1% ( ( "testsppcomplete.c" ) ( "function_with_macro_name" "function_with_macro_name" "use_macro") )
-// Note: fwmn is in twice, once for function, and once for the constant macro below.
-{
-}
-
-#define function_with_macro_name 1
-
-int use_macro () {
- int a = function_with_macro_name;
-}
+++ /dev/null
-// teststruct.cpp --- semantic-ia-utest completion engine unit tests
-
-// Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-
-// Note: initially provided by Alex Ott.
-
-template <typename DerivedT>
-struct grammar {
-public:
- typedef grammar<DerivedT> self_t;
- typedef DerivedT const& embed_t;
- grammar() {}
- ~grammar() { }
- void use_parser() const { }
- void test1() { }
-};
-
-struct PDFbool_parser : public grammar<PDFbool_parser> {
- PDFbool_parser() {}
- template <typename scannerT> struct definition {
- typedef typename scannerT::iterator_t iterator_t;
- int top;
- definition(const PDFbool_parser& /*self*/) {
- return ;
- }
- const int start() const {
- return top;
- }
- };
-};
-
-int main(void) {
- PDFbool_parser PDFbool_p = PDFbool_parser();
- PDFbool_p.//-1-
- ;
- // #1# ("definition" "embed_t" "self_t" "test1" "use_parser")
-}
-
-// ----------------------------------------------------------------------
-
-template <class Derived> struct Base {
-public:
- void interface()
- {
- // ...
- static_cast<Derived*>(this)->implementation();
- // ...
- }
-
- static void static_func()
- {
- // ...
- Derived::static_sub_func();
- // ...
- }
-};
-
-struct Derived : Base<Derived> {
- void implementation() { }
- static void static_sub_func() { }
-};
-
-int foo () {
- Derived d;
- d.//-2-
- ;
- // #2# ("implementation" "interface" "static_func" "static_sub_func")
-}
+++ /dev/null
-// testsubclass.cpp --- unit test for analyzer and complex C++ inheritance
-
-// Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-//#include <iostream>
-#include "testsubclass.hh"
-
-void animal::moose::setFeet(int numfeet) //^1^
-{
- if (numfeet > 4) {
- std::cerr << "Why would a moose have more than 4 feet?" << std::endl;
- return;
- }
-
- fFeet = numfeet;
-}
-
-int animal::moose::getFeet() //^2^
-{
- return fFeet;
-}
-
-void animal::moose::doNothing() //^3^
-{
- animal::moose foo();
-
- fFeet = N// -15-
- ; // #15# ( "NAME1" "NAME2" "NAME3" )
-}
-
-
-void deer::moose::setAntlers(bool have_antlers) //^4^
-{
- fAntlers = have_antlers;
-}
-
-bool deer::moose::getAntlers() //^5^
-// %1% ( ( "testsubclass.cpp" "testsubclass.hh" ) ( "deer::moose::doSomething" "deer::moose::getAntlers" "moose" ) )
-{
- return fAntlers;
-}
-
-bool i_dont_have_symrefs()
-// %2% ( ("testsubclass.cpp" ) ("i_dont_have_symrefs"))
-{
-}
-
-void deer::moose::doSomething() //^6^
-{
- // All these functions should be identified by semantic analyzer.
- getAntlers();
- setAntlers(true);
-
- getFeet();
- setFeet(true);
-
- doNothing();
-
- fSomeField = true;
-
- fIsValid = true;
-}
-
-void deer::alces::setLatin(bool l) {
- fLatin = l;
-}
-
-bool deer::alces::getLatin() {
- return fLatin;
-}
-
-void deer::alces::doLatinStuff(moose moosein) {
- // All these functions should be identified by semantic analyzer.
- getFeet();
- setFeet(true);
-
- getLatin();
- setLatin(true);
-
- doNothing();
-
- deer::moose foo();
-
-
-}
-
-moose deer::alces::createMoose()
-{
- moose MooseVariableName;
- bool tmp;
- int itmp;
- bool fool;
- int fast;
-
- MooseVariableName = createMoose();
-
- doLatinStuff(MooseVariableName);
-
- tmp = this.f// -1-
- // #1# ( "fAlcesBool" "fIsValid" "fLatin" )
- ;
-
- itmp = this.f// -2-
- // #2# ( "fAlcesInt" "fGreek" "fIsProtectedInt" )
- ;
-
- tmp = f// -3-
- // #3# ( "fAlcesBool" "fIsValid" "fLatin" "fool" )
- ;
-
- itmp = f// -4-
- // #4# ( "fAlcesInt" "fGreek" "fIsProtectedInt" "fast" )
- ;
-
- MooseVariableName = m// -5-
- // #5# ( "moose" )
-
- return MooseVariableName;
-}
-
-/** Test Scope Changes
- *
- * This function is rigged to make sure the scope changes to account
- * for different locations in local variable parsing.
- */
-int someFunction(int mPickle)
-{
- moose mMoose = deer::alces::createMoose();
-
- if (mPickle == 1) {
-
- int mOption1 = 2;
-
- m// -5-
- // #5# ( "mMoose" "mOption1" "mPickle" )
- ;
-
- } else {
-
- int mOption2 = 2;
-
- m// -6-
- // #6# ( "mMoose" "mOption2" "mPickle" )
- ;
- }
-
-}
-
-// Thanks Ming-Wei Chang for this next example.
-
-namespace pub_priv {
-
- class A{
- private:
- void private_a(){}
- public:
- void public_a();
- };
-
- void A::public_a() {
- A other_a;
-
- other_a.p// -7-
- // #7# ( "private_a" "public_a" )
- ;
- }
-
- int some_regular_function(){
- A a;
- a.p// -8-
- // #8# ( "public_a" )
- ;
- return 0;
- }
-
-}
-
-
-/** Test Scope w/in a function (non-method) with classes using
- * different levels of inheritance.
- */
-int otherFunction()
-{
- sneaky::antelope Antelope(1);
- sneaky::jackalope Jackalope(1);
- sneaky::bugalope Bugalope(1);
-
- Antelope.// -9-
- // #9# ( "fAntyPublic" "fQuadPublic" "testAccess")
- ;
-
- Jackalope.// -10-
- // #10# ( "fBunnyPublic" "testAccess")
- ;
-
- Jackalope// @1@ 6
- ;
- Jackalope;
- Jackalope;
- Jackalope;
-
- Bugalope.// -11-
- // #11# ( "fBugPublic" "testAccess")
- ;
- Bugalope// @2@ 3
- ;
-}
-
-/** Test methods within each class for types of access to the baseclass.
- */
-
-bool sneaky::antelope::testAccess() //^7^
-{
- this.// -12-
- // #12# ( "fAntyPrivate" "fAntyProtected" "fAntyPublic" "fQuadProtected" "fQuadPublic" "testAccess" )
- ;
-}
-
-bool sneaky::jackalope::testAccess() //^8^
-{
- this.// -13-
- // #13# ( "fBunnyPrivate" "fBunnyProtected" "fBunnyPublic" "fQuadProtected" "fQuadPublic" "testAccess" )
- ;
-}
-
-bool sneaky::bugalope::testAccess() //^9^
-{
- this.// -14-
- // #14# ( "fBugPrivate" "fBugProtected" "fBugPublic" "fQuadPublic" "testAccess" )
- ;
-}
+++ /dev/null
-// testsubclass.hh --- unit test for analyzer and complex C++ inheritance
-
-// Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-
-//#include <cmath>
-// #include <stdio.h>
-
-#ifndef TESTSUBCLASS_HH
-#define TESTSUBCLASS_HH
-
-namespace animal {
-
- class moose {
- public:
- moose() : fFeet(0),
- fIsValid(false)
- { }
-
- virtual void setFeet(int);
- int getFeet();
-
- void doNothing();
-
- enum moose_enum {
- NAME1, NAME2, NAME3 };
-
-
- protected:
-
- bool fIsValid;
- int fIsProtectedInt;
-
- private:
- int fFeet; // Usually 2 or 4.
- bool fIsPrivateBool;
-
- }; // moose
-
- int two_prototypes();
- int two_prototypes();
-
- class quadruped {
- public:
- quadruped(int a) : fQuadPrivate(a)
- { }
-
- int fQuadPublic;
-
- protected:
- int fQuadProtected;
-
- private:
- int fQuadPrivate;
-
- };
-
-}
-
-
-namespace deer {
-
- class moose : public animal::moose {
- public:
- moose() : fAntlers(false)
- { }
-
- void setAntlers(bool);
- bool getAntlers();
-
- void doSomething();
-
- protected:
-
- bool fSomeField;
-
- private:
- bool fAntlers;
-
- };
-
-} // deer
-
-// A second namespace of the same name will test the
-// namespace merging needed to resolve deer::alces
-namespace deer {
-
- class alces : public animal::moose {
- public:
- alces(int lat) : fLatin(lat)
- { }
-
- void setLatin(bool);
- bool getLatin();
-
- void doLatinStuff(moose moosein); // for completion testing
-
- moose createMoose(); // for completion testing.
-
- protected:
- bool fAlcesBool;
- int fAlcesInt;
-
- private:
- bool fLatin;
- int fGreek;
- };
-
-};
-
-// A third namespace with classes that does protected and private inheritance.
-namespace sneaky {
-
- class antelope : public animal::quadruped {
-
- public:
- antelope(int a) : animal::quadruped(),
- fAntyProtected(a)
- {}
-
- int fAntyPublic;
-
- bool testAccess();
-
- protected:
- int fAntyProtected;
-
- private :
- int fAntyPrivate;
-
- };
-
- class jackalope : protected animal::quadruped {
-
- public:
- jackalope(int a) : animal::quadruped(),
- fBunny(a)
- {}
-
- int fBunnyPublic;
-
- bool testAccess();
-
- protected:
- bool fBunnyProtected;
-
- private :
- bool fBunnyPrivate;
-
- };
-
- // Nothing specified means private.
- class bugalope : /* private*/ animal::quadruped {
-
- public:
- bugalope(int a) : animal::quadruped(),
- fBug(a)
- {}
-
- int fBugPublic;
-
- bool testAccess();
- protected:
- bool fBugProtected;
-
- private :
- bool fBugPrivate;
-
- };
-
-
-};
-
-#endif
+++ /dev/null
-// testtemplates.cpp --- semantic-ia-utest completion engine unit tests
-
-// Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-
-// TODO - this probably means can't be part of emacs, as I don't know who this guy is.
-// Written by 'Raf'
-
-template <class T, int U, class V>
-class read_ref {
-public:
- const T* read_ref_member_one( T);
- const V* read_ref_member_two();
-};
-
-namespace NS {
- template <class T, int U, class V>
- class ref {
- public:
- read_ref<T,10,V> operator->() {
- m_// -1-
- ;
- // #1# ( "m_datas" )
- }
-
- private:
- T m_datas[U];
- };
-
-}
-
-class FooOne {
-public:
- int fooOneMember();
-};
-
-class FooTwo {
-public:
- int fooTwoMember();
-};
-
-class FooThree {
-public:
- int fooThreeMember();
-
- FooOne * operator->();
-};
-
-typedef ref<FooOne, 10,FooTwo> Test;
-
-using NS;
-
-void
-main(void) {
- ref<FooOne, 10, FooTwo> v;
-
- v->read_ref_member_one()-> // -2-
- ;
- // #2# ( "fooOneMember" )
-
- v->read_ref_member_two()-> // -3-
- ;
- // #3# ( "fooTwoMember" )
-
- v-> // -4-
- ;
- // #4# ( "read_ref_member_one" "read_ref_member_two" )
-
- Test t;
-
- t->read_ref_member_two()-> // -5-
- ;
- // #5# ( "fooTwoMember" )
-
- ref<FooOne, 10, FooThree> v2;
-
- v2->read_ref_member_two()-> // -6-
- ;
- // #6# ( "fooOneMember" )
-
- /* Try all these things by also specifying the namespace in the name. */
- NS::ref<FooOne, 10, FooTwo> v3;
-
- v3->read_ref_member_one()-> // -7-
- ;
- // #7# ( "fooOneMember" )
-
- v3->read_ref_member_two()-> // -8-
- ;
- // #8# ( "fooTwoMember" )
-
- v3->read_ref_member_two// @1@ 5
- ;
-
-}
-
-// More Namespace Magic using member constants.
-
-template<typename T>
-struct isFooLike {
- static const bool value = false;
-};
-
-template <>
-struct isFooLike<int> {
- static const bool value = true;
-};
-
-
-template <typename T, bool isFoo>
-class A {
-public:
- A();
- void foo() {};
-};
-
-
-template <typename T>
-class FooFour : public A<T, isPodLike<T>::value> {
-public:
- bool bar() {}
-};
-
-
-int main2() {
-
- FooFour<int> ff;
-
- ff.// - 9- @ TODO - bring over patch from SF
- ; // #9# ( "bar" "foo" );
-
-}
+++ /dev/null
-// testtypedefs.cpp --- Sample with some fake bits out of std::string
-
-// Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-// Thanks Ming-Wei Chang for these examples.
-
-namespace std {
- template <T>class basic_string {
- public:
- void resize(int);
- };
-}
-
-typedef std::basic_string<char> mstring;
-
-using namespace std;
-typedef basic_string<char> bstring;
-
-int main(){
- mstring a;
- a.// -1-
- ;
- // #1# ( "resize" )
- bstring b;
- // It doesn't work here.
- b.// -2-
- ;
- // #2# ( "resize" )
- return 0;
-}
-
-// ------------------
-
-class Bar
-{
-public:
- void someFunc() {}
-};
-
-typedef Bar new_Bar;
-
-template <class mytype>
-class TBar
-{
-public:
- void otherFunc() {}
-};
-
-typedef TBar<char> new_TBar;
-
-int main()
-{
- new_Bar nb;
- new_TBar ntb;
-
- nb.// -3-
- ;
- // #3# ("someFunc")
- ntb.// -4-
- ;
- // #4# ("otherFunc")
-
- return 0;
-}
-
-// ------------------
-// Example from Yupeng.
-
-typedef struct epd_info {
- int a;
-} epd_info_t;
-
-static int epd_probe(struct platform_device *pdev)
-{
- struct epd_info *db;
- epd_info_t db1;
-
- db.// -5-
- ; // #5# ("a")
- db1.// -6-
- ;// #6# ("a")
-
- return 1;
-}
-
-// ------------------
-// Example from Michel LAFON-PUYO
-
-typedef enum
-{
- ENUM1,
- ENUM2
-} e_toto;
-
-typedef struct
-{
- int field_a;
- int field_b;
-} t_toto;
-
-// Note: Error condition from anonymous types in a typedef
-// was that the first (ie - the enum) would be used in
-// place of the struct.
-int func(void)
-{
- t_toto t;
- t. // -7-
- ; // #7# ( "field_a" "field_b" )
- return 0;
-}
-
-
-// ------------------
-// Example from Dixon Ryan
-
-
-namespace NS2 {
- class MyClass {
-
- public:
- void myFunction() { }
- };
-}
-
-typedef class NS2::MyClass* MyClassHandle;
-
-int dixon ( void ) {
- MyClassHandle mch = getMyClassHandle();
- NS2::MyClass* mcptr = getMyClassHandle();
-
- mcptr-> // -8-
- ; // #8# ( "myFunction" )
- mch-> // - 9- TODO bring over patch from SF
- ; // #9# ( "myFunction" )
- deleteMyClassHandle(mch);
-
- return 0;
-}
+++ /dev/null
-// testusing.cpp --- semantic-ia-utest completion engine unit tests
-
-// Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-
-#include <adstdio.h>
-
-#include <testusing.hh>
-
-namespace moose {
-
- class MyClass;
- class Point;
-
- typedef MyClass snerk;
-}
-
-namespace moose {
-
- class Point;
- class MyClass;
-
-}
-
-namespace {
-
- int global_variable = 0;
-
-};
-
-using moose::MyClass;
-
-void someFcn() {
-
- MyClass f;
-
- f.//-1-
- ; //#1# ( "getVal" "setVal" )
-
-}
-
-// Code from Zhiqiu Kong
-
-namespace panda {
-
- using namespace bread_name;
-
- int func()
- {
- bread test;
- test.//-2-
- ;// #2# ( "geta" )
- return 0;
- }
-}
-
-namespace togglemoose {
-
- MyOtherClass::testToggle1() { //^1^
- // Impl for testToggle1
- }
-}
-
-togglemoose::MyOtherClass::testToggle2() { //^3^
- // Impl for testToggle2
-}
-
-using togglemoose;
-
-MyOtherClass::testToggle3() { //^3^
- // Impl for testToggle3
-}
-
-// Local using statements and aliased types
-// Code from David Engster
-
-void func2()
-{
- using namespace somestuff;
- OneClass f;
- f.//-3-
- ; //#3# ( "aFunc" "anInt" )
-}
-
-void func3()
-{
- using somestuff::OneClass;
- OneClass f;
- f.//-4-
- ; //#4# ( "aFunc" "anInt" )
-}
-
-// Dereferencing alias types created through 'using' statements
-
-// Alias with fully qualified name
-void func4()
-{
- otherstuff::OneClass f;
- f. //-5-
- ; //#5# ( "aFunc" "anInt" )
-}
-
-// Alias through namespace directive
-void func5()
-{
- using namespace otherstuff;
- OneClass f;
- f. //-6-
- ; //#6# ( "aFunc" "anInt" )
-}
-
-// Check name hiding
-void func6()
-{
- using namespace morestuff;
- OneClass f; // Alias for somestuff::OneClass
- f. //-7-
- ; //#7# ( "aFunc" "anInt" )
- aStruct g; // This however is morestuff::aStruct !
- g. //-8-
- ; //#8# ( "anotherBar" "anotherFoo" )
-}
-
-// Alias of an alias
-// Currently doesn't work interactively for some reason.
-void func6()
-{
- using namespace evenmorestuff;
- OneClass f;
- f. //-7-
- ; //#7# ( "aFunc" "anInt" )
-}
-
-// Alias for struct in nested namespace, fully qualified
-void func7()
-{
- outer::StructNested f;
- f.//-8-
- ; //#8# ( "one" "two" )
-}
-
-// Alias for nested namespace
-void func8()
-{
- using namespace outerinner;
- StructNested f;
- AnotherStruct g;
- f.//-9-
- ; //#9# ( "one" "two" )
- g.//-10-
- ; //#10# ( "four" "three" )
-}
-
-// Check conventional namespace aliases
-// - fully qualified -
-void func9()
-{
- alias_for_somestuff::OneClass c;
- c.//-11-
- ; //#11# ( "aFunc" "anInt" )
- alias_for_outerinner::AnotherStruct s;
- s. //-12-
- ; //#12# ( "four" "three" )
-}
-
-// - unqualified -
-void func10()
-{
- using namespace alias_for_somestuff;
- OneClass c2;
- c2.//-13-
- ; //#13# ( "aFunc" "anInt" )
- using namespace alias_for_outerinner;
- AnotherStruct s2;
- s2.//-14-
- ; //#14# ( "four" "three" )
-}
-
-// Completion on namespace aliases
-void func11()
-{
- alias_for_somestuff:://-15-
- ; //#15# ( "OneClass" "aStruct")
- alias_for_outerinner:://-16-
- ; //#16# ( "AnotherStruct" "StructNested" )
-}
-
-// make sure unfound using statements don't crash stuff.
-using something::cantbe::Found;
-
-void unfoundfunc()
-{
- NotFound notfound; // Variable can't be found.
-
- notfound.//-17-
- ; //#17# ( ) Nothing here since this is an undefined class
-
-}
-
-// Using statements can depend on previous ones...
-
-void acc_using()
-{
- using namespace outer;
- // This is effectively like 'using namespace outer::inner'
- using namespace inner;
-
- StructNested sn;
- sn.//-18-
- ; //#18# ( "one" "two" )
-}
-
-// Check the same outside of function scope
-
-using namespace outer;
-using namespace inner;
-
-void acc_using2()
-{
- StructNested sn;
- sn.//-19-
- ; //#19# ( "one" "two" )
-}
-
-// Check if scope gets correctly generated, i.e., without us providing any
-// hints in the form of an existing type
-
-void check_scope()
-{
- using namespace first;
- AAA//-20-
- ; //#20# ( "AAA1" "AAA2" )
-}
-
-void check_scope2()
-{
- using namespace third;
- AAA//-21-
- ; //#21# ( "AAA1" "AAA2" "AAA3" )
-}
-
-// Make sure this also works not only in functions
-
-namespace check_scope3 {
- using namespace first;
- AAA//-22-
- ; //#22# ( "AAA1" "AAA2" )
-}
+++ /dev/null
-// testusing.hh --- semantic-ia-utest completion engine unit tests
-
-// Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-namespace moose {
-
- class Point;
-
- class MyClass;
-
-}
-
-
-namespace moose {
-
- class Point;
-
- class MyClass {
- public:
- MyClass() : fVal(0) {
- }
-
- ~MyClass() {};
-
- /**
- * fVal Accessors
- * @{
- */
- int getVal() const {
- return fVal;
- }
- void setVal(int Val) const {
- fVal = Val;
- }
- /**
- * @}
- */
-
- private:
- int fVal;
- };
-
-}
-
-namespace togglemoose {
-
- class MyOtherClass {
- public:
- int testToggle1();
- int testToggle2();
- int testToggle3();
- };
-}
-
-namespace deer {
-
- class Pickle;
-
-};
-
-// Code from Zhiqiu Kong
-
-#ifndef BREAD_H
-#define BREAD_H
-
-namespace bread_name {
- class bread
- {
- public:
- void geta();
- private:
- int m_a;
- int m_b;
- };
-}
-
-#endif
-
-// Code from David Engster
-// Creating alias types through 'using' trickery
-
-namespace somestuff {
- class OneClass {
- public:
- void aFunc();
- int anInt;
- };
- struct aStruct {
- int foo;
- int bar;
- };
-}
-
-namespace otherstuff {
- // make otherstuff::OneClass an alias for somestuff::OneClass
- using somestuff::OneClass;
-}
-
-namespace morestuff {
- // make morestuff an alias namespace for somestuff
- using namespace somestuff;
- // but hide aStruct with own type
- struct aStruct {
- int anotherFoo;
- int anotherBar;
- };
-}
-
-// We can also create an alias for an alias
-namespace evenmorestuff {
- using otherstuff::OneClass;
-}
-
-// Now with nested namespaces
-namespace outer {
- namespace inner {
- struct StructNested {
- int one;
- int two;
- };
- struct AnotherStruct {
- int three;
- int four;
- };
- }
-}
-
-// Namespace which pulls in one of its own nested namespaces
-namespace first {
- class AAA1;
- namespace second {
- class AAA2;
- }
- // Elevate nested namespace into first one
- using namespace second;
-}
-
-namespace third {
- using namespace first;
- class AAA3;
-}
-
-
-// Elevate the first struct into 'outer'
-// so that we can access it via 'outer::StructNested'
-namespace outer {
- using outer::inner::StructNested;
-}
-
-// Create an alias for a nested namespace
-namespace outerinner {
- // equivalent to 'namespace outerinner = outer::inner;'
- using namespace outer::inner;
-}
-
-// Create namespace alias
-namespace alias_for_somestuff = somestuff;
-// Same for nested namespace
-namespace alias_for_outerinner = outer::inner;
+++ /dev/null
-/* testvarnames.cpp --- semantic-ia-utest completion engine unit tests
-
- Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-*/
-
-struct independent {
- int indep_1;
- int indep_2;
-};
-
-struct independent var_indep_struct;
-
-struct {
- int unnamed_1;
- int unnamed_2;
-} var_unnamed_struct;
-
-struct {
- int unnamed_3;
- int unnamed_4;
-} var_un_2, var_un_3;
-
-struct inlinestruct {
- int named_1;
- int named_2;
-} var_named_struct;
-
-struct inline2struct {
- int named_3;
- int named_4;
-} var_n_2, var_n_3;
-
-/* Structures with names that then declare variables
- * should also be completable.
- *
- * Getting this to work is the bugfix in semantic-c.el CVS v 1.122
- */
-struct inlinestruct in_var1;
-struct inline2struct in_var2;
-
-/*
- * Structures (or any types) could have the same name as a variable.
- * Make sure we complete vars over types.
- *
- * See cedet-devel mailing list Dec 23, 2013 for details.
- */
-struct varorstruct {};
-int varorstruct;
-
-int assigntovarorstruct;
-
-int test_1(int var_arg1) {
-
- var_// -1-
- ; // #1# ("var_arg1" "var_indep_struct" "var_n_2" "var_n_3" "var_named_struct" "var_un_2" "var_un_3" "var_unnamed_struct")
-
- var_indep_struct.// -2-
- ; // #2# ( "indep_1" "indep_2" )
-
- var_unnamed_struct.// -3-
- ; // #3# ( "unnamed_1" "unnamed_2" )
-
- var_named_struct.// -4-
- ; // #4# ( "named_1" "named_2" )
-
- var_un_2.// -5-
- ; // #5# ( "unnamed_3" "unnamed_4" )
- var_un_3.// -6-
- ; // #6# ( "unnamed_3" "unnamed_4" )
-
- var_n_2.// -7-
- ; // #7# ( "named_3" "named_4" )
- var_n_3.// -8-
- ; // #8# ( "named_3" "named_4" )
-
- in_// -9-
- ; // #9# ( "in_var1" "in_var2" )
-
- in_var1.// -10-
- ; // #10# ( "named_1" "named_2")
- in_var2.// -11-
- ; // #11# ( "named_3" "named_4")
-
- varorstruct = assign// -12-
- ; // #12# ( "assigntovarorstruct" )
-}
+++ /dev/null
-// testvarnames.java --- Semantic unit test for Java
-
-// Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
-
-package tests;
-
-/**
- *
- *
- * Created: 02/17/14
- *
- * @author Eric M. Ludlam
- * @version
- * @since
- */
-public class testvarnames {
-
- public class varorclass {
- public static long misclongvalue;
- };
-
- public static varorclass varoftypevarorclass = NULL;
-
- public static long varorclass = 1;
-
- public static long assignintovar = 1;
-
- public static varorclass classassign = NULL;
-
- static public void main(String [] args) {
-
- varorclass = assign// -1-
- // #1# ( "assignintovar" )
- ;
-
- varoftypevarorclass = clas// -2-
- // #2# ( "classassign" )
-
- varoftypevarorclass.misc//-3-
- // #3# ( "misclongvalue" )
- }
-
-} // testvarnames
+++ /dev/null
-;; testwisent.wy --- unit test support file for semantic-utest-ia
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Parser for nothing in particular mode
-
-%languagemode nothing-mode
-%parsetable wisent-nothing-parser-tables
-%keywordtable wisent-nothing-keywords
-%tokentable wisent-nothing-tokens
-%languagemode nothing-mode
-%setupfunction wisent-nothing-default-setup
-
-%start goal
-
-;;; Punctuation
-%type <punctuation> ;;syntax "\\(\\s.\\|\\s$\\|\\s'\\)+" matchdatatype string
-
-%token <punctuation> DOT "."
-%token <punctuation> COMA ","
-%token <punctuation> COLONCOLON "::"
-%token <punctuation> COLON ":"
-%token <punctuation> SEMICOLON ";"
-
-;;; KEYWORDS
-%type <keyword>
-
-%keyword COLONOSCOPY "colonoscopy"
-%keyword SEMISOMETHING "semisomething"
-
-%%
-
-goal
- ;; Misc
- : COLON ;; -1-
- ;; #1# ( "COLONCOLON" "COLON" "COLONOSCOPY" )
- | SEMI ;; -2-
- ;; #2# ( "SEMI_useless_rule" "SEMICOLON" "SEMISOMETHING" )
- | thing ;; -3-
- ;; #3# ( "thing_term_1" "thing_term_2" )
- ;
-
-SEMI_useless_rule
- :
- ;
-
-thing_term_1
- :
- ;
-
-thing_term_2
- :
- ;
-
-%%
-(define-lex wisent-nothing-lexer
- "Lexical analyzer to handle nothing in particular buffers."
- ;; semantic-lex-newline
- semantic-lex-ignore-whitespace
- semantic-lex-ignore-newline
- semantic-lex-ignore-comments
-
- semantic-lex-default-action
- )
-
-;; testwisent.wy ends here
\ No newline at end of file
+++ /dev/null
-;;; semantic-utest-ia.el --- Analyzer unit tests -*- lexical-binding:t -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Use marked-up files in the test directory and run the analyzer
-;; on them. Make sure the answers are correct.
-;;
-;; Each file has cursor keys in them of the form:
-;; // -#- ("ans1" "ans2" )
-;; where # is 1, 2, 3, etc, and some sort of answer list.
-;; (Replace // with contents of comment-start for the language being tested.)
-
-;;; Code:
-(require 'ert)
-(require 'ert-x)
-(require 'semantic)
-(require 'semantic/analyze)
-(require 'semantic/analyze/refs)
-(require 'semantic/symref)
-(require 'semantic/symref/filter)
-
-(ert-deftest semantic-utest-ia-doublens.cpp ()
- (let ((tst (ert-resource-file "testdoublens.cpp")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-subclass.cpp ()
- (let ((tst (ert-resource-file "testsubclass.cpp")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-typedefs.cpp ()
- (let ((tst (ert-resource-file "testtypedefs.cpp")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-struct.cpp ()
- (let ((tst (ert-resource-file "teststruct.cpp")))
- (should-not (semantic-ia-utest tst))))
-
-;;(ert-deftest semantic-utest-ia-union.cpp ()
-;; (let ((tst (ert-resource-file "testunion.cpp")))
-;; (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-templates.cpp ()
- (let ((tst (ert-resource-file "testtemplates.cpp")))
- (should-not (semantic-ia-utest tst))))
-
-;;(ert-deftest semantic-utest-ia-friends.cpp ()
-;; (let ((tst (ert-resource-file "testfriends.cpp")))
-;; (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-using.cpp ()
- (let ((tst (ert-resource-file "testusing.cpp")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-nsp.cpp ()
- (skip-unless (executable-find "g++"))
- (let ((tst (ert-resource-file "testnsp.cpp")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-localvars.cpp ()
- (let ((tst (ert-resource-file "testlocalvars.cpp")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-namespace.cpp ()
- (skip-unless (executable-find "g++"))
- (let ((tst (ert-resource-file "testnsp.cpp")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-sppcomplete.c ()
- (let ((tst (ert-resource-file "testsppcomplete.c")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-varnames.c ()
- (let ((tst (ert-resource-file "testvarnames.c")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-javacomp.java ()
- (let ((tst (ert-resource-file "testjavacomp.java")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-varnames.java ()
- (let ((tst (ert-resource-file "testvarnames.java")))
- (should-not (semantic-ia-utest tst))))
-
-;;(ert-deftest semantic-utest-ia-f90.f90 ()
-;; (let ((tst (ert-resource-file "testf90.f90")))
-;; (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-wisent.wy ()
- (let ((tst (ert-resource-file "testwisent.wy")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-texi ()
- (let ((tst (ert-resource-file "test.texi")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-make ()
- (let ((tst (ert-resource-file "test.mk")))
- (should-not (semantic-ia-utest tst))))
-
-(ert-deftest semantic-utest-ia-srecoder ()
- (let ((tst (ert-resource-file "test.srt")))
- (should-not (semantic-ia-utest tst))))
-
-;;; Core testing utility
-(defun semantic-ia-utest (testfile)
- "Run the semantic ia unit test against stored sources."
- (semantic-mode 1)
- (let ((b (semantic-find-file-noselect testfile t)))
-
- ;; Run the test on it.
- (with-current-buffer b
-
- ;; This line will also force the include, scope, and typecache.
- (semantic-clear-toplevel-cache)
- ;; Force tags to be parsed.
- (semantic-fetch-tags)
-
- (prog1
- (or (semantic-ia-utest-buffer)
- (semantic-ia-utest-buffer-refs)
- (semantic-sr-utest-buffer-refs)
- (semantic-src-utest-buffer-refs))
-
- (kill-buffer b)
- ))))
-
-(defun semantic-ia-utest-buffer ()
- "Run analyzer completion unit-test pass in the current buffer."
-
- (let* ((idx 1)
- (regex-p nil)
- (regex-a nil)
- (p nil)
- (a nil)
- (pass nil)
- (fail nil)
- (actual nil)
- (desired nil)
- ;; Exclude unpredictable system files in the
- ;; header include list.
- (semanticdb-find-default-throttle
- (remq 'system semanticdb-find-default-throttle))
- )
-
- ;; Keep looking for test points until we run out.
- (while (save-excursion
- (setq regex-p (concat "\\(" comment-start-skip "\\)\\s-*-"
- (number-to-string idx) "-" )
- regex-a (concat "\\(" comment-start-skip "\\)\\s-*#"
- (number-to-string idx) "#" ))
- (goto-char (point-min))
- (save-match-data
- (when (re-search-forward regex-p nil t)
- (setq p (match-beginning 0))))
- (save-match-data
- (when (re-search-forward regex-a nil t)
- (setq a (match-end 0))))
- (and p a))
-
- (save-excursion
-
- (goto-char p)
- (skip-chars-backward " ") ;; some languages need a space.
-
- (let* ((ctxt (semantic-analyze-current-context))
- ;; TODO - fix the NOTFOUND case to be nil and not an error when finding
- ;; completions, then remove the below debug-on-error setting.
- (debug-on-error nil)
- (acomp
- (condition-case _err
- (semantic-analyze-possible-completions ctxt)
- ((error user-error) nil))
- ))
- (setq actual (mapcar 'semantic-format-tag-name acomp)))
-
- (goto-char a)
-
- (let ((bss (buffer-substring-no-properties (point) (pos-eol))))
- (condition-case nil
- (setq desired (read bss))
- (error (setq desired (format " FAILED TO PARSE: %S"
- bss)))))
-
- (setq actual (sort actual 'string<))
- (setq desired (sort desired 'string<))
-
- (if (equal actual desired)
- (prog1
- (setq pass (cons idx pass))
- ;;(message "PASS: %S" actual)
- )
- (setq fail (cons
- (list
- (format "Failed %d. Desired: %S Actual %S"
- idx desired actual)
- )
- fail)))
-
- (setq p nil a nil)
- (setq idx (1+ idx)))
- )
-
- (when fail
- (cons "COMPLETION SUBTEST" (reverse fail)))
- ))
-
-(defun semantic-ia-utest-buffer-refs ()
- "Run an analyze-refs unit-test pass in the current buffer."
-
- (let* ((idx 1)
- (regex-p nil)
- (p nil)
- (pass nil)
- (fail nil)
- ;; Exclude unpredictable system files in the
- ;; header include list.
- (semanticdb-find-default-throttle
- (remq 'system semanticdb-find-default-throttle))
- )
- ;; Keep looking for test points until we run out.
- (while (save-excursion
- (setq regex-p (concat "\\(" comment-start-skip
- "\\)\\s-*\\^" (number-to-string idx) "^" )
- )
- (goto-char (point-min))
- (save-match-data
- (when (re-search-forward regex-p nil t)
- (setq p (match-beginning 0))))
- p)
-
- (save-excursion
-
- (goto-char p)
- (forward-char -1)
-
- (let* ((ct (semantic-current-tag))
- (refs (semantic-analyze-tag-references ct))
- (impl (semantic-analyze-refs-impl refs t))
- (proto (semantic-analyze-refs-proto refs t))
- (pf nil)
- )
- (setq
- pf
- (catch 'failed
- (if (and impl proto (car impl) (car proto))
- (let (ct2 ref2 impl2 proto2
- newstart)
- (cond
- ((semantic-equivalent-tag-p (car impl) ct)
- ;; We are on an IMPL. Go To the proto, and find matches.
- (semantic-go-to-tag (car proto))
- (setq newstart (car proto))
- )
- ((semantic-equivalent-tag-p (car proto) ct)
- ;; We are on a PROTO. Go to the imple, and find matches
- (semantic-go-to-tag (car impl))
- (setq newstart (car impl))
- )
- (t
- ;; No matches is a fail.
- (throw 'failed t)
- ))
- ;; Get the new tag, does it match?
- (setq ct2 (semantic-current-tag))
-
- ;; Does it match?
- (when (not (semantic-equivalent-tag-p ct2 newstart))
- (throw 'failed t))
-
- ;; Can we double-jump?
- (setq ref2 (semantic-analyze-tag-references ct)
- impl2 (semantic-analyze-refs-impl ref2 t)
- proto2 (semantic-analyze-refs-proto ref2 t))
-
- (when (or (not (and impl2 proto2))
- (not
- (and (semantic-equivalent-tag-p
- (car impl) (car impl2))
- (semantic-equivalent-tag-p
- (car proto) (car proto2)))))
- (throw 'failed t))
- )
-
- ;; Else, no matches at all, so another fail.
- (throw 'failed t)
- )))
-
- (if (not pf)
- ;; We passed
- (setq pass (cons idx pass))
- ;; We failed.
- (setq fail (cons
- (list
- (message "Test id %d. For %s (Num impls %d) (Num protos %d)"
- idx (if ct (semantic-tag-name ct) "<No tag found>")
- (length impl) (length proto))
- )
- fail))
- ))
- (setq p nil)
- (setq idx (1+ idx))))
- (when fail
- (cons "ANALYZER REF COUNTING SUBTEST" fail))))
-
-(defun semantic-sr-utest-buffer-refs ()
- "Run a symref unit-test pass in the current buffer."
-
- ;; This line will also force the include, scope, and typecache.
- (semantic-clear-toplevel-cache)
- ;; Force tags to be parsed.
- (semantic-fetch-tags)
-
- (let* ((idx 1)
- (tag nil)
- (regex-p nil)
- (desired nil)
- (actual-result nil)
- (actual nil)
- (pass nil)
- (fail nil)
- (symref-tool-used nil)
- ;; Exclude unpredictable system files in the
- ;; header include list.
- (semanticdb-find-default-throttle
- (remq 'system semanticdb-find-default-throttle))
- )
- ;; Keep looking for test points until we run out.
- (while (save-excursion
- (setq regex-p (concat "\\(" comment-start-skip "\\)\\s-*\\%"
- (number-to-string idx) "%" )
- )
- (goto-char (point-min))
- (save-match-data
- (when (re-search-forward regex-p nil t)
- (setq tag (semantic-current-tag))
- (goto-char (match-end 0))
- (setq desired (read (buffer-substring (point) (pos-eol))))
- ))
- tag)
-
- (setq actual-result (semantic-symref-find-references-by-name
- (semantic-format-tag-name tag) 'target
- 'symref-tool-used))
-
- (if (not actual-result)
- (progn
- (setq fail (cons idx fail))
- (message "Failed Tool: %s" (eieio-object-name symref-tool-used))
- )
-
- (setq actual (list (sort (mapcar
- 'file-name-nondirectory
- (semantic-symref-result-get-files actual-result))
- 'string<)
- (sort
- (mapcar
- 'semantic-format-tag-canonical-name
- (semantic-symref-result-get-tags actual-result))
- 'string<)))
-
-
- (if (equal desired actual)
- ;; We passed
- (setq pass (cons idx pass))
- ;; We failed.
- (setq fail
- (cons (list
- (when (not (equal (car actual) (car desired)))
- (list
- (format "Actual: %S Desired: %S"
- (car actual) (car desired))
- (format "Failed Tool: %s" (eieio-object-name symref-tool-used))
- ))
- (when (not (equal (car (cdr actual)) (car (cdr desired))))
- (list (format
- "Actual: %S Desired: %S"
- (car (cdr actual)) (car (cdr desired)))
- (format
- "Failed Tool: %s" (eieio-object-name symref-tool-used)))))
- fail))
- ))
-
- (setq idx (1+ idx))
- (setq tag nil))
-
- (when fail
- (cons "SYMREF SUBTEST" fail))))
-
-(defun semantic-symref-test-count-hits-in-tag ()
- "Lookup in the current tag the symbol under point.
-Then count all the other references to the same symbol within the
-tag that contains point, and return that."
- (interactive)
- (let* ((ctxt (semantic-analyze-current-context))
- (target (car (reverse (oref ctxt prefix))))
- (tag (semantic-current-tag))
- (Lcount 0))
- (when (semantic-tag-p target)
- (semantic-symref-hits-in-region
- target (lambda (_start _end _prefix) (setq Lcount (1+ Lcount)))
- (semantic-tag-start tag)
- (semantic-tag-end tag))
- Lcount)))
-
-(defun semantic-src-utest-buffer-refs ()
- "Run a sym-ref counting unit-test pass in the current buffer."
-
- ;; This line will also force the include, scope, and typecache.
- (semantic-clear-toplevel-cache)
- ;; Force tags to be parsed.
- (semantic-fetch-tags)
-
- (let* ((idx 1)
- (start nil)
- (regex-p nil)
- (desired nil)
- (actual nil)
- (pass nil)
- (fail nil)
- ;; Exclude unpredictable system files in the
- ;; header include list.
- (semanticdb-find-default-throttle
- (remq 'system semanticdb-find-default-throttle))
- )
- ;; Keep looking for test points until we run out.
- (while (save-excursion
- (setq regex-p (concat "\\(" comment-start-skip "\\)\\s-*@"
- (number-to-string idx)
- "@\\s-+\\w+" ))
- (goto-char (point-min))
- (save-match-data
- (when (re-search-forward regex-p nil t)
- (goto-char (match-end 0))
- (skip-syntax-backward "w")
- (setq desired (read (buffer-substring (point) (pos-eol))))
- (setq start (match-beginning 0))
- (goto-char start)
- (setq actual (semantic-symref-test-count-hits-in-tag))
- start)))
-
- (if (not actual)
- (progn
- (setq fail (cons
- (list
- (format
- "Symref id %d: No results." idx))
- fail))
-
- )
-
- (if (equal desired actual)
- ;; We passed
- (setq pass (cons idx pass))
- ;; We failed.
- (setq fail (cons (list
- (when (not (equal actual desired))
- (format
- "Symref id %d: Actual: %S Desired: %S"
- idx actual desired)
- )
- )
- fail))
- ))
-
- (setq idx (1+ idx))
- )
-
- (when fail
- (cons "SYMREF COUNTING SUBTEST" fail))))
-
-(provide 'semantic-ia-utest)
-
-;;; semantic-utest-ia.el ends here
+++ /dev/null
-;;; semantic-utest.el --- Tests for semantic's parsing system. -*- lexical-binding:t -*-
-
-;; Copyright (C) 2003-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Semantic's parsing and partial parsing system is pretty complex.
-;; These unit tests attempt to emulate semantic's partial reparsing
-;; and full reparsing system, and anything else I may feel the urge
-;; to write a test for.
-
-(require 'cedet)
-(require 'semantic)
-
-;;; Code:
-
-(defvar cedet-utest-directory
- (let* ((C (file-name-directory (locate-library "cedet")))
- (D (expand-file-name "../../test/manual/cedet/" C)))
- D)
- "Location of test files for this test suite.")
-
-(defvar semantic-utest-test-directory (expand-file-name "tests" cedet-utest-directory)
- "Location of test files.")
-
-(defun semantic-utest-fname (name)
- "Create a filename for NAME in /tmp."
- (expand-file-name name temporary-file-directory))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for C tests
-
-(defvar semantic-utest-C-buffer-contents
- "/* Test file for C language for Unit Tests */
-
-#include <stdio.h>
-#include \"sutest.h\"
-
-struct mystruct1 {
- int slot11;
- char slot12;
- float slot13;
-};
-
-int var1;
-
-float funp1(char arg11, char arg12);
-
-char fun2(int arg_21, int arg_22) /*1*/
-{
- struct mystruct1 *ms1 = malloc(sizeof(struct mystruct1));
-
- char sv = calc_sv(var1);
-
- if (var1 == 0) {
- sv = 1;
- } else if (arg_21 == 0) {
- sv = 2;
- } else if (arg_22 == 0) {
- sv = 3;
- } else {
- sv = 4;
- }
-
- printf(\"SV = %d\\n\", sv);
-
- /* Memory Leak */
- ms1.slot1 = sv;
-
- return 'A' + sv;
-}
-"
- "Contents of a C buffer initialized by this unit test.
-Be sure to change `semantic-utest-C-name-contents' when you
-change this variable.")
-
-(defvar semantic-utest-C-h-buffer-contents
- "/* Test file for C language header file for Unit Tests */
-
-int calc_sv(int);
-
-"
- "Contents of a C header file buffer initialized by this unit test.")
-
-(defvar semantic-utest-C-filename (semantic-utest-fname "sutest.c")
- "File to open and erase during this test for C.")
-
-(defvar semantic-utest-C-filename-h
- (concat (file-name-sans-extension semantic-utest-C-filename)
- ".h")
- "Header file filename for C.")
-
-
-(defvar semantic-utest-C-name-contents
- '(("stdio.h" include
- (:system-flag t)
- nil (overlay 48 66 "sutest.c"))
- ("sutest.h" include nil nil (overlay 67 86 "sutest.c"))
- ("mystruct1" type
- (:members
- (("slot11" variable
- (:type "int")
- (reparse-symbol classsubparts)
- (overlay 109 120 "sutest.c"))
- ("slot12" variable
- (:type "char")
- (reparse-symbol classsubparts)
- (overlay 123 135 "sutest.c"))
- ("slot13" variable
- (:type "float")
- (reparse-symbol classsubparts)
- (overlay 138 151 "sutest.c")))
- :type "struct")
- nil (overlay 88 154 "sutest.c"))
- ("var1" variable
- (:type "int")
- nil (overlay 156 165 "sutest.c"))
- ("funp1" function
- (:prototype-flag t :arguments
- (("arg11" variable
- (:type "char")
- (reparse-symbol arg-sub-list)
- (overlay 179 190 "sutest.c"))
- ("arg12" variable
- (:type "char")
- (reparse-symbol arg-sub-list)
- (overlay 191 202 "sutest.c")))
- :type "float")
- nil (overlay 167 203 "sutest.c"))
- ("fun2" function
- (:arguments
- (("arg_21" variable
- (:type "int")
- (reparse-symbol arg-sub-list)
- (overlay 215 226 "sutest.c"))
- ("arg_22" variable
- (:type "int")
- (reparse-symbol arg-sub-list)
- (overlay 227 238 "sutest.c")))
- :type "char")
- nil (overlay 205 566 "sutest.c")))
- "List of expected tag names for C.")
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Python tests
-
-(defvar semantic-utest-Python-buffer-contents
-"
-def fun1(a,b,c):
- return a
-
-def fun2(a,b,c): #1
- return b
-
-"
-
-
-)
-; "python test case. notice that python is indentation sensitive
-
-
-(defvar semantic-utest-Python-name-contents
- '(("fun1" function
- (:arguments
- (("a" variable nil
- (reparse-symbol function_parameters)
- (overlay 10 11 "tst.py"))
- ("b" variable nil
- (reparse-symbol function_parameters)
- (overlay 12 13 "tst.py"))
- ("c" variable nil
- (reparse-symbol function_parameters)
- (overlay 14 15 "tst.py"))))
- nil (overlay 1 31 "tst.py"))
- ("fun2" function
- (:arguments
- (("a" variable nil
- (reparse-symbol function_parameters)
- (overlay 41 42 "tst.py"))
- ("b" variable nil
- (reparse-symbol function_parameters)
- (overlay 43 44 "tst.py"))
- ("c" variable nil
- (reparse-symbol function_parameters)
- (overlay 45 46 "tst.py"))))
- nil (overlay 32 65 "tst.py")))
-
- "List of expected tag names for Python.")
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Java tests
-
-(defvar semantic-utest-Java-buffer-contents
-"
-class JavaTest{
- void fun1(int a,int b){
- return a;
- }
-
- void fun2(int a,int b){ //1
- return b;
- }
-
-}
-"
-)
-
-(defvar semantic-utest-Java-name-contents
- '(("JavaTest" type
- (:members
- (("fun1" function
- (:arguments
- (("a" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 30 35 "JavaTest.java"))
- ("b" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 36 41 "JavaTest.java")))
- :type "void")
- (reparse-symbol class_member_declaration)
- (overlay 20 61 "JavaTest.java"))
- ("fun2" function
- (:arguments
- (("a" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 75 80 "JavaTest.java"))
- ("b" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 81 86 "JavaTest.java")))
- :type "void")
- (reparse-symbol class_member_declaration)
- (overlay 65 110 "JavaTest.java")))
- :type "class")
- nil (overlay 2 113 "JavaTest.java")))
- "List of expected tag names for Java."
- )
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Javascript tests
-
-(defvar semantic-utest-Javascript-buffer-contents
-"
-function fun1(a, b){
- return a;
- }
-
-function fun2(a,b){ //1
- return b;
- }
-"
-)
-
-
-(defvar semantic-utest-Javascript-name-contents
- '(("fun1" function
- (:arguments
- (("a" variable nil
- (reparse-symbol FormalParameterList)
- (overlay 15 16 "tst.js"))
- ("b" variable nil
- (reparse-symbol FormalParameterList)
- (overlay 18 19 "tst.js"))))
- nil (overlay 1 39 "tst.js"))
- ("fun2" function
- (:arguments
- (("a" variable nil
- (reparse-symbol FormalParameterList)
- (overlay 55 56 "tst.js"))
- ("b" variable nil
- (reparse-symbol FormalParameterList)
- (overlay 57 58 "tst.js"))))
- nil (overlay 41 82 "tst.js")))
-
- "List of expected tag names for Javascript.")
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Makefile tests
-
-(defvar semantic-utest-Makefile-buffer-contents
-"
-t1:
-\techo t1
-
-t2:t1 #1
-\techo t2
-
-
-"
-)
-
-
-(defvar semantic-utest-Makefile-name-contents
- '(("t1" function nil nil (overlay 1 9 "Makefile"))
- ("t2" function
- (:arguments
- ("t1"))
- nil (overlay 18 28 "Makefile")))
- "List of expected tag names for Makefile.")
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Scheme tests
-
-(defvar semantic-utest-Scheme-buffer-contents
- "
- (define fun1 2)
-
- (define fun2 3) ;1
-
-")
-
-(defvar semantic-utest-Scheme-name-contents
- '(("fun1" variable
- (:default-value ("2"))
- nil (overlay 3 18 "tst.scm"))
- ("fun2" variable
- (:default-value ("3"))
- nil (overlay 21 55 "tst.scm")))
- )
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Html tests
-
-(defvar semantic-utest-Html-buffer-contents
- "
-<html>
- <body>
- <h1>hello</h1>
- </body><!--1-->
-</html>
-"
- )
-
-(defvar semantic-utest-Html-name-contents
- '(("hello" section
- (:members
- (("hello" section nil nil (overlay 21 24 "tst.html"))))
- nil (overlay 10 15 "tst.html")))
- )
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for PHP tests
-
-(defvar semantic-utest-PHP-buffer-contents
- "<?php
-
-function fun1(){
- return \"fun1\";
-}
-
-function fun2($arg1){
- $output = \"argument to fun2: \" . $arg1;
- return $output;
-}
-
-class aClass {
- public function fun1($a, $b){
- return $a;
- }
-
- public function fun2($a, $b){
- return $b;
- }
-}
-?> "
- )
-
-(defvar semantic-utest-PHP-name-contents
- '(("fun1" function nil
- nil (overlay 9 45 "phptest.php"))
- ("fun2" function
- (:arguments (("$arg1" variable nil (reparse-symbol formal_parameters) (overlay 61 66 "phptest.php"))))
- nil
- (overlay 47 132 "phptest.php"))
- ("aClass" type
- (:members (("fun1" function
- (:typemodifiers ("public") :arguments
- (("$a" variable nil (reparse-symbol formal_parameters) (overlay 174 176 "phptest.php"))
- ("$b" variable nil (reparse-symbol formal_parameters) (overlay 178 180 "phptest.php"))))
-
- nil
- (overlay 153 204 "phptest.php"))
-
- ("fun2" function
- (:typemodifiers ("public") :arguments
- (("$a" variable nil (reparse-symbol formal_parameters) (overlay 230 232 "phptest.php"))
- ("$b" variable nil (reparse-symbol formal_parameters) (overlay 234 236 "phptest.php"))
- ))
- nil
- (overlay 209 260 "phptest.php"))) :type "class")
- nil
- (overlay 135 262 "phptest.php"))
- )
- "Expected results from the PHP Unit test.")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Data for Csharp C# tests
-
-(defvar semantic-utest-Csharp-buffer-contents
-"
-class someClass {
- int fun1(int a, int b) {
- return a; }
- int fun2(int a, int b) {
- return b; }
-}
-")
-
-(defvar semantic-utest-Csharp-name-contents
- '(("someClass" type
- (:members
- (("fun1" function
- (:arguments
- (("a" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 30 35 "tst.cs"))
- ("b" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 37 42 "tst.cs")))
- :type "int")
- (reparse-symbol class_member_declaration)
- (overlay 21 61 "tst.cs"))
- ("fun2" function
- (:arguments
- (("a" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 73 78 "tst.cs"))
- ("b" variable
- (:type "int")
- (reparse-symbol formal_parameters)
- (overlay 80 85 "tst.cs")))
- :type "int")
- (reparse-symbol class_member_declaration)
- (overlay 64 104 "tst.cs")))
- :type "class")
- nil (overlay 1 106 "tst.cs")))
- )
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-
-(defun semantic-utest-makebuffer (filename contents)
- "Create a buffer for FILENAME for use in a unit test.
-Pre-fill the buffer with CONTENTS."
- (let ((buff (semantic-find-file-noselect filename)))
- (set-buffer buff)
- (setq buffer-offer-save nil)
- (font-lock-mode -1) ;; Font lock has issues in Emacs 23
- (read-only-mode -1) ;; In case /tmp doesn't exist
- (erase-buffer)
- (insert contents)
- ;(semantic-fetch-tags) ;JAVE could this go here?
- (set-buffer-modified-p nil)
- buff
- )
- )
-
-(ert-deftest semantic-utest-C ()
- "Run semantic's C unit test."
- (semantic-mode 1)
- (save-excursion
- (let ((buff (semantic-utest-makebuffer semantic-utest-C-filename semantic-utest-C-buffer-contents))
- (buff2 (semantic-utest-makebuffer semantic-utest-C-filename-h semantic-utest-C-h-buffer-contents))
- )
- (semantic-fetch-tags)
- (set-buffer buff)
-
- ;; Turn off a range of modes
- (semantic-idle-scheduler-mode -1)
-
- ;; Turn on some modes
- (semantic-highlight-edits-mode 1)
-
- ;; Update tags, and show it.
- (semantic-fetch-tags)
-
- ;; Run the tests.
- ;;(message "First parsing test.")
- (should (semantic-utest-verify-names semantic-utest-C-name-contents))
-
- ;;(message "Invalid tag test.")
- (semantic-utest-last-invalid semantic-utest-C-name-contents '("fun2") "/\\*1\\*/" "/* Deleted this line */")
- (should (semantic-utest-verify-names semantic-utest-C-name-contents))
-
- (set-buffer-modified-p nil)
- ;; Clean up
- (kill-buffer buff)
- (kill-buffer buff2)
- )))
-
-
-
-
-(defun semantic-utest-generic (filename contents name-contents names-removed killme insertme)
- "Generic unit test according to template.
-Should work for languages without .h files, python javascript java.
-FILENAME is the name of the file to create.
-CONTENTS is the contents of the file to test.
-NAME-CONTENTS is the list of names that should be in the contents.
-NAMES-REMOVED is the list of names that gets removed in the removal step.
-KILLME is the name of items to be killed.
-INSERTME is the text to be inserted after the deletion."
- (semantic-mode 1)
- (save-excursion
- (let ((buff (semantic-utest-makebuffer filename contents))
- )
- ;; Turn off a range of modes
- (semantic-idle-scheduler-mode -1)
-
- ;; Turn on some modes
- (semantic-highlight-edits-mode 1)
-
- ;; Update tags, and show it.
- (semantic-clear-toplevel-cache)
- (semantic-fetch-tags)
- (switch-to-buffer buff)
- (sit-for 0)
-
- ;; Run the tests.
- (should (semantic-utest-verify-names name-contents))
-
- (semantic-utest-last-invalid name-contents names-removed killme insertme)
- (should (semantic-utest-verify-names name-contents))
-
- (set-buffer-modified-p nil)
- ;; Clean up
- (kill-buffer buff)
- )))
-
-(defvar python-indent-guess-indent-offset) ; Silence byte-compiler.
-(ert-deftest semantic-utest-Python()
- (skip-unless (fboundp 'python-mode))
- (let ((python-indent-guess-indent-offset nil))
- (semantic-utest-generic (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents semantic-utest-Python-name-contents '("fun2") "#1" "#deleted line")
- ))
-
-
-(ert-deftest semantic-utest-Javascript()
- (skip-unless (fboundp 'javascript-mode))
- (semantic-utest-generic (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line"))
-
-(ert-deftest semantic-utest-Java()
- ;; If JDE is installed, it might mess things up depending on the version
- ;; that was installed.
- (let ((auto-mode-alist '(("\\.java\\'" . java-mode))))
- (semantic-utest-generic (semantic-utest-fname "JavaTest.java") semantic-utest-Java-buffer-contents semantic-utest-Java-name-contents '("fun2") "//1" "//deleted line")
- ))
-
-(ert-deftest semantic-utest-Makefile()
- (semantic-utest-generic (semantic-utest-fname "Makefile") semantic-utest-Makefile-buffer-contents semantic-utest-Makefile-name-contents '("fun2") "#1" "#deleted line")
- )
-
-(ert-deftest semantic-utest-Scheme()
- (skip-unless nil) ;; There is a bug with scheme parser. Skip this for now.
- (semantic-utest-generic (semantic-utest-fname "tst.scm") semantic-utest-Scheme-buffer-contents semantic-utest-Scheme-name-contents '("fun2") ";1" ";deleted line")
- )
-
-(defvar html-helper-build-new-buffer) ; Silence byte-compiler.
-(ert-deftest semantic-utest-Html()
- ;; Disable html-helper auto-fill-in mode.
- (let ((html-helper-build-new-buffer nil)) ; FIXME: Why is this bound?
- (semantic-utest-generic (semantic-utest-fname "tst.html") semantic-utest-Html-buffer-contents semantic-utest-Html-name-contents '("fun2") "<!--1-->" "<!--deleted line-->")
- ))
-
-(ert-deftest semantic-utest-PHP()
- (skip-unless (featurep 'php-mode))
- (semantic-utest-generic (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@")
- )
-
-(ert-deftest semantic-utest-Csharp() ;; hmm i don't even know how to edit a scharp file. need a csharp mode implementation i suppose
- (skip-unless (featurep 'csharp-mode))
- (semantic-utest-generic (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents semantic-utest-Csharp-name-contents '("fun2") "//1" "//deleted line")
- )
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; stubs
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; stuff for Erlang
-;;-module(hello).
-;-export([hello_world/0]).
-;
-;hello_world()->
-; io:format("Hello World ~n").
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;(defun semantic-utest-Erlang()
-; (interactive)
-; (semantic-utest-generic "Erlang" (semantic-utest-fname "tst.erl") semantic-utest-Erlang-buffer-contents semantic-utest-Erlang-name-contents '("fun2") "//1" "//deleted line")
-; )
-;
-;;texi is also supported
-;(defun semantic-utest-Texi()
-; (interactive)
-; (semantic-utest-generic "texi" (semantic-utest-fname "tst.texi") semantic-utest-Texi-buffer-contents semantic-utest-Texi-name-contents '("fun2") "//1" "//deleted line")
-; )
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-;;; Buffer contents validation
-;;
-(defun semantic-utest-match-attributes (attr1 attr2 skipnames)
- "Compare attribute lists ATTR1 and ATTR2.
-Argument SKIPNAMES is a list of names that may be child nodes to skip."
- (let ((res t))
- (while (and res attr1 attr2)
-
- ;; Compare
- (setq res
- (cond ((and (listp (car attr1))
- (semantic-tag-p (car (car attr1))))
- ;; Compare the list of tags...
- (semantic-utest-taglists-equivalent-p
- (car attr2) (car attr1) skipnames)
- )
- (t
- (equal (car attr1) (car attr2)))))
-
- (if (not res)
- (error "TAG INTERNAL DIFF: %S %S"
- (car attr1) (car attr2)))
-
- (setq attr1 (cdr attr1)
- attr2 (cdr attr2)))
- res))
-
-(defun semantic-utest-equivalent-tag-p (tag1 tag2 skipnames)
- "Determine if TAG1 and TAG2 are the same.
-SKIPNAMES includes lists of possible child nodes that should be missing."
- (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
- (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
- (semantic-utest-match-attributes
- (semantic-tag-attributes tag1) (semantic-tag-attributes tag2)
- skipnames)
- ))
-
-(defun semantic-utest-taglists-equivalent-p (table names skipnames)
- "Compare TABLE and NAMES, where skipnames allow list1 to be different.
-SKIPNAMES is a list of names that should be skipped in the NAMES list."
- (let ((SN skipnames))
- (while SN
- (setq names (remove (car SN) names))
- (setq SN (cdr SN))))
- (catch 'utest-err
- (while (and names table)
- (when (not (semantic-utest-equivalent-tag-p (car names)
- (car table)
- skipnames))
- (message "Semantic Parse Test Fail: Expected %s, found %s"
- (semantic-format-tag-prototype (car names))
- (semantic-format-tag-prototype (car table)))
- (throw 'utest-err nil)
- )
- (setq names (cdr names)
- table (cdr table)))
- (when names
- (message "Semantic Parse Test Fail: Items forgotten: %S" (mapcar 'semantic-tag-name names))
- (throw 'utest-err nil))
- (when table
- (message "Semantic parse Test Fail: Items extra: %S" (mapcar 'semantic-tag-name table))
- (throw 'utest-err nil))
- t))
-
-(defun semantic-utest-verify-names (name-contents &optional skipnames)
- "Verify the names of the test buffer from NAME-CONTENTS.
-Argument SKIPNAMES is a list of names that should be skipped
-when analyzing the file.
-
-JAVE this thing would need to be recursive to handle java and csharp"
- (let ((names name-contents)
- (table (semantic-fetch-tags))
- )
- (semantic-utest-taglists-equivalent-p table names skipnames)
- ))
-
-
-;;; Kill indicator line
-;;
-;; Utilities to modify the buffer for reparse, making sure a specific tag is deleted
-;; via the incremental parser.
-
-(defvar semantic-utest-last-kill-text nil
- "The text from the last kill.")
-
-(defvar semantic-utest-last-kill-pos nil
- "The position of the last kill.")
-
-(defun semantic-utest-kill-indicator ( killme insertme)
- "Kill the line with KILLME on it and insert INSERTME in its place."
- (goto-char (point-min))
-; (re-search-forward (concat "/\\*" indicator "\\*/")); JAVE this isn't generic enough for different languages
- (re-search-forward killme)
- (beginning-of-line)
- (setq semantic-utest-last-kill-pos (point))
- (setq semantic-utest-last-kill-text
- (buffer-substring (point) (pos-eol)))
- (delete-region (point) (pos-eol))
- (insert insertme)
- (sit-for 0)
-)
-
-(defun semantic-utest-unkill-indicator ()
- "Unkill the last indicator."
- (goto-char semantic-utest-last-kill-pos)
- (delete-region (point) (pos-eol))
- (insert semantic-utest-last-kill-text)
- (sit-for 0)
- )
-
-(defun semantic-utest-last-invalid (_name-contents _names-removed killme insertme)
- "Make the last fcn invalid."
- (semantic-utest-kill-indicator killme insertme)
-; (semantic-utest-verify-names name-contents names-removed); verify its gone ;new validator doesn't handle skipnames yet
- (semantic-utest-unkill-indicator);put back killed stuff
- )
-
-
-
-;;; semantic-utest.el ends here
+++ /dev/null
-;;; gcc-tests.el --- Tests for semantic/bovine/gcc.el -*- lexical-binding:t -*-
-
-;; Copyright (C) 2003-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Moved here from test/manual/cedet/semantic-tests.el
-
-;;; Code:
-
-(require 'ert)
-(require 'ert-x)
-(require 'semantic/bovine/gcc)
-
-;;; From bovine-gcc:
-
-(defmacro semantic-gcc-test (str)
- `(let ((fields (semantic-gcc-fields ,str)))
- (let-alist fields
- (message "%S" fields)
- ;; No longer test for prefixes.
- ;; (should .--prefix)
- (should .version)
- (should (or .target
- .--target
- .--host)))))
-
-;; A bunch of sample gcc -v outputs from different machines.
-
-(ert-deftest semantic-gcc-test/1 ()
- ;; My old box:
- (semantic-gcc-test "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)"))
-
-(ert-deftest semantic-gcc-test/2 ()
- ;; Alex Ott:
- (semantic-gcc-test "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)"))
-
-(ert-deftest semantic-gcc-test/3 ()
- ;; My Debian box:
- (semantic-gcc-test "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"))
-
-(ert-deftest semantic-gcc-test/4 ()
- ;; My mac:
- (semantic-gcc-test "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)"))
-
-(ert-deftest semantic-gcc-test/5 ()
- ;; Ubuntu Intrepid
- (semantic-gcc-test "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)"))
-
-(ert-deftest semantic-gcc-test/6 ()
- ;; Red Hat EL4
- (semantic-gcc-test "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)"))
-
-(ert-deftest semantic-gcc-test/7 ()
- ;; Red Hat EL5
- (semantic-gcc-test "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)"))
-
-(ert-deftest semantic-gcc-test/8 ()
- ;; David Engster's german gcc on ubuntu 4.3
- (semantic-gcc-test "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)"))
-
-(ert-deftest semantic-gcc-test/9 ()
- ;; Damien Deville bsd
- (semantic-gcc-test "Using built-in specs.
-Target: i386-undermydesk-freebsd
-Configured with: FreeBSD/i386 system compiler
-Thread model: posix
-gcc version 4.2.1 20070719 [FreeBSD]"))
-
-(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.")
-
-(ert-deftest semantic-gcc-test-output-parser/fail ()
- "Test the output parser against some collected strings."
- (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)
- (error "Negative test failed on %S" S)))))
-
-(ert-deftest semantic-gcc-test-output-parser/this-machine ()
- "Test the output parser against the machine currently running Emacs."
- (skip-unless (and (executable-find "gcc")
- (not (ert-gcc-is-clang-p))))
- (semantic-gcc-test (semantic-gcc-query "gcc" "-v")))
-
-;;; gcc-tests.el ends here
+++ /dev/null
-/** test-fmt.cpp --- Signatures, and format answers for testing
- *
- * Copyright (C) 2012, 2016, 2019-2024 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 <https://www.gnu.org/licenses/>.
- */
-
-/*
- * About semantic-fmt-utest :
- *
- * These tests validate two features:
- * 1) The C++ parser can parse the different signatures
- * 2) The semantic-tag-format-* functions can recreate them.
- *
- */
-
-void basic_fcn() { }
-/*
- * ## name "basic_fcn"
- * ## abbreviate "basic_fcn()"
- * ## prototype "void basic_fcn ()"
- * ## uml-prototype "basic_fcn () : void"
- */
-
-int twoargs_fcn(int a, char b) { }
-/*
- * ## name "twoargs_fcn"
- * ## abbreviate "twoargs_fcn()"
- * ## prototype "int twoargs_fcn (int a,char b)"
- * ## uml-prototype "twoargs_fcn (a : int,b : char) : int"
- */
-
-struct moose {
- int field1;
- char field2;
-};
-/*
- * ## name "moose"
- * ## abbreviate "moose{}"
- * ## prototype "struct moose {}"
- * ## uml-prototype "moose{} : struct"
- */
-
-struct moose struct_fcn ( struct moose in, char *out);
-/*
- * ## name "struct_fcn"
- * ## abbreviate "struct_fcn()"
- * ## prototype "struct moose struct_fcn (struct moose in,char* out)"
- * ## uml-prototype "struct_fcn (in : struct moose,out : char*) : struct moose"
- */
-
-struct moose *var_one = NULL;
-/*
- * ## name "var_one"
- * ## summarize "Variables: struct moose* var_one[=NULL]"
- * ## prototype "struct moose* var_one[=NULL]"
- * ## uml-prototype "var_one : struct moose*"
- */
-
-const int var_two = 1;
-/*
- * ## name "var_two"
- * ## summarize "Variables: const int var_two[=1]"
- * ## prototype "const int var_two[=1]"
- * ## uml-prototype "var_two : int"
- */
-
-namespace NS {
- enum TestEnum {a,b};
-}
-/*
- * ## name "NS"
- * ## summarize "Types: namespace NS {}"
- * ## prototype "namespace NS {}"
- * ## uml-prototype "NS{} : namespace"
- */
-
-
-// void func_ns_arg(NS::TestEnum v = NS::a); <<--- TODO - bring FIX from CEDET on SF
-/*
- * # # name "func_ns_arg"
- * # # summarize "Functions: void func_ns_arg (NS::TestEnum v[=NS::a])"
- * # # prototype "void func_ns_arg (NS::TestEnum v[=NS::a])"
- * # # uml-prototype "func_ns_arg (v : NS::TestEnum) : void"
- */
-
-//int const var_three = 1;
-/*
- * # # name "var_three"
- * # # summarize "Variables: int const var_three" <-- this fails
- * # # prototype "int const var_three" <-- this fails
- * # # uml-prototype "var_three : int"
- */
+++ /dev/null
-;;; test-fmt.el --- test semantic tag formatting -*- lexical-binding: t -*-
-
-;; Copyright (C) 2012-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;;
-
-;;; Code:
-(require 'semantic)
-;;
-;; ## name "semantic"
-;; ## abbreviate "semantic<>"
-;; ## summarize "Requires: semantic"
-
-(defun test-fmt-1 (a)
- "Function with 1 arg.")
-;;
-;; ## name "test-fmt-1"
-;; ## abbreviate "(test-fmt-1)"
-;; ## summarize "Defuns: (test-fmt-1 a)"
-;; ## short-doc "Function with 1 arg."
-;; ## uml-prototype "(test-fmt-1 a)" <-- That is probably wrong.
-
-(defvar test-fmt-var nil
- "Variable test.")
-;;
-;; ## name "test-fmt-var"
-;; ## abbreviate "test-fmt-var"
-;; ## summarize "Variables: test-fmt-var"
-;; ## short-doc "Variable test."
-;; ## uml-prototype "test-fmt-var"
-
-(defclass test-fmt-class ()
- ((slot1 :initarg :slot1))
- "Class for testing.")
-;;
-;; ## name "test-fmt-class"
-;; ## abbreviate "test-fmt-class{}"
-;; ## summarize "Types: class test-fmt-class {}"
-;; ## short-doc "Class for testing."
-;; ## uml-prototype "class test-fmt-class {}"
-
-
-
-(provide 'test-fmt)
-
-;;; test-fmt.el ends here
+++ /dev/null
-;;; semantic/format-tests.el --- Parsing / Formatting tests -*- lexical-binding:t -*-
-
-;; Copyright (C) 2003-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Unit tests for the formatting feature.
-;;
-;; Using test code from the tests source directory, parse the source
-;; file. After parsing, read the comments for each signature, and
-;; make sure that the semantic-tag-format-* functions in question
-;; created the desired output.
-
-;;; Code:
-
-(require 'ert)
-(require 'ert-x)
-(require 'semantic/format)
-
-(defvar semantic-fmt-utest-file-list
- (list (ert-resource-file "test-fmt.cpp")
- ;; "tests/test-fmt.el" - add this when elisp is support by dflt in Emacs
- )
- "List of files to run unit tests in.")
-
-(ert-deftest semantic-fmt-utest ()
- "Visit all file entries, and run formatting test. "
- (save-current-buffer
- (semantic-mode 1)
- (dolist (fname semantic-fmt-utest-file-list)
- (let ((fb (find-buffer-visiting fname))
- (b (semantic-find-file-noselect fname))
- (tags nil))
- (save-current-buffer
- (set-buffer b)
- (should (semantic-active-p))
- ;;(error "Cannot open %s for format tests" fname))
-
- ;; This will force a reparse, removing any chance of semanticdb cache
- ;; using stale data.
- (semantic-clear-toplevel-cache)
- ;; Force the reparse
- (setq tags (semantic-fetch-tags))
-
- (save-excursion
- (while tags
- (let* ((T (car tags))
- (start (semantic-tag-end T))
- (end (if (cdr tags)
- (semantic-tag-start (car (cdr tags)))
- (point-max)))
- (TESTS nil))
- (goto-char start)
- ;; Scan the space between tags for all test condition matches.
- (while (re-search-forward "## \\([a-z-]+\\) \"\\([^\n\"]+\\)\"$" end t)
- (push (cons (match-string 1) (match-string 2)) TESTS))
- (setq TESTS (nreverse TESTS))
-
- (dolist (TST TESTS)
- (let* ( ;; For each test, convert CAR into a semantic-format-tag* fcn
- (sym (intern (concat "semantic-format-tag-" (car TST))))
- ;; Convert the desired result from a string syntax to a string.
- (desired (cdr TST))
- ;; What does the fmt function do?
- (actual (funcall sym T)))
- (when (not (string= desired actual))
- (should-not (list "Desired" desired
- "Actual" actual
- "Formatter" (car TST)))))))
- (setq tags (cdr tags)))))
-
- ;; If it wasn't already in memory, whack it.
- (when (and b (not fb))
- (kill-buffer b))))))
-
-(provide 'format-tests)
-
-;;; format-tests.el ends here
+++ /dev/null
-;;; fw-tests.el --- Tests for semantic/fw.el -*- lexical-binding:t -*-
-
-;; Copyright (C) 2003-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Moved here from test/manual/cedet/semantic-tests.el
-
-;;; Code:
-
-(require 'ert)
-(require 'semantic/fw)
-
-;;; From semantic-fw:
-
-(ert-deftest semantic-test-data-cache ()
- "Test the data cache."
- (let ((data '(a b c)))
- (with-current-buffer (get-buffer-create " *semantic-test-data-cache*")
- (erase-buffer)
- (insert "The Moose is Loose")
- (goto-char (point-min))
- (semantic-cache-data-to-buffer (current-buffer) (point) (+ (point) 5)
- data 'moose 'exit-cache-zone)
- ;; retrieve cached data
- (should (equal (semantic-get-cache-data 'moose) data)))))
-
-;;; fw-tests.el ends here
+++ /dev/null
-;;; srecode/test-getset.el --- Test the getset inserter. -*- lexical-binding:t -*-
-
-;; Copyright (C) 2008-2009, 2011, 2019-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Unit tests for the getset inserter application.
-
-(require 'srecode/semantic)
-
-;;; Code:
-(defvar srecode-utest-getset-pre-fill
- "// Test Class for getset tests in c++.
-
-class myClass {
-public:
- myClass() { };
- ~myClass() { };
- /** miscFunction
- */
- int miscFunction(int);
-
-private:
- int fStartingField;
-
-};
-
-"
- "The pre-fill class for the getset tests.")
-
-
-;;; Master Harness
-;;
-(defvar srecode-utest-getset-testfile
- (expand-file-name
- (concat (make-temp-name "srecode-utest-getset-") ".cpp")
- temporary-file-directory)
- "File used to do testing.")
-
-(defvar srecode-insert-getset-fully-automatic-flag) ; Silence byte-compiler.
-(ert-deftest srecode-utest-getset-output ()
- "Test various template insertion options."
- :tags '(:expensive-test)
- (save-excursion
- (let ((testbuff (find-file-noselect srecode-utest-getset-testfile))
- (srecode-insert-getset-fully-automatic-flag t))
-
- (set-buffer testbuff)
- (semantic-mode 1)
- (srecode-load-tables-for-mode major-mode)
- (srecode-load-tables-for-mode major-mode 'getset)
-
- (should (srecode-table))
- ;;(error "No template table found for mode %s" major-mode))
-
- (condition-case nil
- (erase-buffer)
- (error nil))
-
- (insert srecode-utest-getset-pre-fill)
- (goto-char (point-min))
-
- ;; Test PRE FILL
- (should-not
- (srecode-utest-getset-tagcheck '("public"
- "myClass"
- "myClass"
- "miscFunction"
- "private"
- "fStartingField")))
- (should-not
- (srecode-utest-getset-jumptotag "fStartingField"))
-
- ;; Startup with fully automatic selection.
- (srecode-insert-getset)
-
- ;; * Post get-set "StartingField"
- (should-not
- (srecode-utest-getset-tagcheck '("public"
- "myClass"
- "myClass"
- "getStartingField"
- "setStartingField"
- "miscFunction"
- "private"
- "fStartingField")))
-
- ;; Now try convenience args.
- (goto-char (point-min))
- (should-not
- (srecode-utest-getset-jumptotag "fStartingField"))
- (end-of-line)
- (insert "\n")
-
- (srecode-insert-getset nil "AutoInsertField")
-
- ;; * Post get-set "AutoInsertField"
- (should-not
- (srecode-utest-getset-tagcheck '("public"
- "myClass"
- "myClass"
- "getStartingField"
- "setStartingField"
- "getAutoInsertField"
- "setAutoInsertField"
- "miscFunction"
- "private"
- "fStartingField"
- "fAutoInsertField")))
-
- ;; Make sure all the comments are in the right place.
- (should-not
- (srecode-utest-getset-jumptotag "miscFunction"))
-
- (let ((pos (point)))
- (forward-comment -1)
- (re-search-forward "miscFunction" pos))
-
- ))
- (when (file-exists-p srecode-utest-getset-testfile)
- (delete-file srecode-utest-getset-testfile))
- )
-
-(defun srecode-utest-getset-tagcheck (expected-members)
- "Make sure that the tags in myClass have EXPECTED-MEMBERS."
- (semantic-fetch-tags)
- (let* ((mc (semantic-find-tags-by-name "myClass" (current-buffer)))
- (mem (semantic-tag-type-members (car mc)))
- (fail nil))
- (catch 'fail-early
- (while (and mem expected-members)
- (when (not (string= (semantic-tag-name (car mem))
- (car expected-members)))
- (switch-to-buffer (current-buffer))
- (setq fail (format "Did not find %s in %s" (car expected-members)
- (buffer-file-name)))
- (throw 'fail-early nil))
- (setq mem (cdr mem)
- expected-members (cdr expected-members)))
- (when expected-members
- (switch-to-buffer (current-buffer))
- (setq fail (format "Did not find all expected tags in class: %s" (buffer-file-name)))
- (throw 'fail-early t))
- (when mem
- (switch-to-buffer (current-buffer))
- (setq fail (format "Found extra tags in class: %s" (buffer-file-name)))))
-
- (when fail (message "%s" (buffer-string)))
- fail))
-
-(defun srecode-utest-getset-jumptotag (tagname)
- "Jump to the tag named TAGNAME."
- (semantic-fetch-tags)
- (let ((fail nil)
- (tag (semantic-deep-find-tags-by-name tagname (current-buffer))))
- (if tag
- (semantic-go-to-tag (car tag))
- (setq fail (format "Failed to jump to tag %s" tagname)))
- fail))
-
-(provide 'cedet/srecode/test-getset)
-;;; srecode/test-getset.el ends here
+++ /dev/null
-;;; srecode-utest-template.el --- SRecode Core Template tests. -*- lexical-binding:t -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Tests of SRecode template insertion routines and tricks.
-;;
-
-
-(require 'srecode/map)
-(require 'srecode/insert)
-(require 'srecode/dictionary)
-
-
-;;; Code:
-
-;;; MAP DUMP TESTING
-(defun srecode-utest-map-reset ()
- "Reset, then dump the map of SRecoder templates.
-Probably should be called `describe-srecode-maps'."
- (interactive)
- (message "SRecode Template Path: %S" srecode-map-load-path)
- ;; Interactive call allows us to dump.
- (call-interactively 'srecode-get-maps)
- (switch-to-buffer "*SRECODE MAP*")
- (message (buffer-string))
- )
-
-;;; OUTPUT TESTING
-;;
-(defclass srecode-utest-output ()
- ((point :initarg :point
- :type string
- :documentation
- "Name of this test point.")
- (name :initarg :name
- :type string
- :documentation
- "Name of the template tested.")
- (output :initarg :output
- :type string
- :documentation
- "Expected output of the template.")
- (dict-entries :initarg :dict-entries
- :initform nil
- :type list
- :documentation
- "Additional dictionary entries to specify.")
- (pre-fill :initarg :pre-fill
- :type (or null string)
- :initform nil
- :documentation
- "Text to prefill a buffer with.
-Place cursor on the ! and delete it.
-If there is a second !, the put the mark there."))
- "A single template test.")
-
-(cl-defmethod srecode-utest-test ((o srecode-utest-output))
- "Perform the insertion and test the output.
-Assumes that the current buffer is the testing buffer.
-Return NIL on success, or a diagnostic on failure."
- (let ((fail nil))
- (catch 'fail-early
- (with-slots (name (output-1 output) dict-entries pre-fill) o
- ;; Prepare buffer: erase content and maybe insert pre-fill
- ;; content.
- (erase-buffer)
- (insert (or pre-fill ""))
- (goto-char (point-min))
- (let ((start nil))
- (when (re-search-forward "!" nil t)
- (goto-char (match-beginning 0))
- (setq start (point))
- (replace-match ""))
- (when (re-search-forward "!" nil t)
- (push-mark (match-beginning 0) t t)
- (replace-match ""))
- (when start (goto-char start)))
-
- ;; Find a template, perform an insertion and validate the output.
- (let ((dict (srecode-create-dictionary))
- (temp (or (srecode-template-get-table
- (srecode-table) name "test" 'tests)
- (progn
- (srecode-map-update-map)
- (srecode-template-get-table
- (srecode-table) name "test" 'tests))
- (progn
- (setq fail (format "Test template \"%s\" for `%s' not loaded!"
- name major-mode))
- (throw 'fail-early t)
- )))
- (srecode-handle-region-when-non-active-flag t))
-
- ;; RESOLVE AND INSERT
- (let ((entry dict-entries))
- (while entry
- (srecode-dictionary-set-value
- dict (nth 0 entry) (nth 1 entry))
- (setq entry (nthcdr 1 entry))))
-
- (srecode-insert-fcn temp dict)
-
- ;; COMPARE THE OUTPUT
- (let ((actual (buffer-substring-no-properties
- (point-min) (point-max))))
- (if (string= output-1 actual)
- nil
-
- (goto-char (point-max))
- (insert "\n\n ------------- ^^ actual ^^ ------------\n\n
- ------------- vv expected vv ------------\n\n"
- output-1)
- (setq fail
- (list (format "Entry %s failed:" (oref o point))
- (buffer-string))
- )))))
- )
- fail))
-
-;;; ARG HANDLER
-;;
-(defun srecode-semantic-handle-:utest (dict)
- "Add macros into the dictionary DICT for unit testing purposes."
- (srecode-dictionary-set-value dict "UTESTVAR1" "ARG HANDLER ONE")
- (srecode-dictionary-set-value dict "UTESTVAR2" "ARG HANDLER TWO")
- )
-
-(defun srecode-semantic-handle-:utestwitharg (dict)
- "Add macros into the dictionary DICT based on other vars in DICT."
- (let ((val1 (srecode-dictionary-lookup-name dict "UTWA"))
- (nval1 nil))
- ;; If there is a value, mutate it
- (if (and val1 (stringp val1))
- (setq nval1 (upcase val1))
- ;; No value, make stuff up
- (setq nval1 "NO VALUE"))
-
- (srecode-dictionary-set-value dict "UTESTARGXFORM" nval1))
-
- (let ((dicts (srecode-dictionary-lookup-name dict "UTLOOP")))
- (dolist (D dicts)
- ;; For each dictionary, lookup NAME, and transform into
- ;; something in DICT instead.
- (let ((sval (srecode-dictionary-lookup-name D "NAME")))
- (srecode-dictionary-set-value dict (concat "FOO_" sval) sval)
- )))
- )
-
-;;; TEST POINTS
-;;
-(defvar srecode-utest-output-entries
- (list
- (srecode-utest-output
- :point "test1" :name "test"
- :output (concat ";; " (user-full-name) "\n"
- ";; " (upcase (user-full-name))) )
- (srecode-utest-output
- :point "subs" :name "subs"
- :output ";; Before Loop
-;; After Loop" )
- (srecode-utest-output
- :point "firstlast" :name "firstlast"
- :output "
-;; << -- FIRST
-;; I'm First
-;; I'm Not Last
-;; -- >>
-
-;; << -- MIDDLE
-;; I'm Not First
-;; I'm Not Last
-;; -- >>
-
-;; << -- LAST
-;; I'm Not First
-;; I'm Last
-;; -- >>
-" )
- (srecode-utest-output
- :point "gapsomething" :name "gapsomething"
- :output ";; First Line
-### ALL ALONE ON A LINE ###
-;;Second Line"
- :pre-fill ";; First Line
-!;;Second Line")
- (srecode-utest-output
- :point "wrapsomething" :name "wrapsomething"
- :output ";; Put this line in front:
-;; First Line
-;; Put this line at the end:"
- :pre-fill "!;; First Line
-!")
- (srecode-utest-output
- :point "inlinetext" :name "inlinetext"
- :output ";; A big long comment XX*In the middle*XX with cursor in middle"
- :pre-fill ";; A big long comment XX!XX with cursor in middle")
-
- (srecode-utest-output
- :point "wrapinclude-basic" :name "wrapinclude-basic"
- :output ";; An includable we could use.
-;; \n;; Text after a point inserter."
- )
- (srecode-utest-output
- :point "wrapinclude-basic2" :name "wrapinclude-basic"
- :output ";; An includable MOOSE we could use.
-;; \n;; Text after a point inserter."
- :dict-entries '("COMMENT" "MOOSE")
- )
- (srecode-utest-output
- :point "wrapinclude-around" :name "wrapinclude-around"
- :output ";; An includable we could use.
-;; [VAR]Intermediate Comments
-;; Text after a point inserter."
- )
- (srecode-utest-output
- :point "wrapinclude-around1" :name "wrapinclude-around"
- :output ";; An includable PENGUIN we could use.
-;; [VAR]Intermediate Comments
-;; Text after a point inserter."
- :dict-entries '("COMMENT" "PENGUIN")
- )
- (srecode-utest-output
- :point "complex-subdict" :name "complex-subdict"
- :output ";; I have a cow and a dog.")
- (srecode-utest-output
- :point "wrap-new-template" :name "wrap-new-template"
- :output "template newtemplate
-\"A nice doc string goes here.\"
-----
-Random text in the new template
-----
-bind \"a\""
- :dict-entries '( "NAME" "newtemplate" "KEY" "a" )
- )
- (srecode-utest-output
- :point "column-data" :name "column-data"
- :output "Table of Values:
-Left Justified | Right Justified
-FIRST | FIRST
-VERY VERY LONG STRIN | VERY VERY LONG STRIN
-MIDDLE | MIDDLE
-S | S
-LAST | LAST")
- (srecode-utest-output
- :point "custom-arg-handler" :name "custom-arg-handler"
- :output "OUTSIDE SECTION: ARG HANDLER ONE
-INSIDE SECTION: ARG HANDLER ONE")
- (srecode-utest-output
- :point "custom-arg-w-arg none" :name "custom-arg-w-arg"
- :output "Value of xformed UTWA: NO VALUE")
- (srecode-utest-output
- :point "custom-arg-w-arg upcase" :name "custom-arg-w-arg"
- :dict-entries '( "UTWA" "uppercaseme" )
- :output "Value of xformed UTWA: UPPERCASEME")
- (srecode-utest-output
- :point "custom-arg-w-subdict" :name "custom-arg-w-subdict"
- :output "All items here: item1 item2 item3")
-
- ;; Test cases for new "section ... end" dictionary syntax
- (srecode-utest-output
- :point "nested-dictionary-syntax-flat"
- :name "nested-dictionary-syntax-flat"
- :output "sub item1")
- (srecode-utest-output
- :point "nested-dictionary-syntax-nesting"
- :name "nested-dictionary-syntax-nesting"
- :output "item11-item11-item21-item31 item21-item11-item21-item31 item31-item311-item321 ")
- (srecode-utest-output
- :point "nested-dictionary-syntax-mixed"
- :name "nested-dictionary-syntax-mixed"
- :output "item1 item2"))
- "Test point entries for the template output tests.")
-
-;;; Master Harness
-;;
-(defvar srecode-utest-testfile
- (expand-file-name (concat (make-temp-name "srecode-utest-") ".srt") temporary-file-directory)
- "File used to do testing.")
-
-(ert-deftest srecode-utest-template-output ()
- "Test various template insertion options."
- (save-excursion
- (let ((testbuff (find-file-noselect srecode-utest-testfile)))
-
- (set-buffer testbuff)
-
- (srecode-load-tables-for-mode major-mode)
- (srecode-load-tables-for-mode major-mode 'tests)
-
- (should (srecode-table major-mode))
-
- ;; Loop over the output testpoints.
- (dolist (p srecode-utest-output-entries)
- (should-not (srecode-utest-test p)))))
-
- (when (file-exists-p srecode-utest-testfile)
- (delete-file srecode-utest-testfile)))
-
-;;; Project test
-;;
-;; Test that "project" specification works ok.
-
-(ert-deftest srecode-utest-project ()
- "Test that project filtering works."
- (save-excursion
- (let ((testbuff (find-file-noselect srecode-utest-testfile))
- (temp nil))
-
- (set-buffer testbuff)
- (erase-buffer)
-
- ;; Load the basics, and test that we can't find the application templates.
- (srecode-load-tables-for-mode major-mode)
-
- (should (srecode-table major-mode))
-
- (setq temp (srecode-template-get-table (srecode-table)
- "test-project"
- "test"
- 'tests
- ))
- (when temp
- (should-not "App Template Loaded when not specified."))
-
- ;; Load the application templates, and make sure we can find them.
- (srecode-load-tables-for-mode major-mode 'tests)
-
- (dolist (table (oref (srecode-table) tables))
- (when (gethash "test" (oref table contexthash))
- (oset table project default-directory)))
-
- (setq temp (srecode-template-get-table (srecode-table)
- "test-project"
- "test"
- 'tests
- ))
-
- (when (not temp)
- (should-not "Failed to load app specific template when available."))
-
- ;; Temporarily change the home of this file. This will make the
- ;; project template go out of scope.
- (let ((default-directory (expand-file-name "~/")))
-
- (setq temp (srecode-template-get-table (srecode-table)
- "test-project"
- "test"
- 'tests
- ))
-
- (when temp
- (should-not "Project specific template available when in wrong directory."))
-
- )))
- (when (file-exists-p srecode-utest-testfile)
- (delete-file srecode-utest-testfile)))
-
-
-(provide 'cedet/srecode-utest-template)
-;;; srecode-utest-template.el ends here
+++ /dev/null
-;;; document-tests.el --- Tests for srecode/document.el -*- lexical-binding:t -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Extracted from srecode-document.el in the CEDET distribution.
-
-;; Converted to ert from test/manual/cedet/srecode-tests.el
-
-;;; Code:
-
-(require 'ert)
-(require 'srecode/document)
-
-;; FIXME: This test fails even before conversion to ert.
-(ert-deftest srecode-document-function-comment-extract-test ()
- "Test old comment extraction.
-Dump out the extracted dictionary."
- :tags '(:unstable)
- (srecode-load-tables-for-mode major-mode)
- (srecode-load-tables-for-mode major-mode 'document)
-
- (should (srecode-table))
- ;; (error "No template table found for mode %s" major-mode)
-
- (let* ((temp (srecode-template-get-table (srecode-table)
- "function-comment"
- "declaration"
- 'document))
- (fcn-in (semantic-current-tag)))
-
- (should temp)
- ;; (error "No templates for function comments")
-
- ;; Try to figure out the tag we want to use.
- (should fcn-in)
- (should (semantic-tag-of-class-p fcn-in 'function))
- ;; (error "No tag of class 'function to insert comment for")
-
- (let ((lextok (semantic-documentation-comment-preceding-tag fcn-in 'lex)))
-
- (should lextok)
- ;; (error "No comment to attempt an extraction")
-
- (let ((s (semantic-lex-token-start lextok))
- (e (semantic-lex-token-end lextok))
- (extract nil))
-
- (pulse-momentary-highlight-region s e)
-
- ;; Extract text from the existing comment.
- (setq extract (srecode-extract temp s e))
-
- (with-output-to-temp-buffer "*SRECODE DUMP*"
- (princ "EXTRACTED DICTIONARY FOR ")
- (princ (semantic-tag-name fcn-in))
- (princ "\n--------------------------------------------\n")
- (srecode-dump extract))))))
-
-;;; document-tests.el ends here
+++ /dev/null
-;;; srecode/fields-tests.el --- Tests for srecode/fields.el -*- lexical-binding: t -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Extracted from srecode-fields.el in the CEDET distribution.
-
-;; Converted to ert from test/manual/cedet/srecode-tests.el
-
-;;; Code:
-
-;;; From srecode-fields:
-
-(require 'ert)
-(require 'srecode/fields)
-
-(defvar srecode-field-utest-text
- "This is a test buffer.
-
-It is filled with some text."
- "Text for tests.")
-
-;; FIXME: This test fails even before conversion to ert.
-(ert-deftest srecode-field-utest-impl ()
- "Implementation of the SRecode field utest."
- :tags '(:unstable)
- (save-excursion
- (find-file "/tmp/srecode-field-test.txt")
-
- (erase-buffer)
- (goto-char (point-min))
- (insert srecode-field-utest-text)
- (set-buffer-modified-p nil)
-
- ;; Test basic field generation.
- (let ((srecode-field-archive nil)
- (f nil))
-
- (end-of-line)
- (forward-word -1)
-
- (setq f (srecode-field :name "TEST"
- :start 6
- :end 8))
-
- (when (or (not (slot-boundp f 'overlay)) (not (oref f overlay)))
- (error "Field test: Overlay info not created for field"))
-
- (when (and (overlayp (oref f overlay))
- (not (overlay-get (oref f overlay) 'srecode-init-only)))
- (error "Field creation overlay is not tagged with init flag"))
-
- (srecode-overlaid-activate f)
-
- (when (or (not (overlayp (oref f overlay)))
- (overlay-get (oref f overlay) 'srecode-init-only))
- (error "New field overlay not created during activation"))
-
- (when (not (= (length srecode-field-archive) 1))
- (error "Field test: Incorrect number of elements in the field archive"))
- (when (not (eq f (car srecode-field-archive)))
- (error "Field test: Field did not auto-add itself to the field archive"))
-
- (when (not (overlay-get (oref f overlay) 'keymap))
- (error "Field test: Overlay keymap not set"))
-
- (when (not (string= "is" (srecode-overlaid-text f)))
- (error "Field test: Expected field text 'is', not %s"
- (srecode-overlaid-text f)))
-
- ;; Test deletion.
- (srecode-delete f)
-
- (when (slot-boundp f 'overlay)
- (error "Field test: Overlay not deleted after object delete"))
- )
-
- ;; Test basic region construction.
- (let* ((srecode-field-archive nil)
- (reg nil)
- (fields
- (list
- (srecode-field :name "TEST-1" :start 5 :end 10)
- (srecode-field :name "TEST-2" :start 15 :end 20)
- (srecode-field :name "TEST-3" :start 25 :end 30)
-
- (srecode-field :name "TEST-4" :start 35 :end 35))))
-
- (when (not (= (length srecode-field-archive) 4))
- (error "Region Test: Found %d fields. Expected 4"
- (length srecode-field-archive)))
-
- (setq reg (srecode-template-inserted-region :start 4
- :end 40))
-
- (srecode-overlaid-activate reg)
-
- ;; Make sure it was cleared.
- (when srecode-field-archive
- (error "Region Test: Did not clear field archive"))
-
- ;; Auto-positioning.
- (when (not (eq (point) 5))
- (error "Region Test: Did not reposition on first field"))
-
- ;; Active region
- (when (not (eq (srecode-active-template-region) reg))
- (error "Region Test: Active region not set"))
-
- ;; Various sizes
- (mapc (lambda (T)
- (if (string= (eieio-object-name-string T) "Test4")
- (progn
- (when (not (srecode-empty-region-p T))
- (error "Field %s is not empty"
- (eieio-object-name T)))
- )
- (when (not (= (srecode-region-size T) 5))
- (error "Calculated size of %s was not 5"
- (eieio-object-name T)))))
- fields)
-
- ;; Make sure things stay up after a 'command'.
- (srecode-field-post-command)
- (when (not (eq (srecode-active-template-region) reg))
- (error "Region Test: Active region did not stay up"))
-
- ;; Test field movement.
- (when (not (eq (srecode-overlaid-at-point 'srecode-field)
- (nth 0 fields)))
- (error "Region Test: Field %s not under point"
- (eieio-object-name (nth 0 fields))))
-
- (srecode-field-next)
-
- (when (not (eq (srecode-overlaid-at-point 'srecode-field)
- (nth 1 fields)))
- (error "Region Test: Field %s not under point"
- (eieio-object-name (nth 1 fields))))
-
- (srecode-field-prev)
-
- (when (not (eq (srecode-overlaid-at-point 'srecode-field)
- (nth 0 fields)))
- (error "Region Test: Field %s not under point"
- (eieio-object-name (nth 0 fields))))
-
- ;; Move cursor out of the region and have everything cleaned up.
- (goto-char 42)
- (srecode-field-post-command)
- (when (srecode-active-template-region)
- (error "Region Test: Active region did not clear on move out"))
-
- (mapc (lambda (T)
- (when (slot-boundp T 'overlay)
- (error "Overlay did not clear off of field %s"
- (eieio-object-name T))))
- fields)
-
- ;; End of LET
- )
-
- ;; Test variable linkage.
- (let* ((srecode-field-archive nil)
- (f1 (srecode-field :name "TEST" :start 6 :end 8))
- (f2 (srecode-field :name "TEST" :start 28 :end 30))
- (f3 (srecode-field :name "NOTTEST" :start 35 :end 40))
- (reg (srecode-template-inserted-region :start 4 :end 40)))
- (srecode-overlaid-activate reg)
-
- (when (not (string= (srecode-overlaid-text f1)
- (srecode-overlaid-text f2)))
- (error "Linkage Test: Init strings are not ="))
- (when (string= (srecode-overlaid-text f1)
- (srecode-overlaid-text f3))
- (error "Linkage Test: Init string on dissimilar fields is now the same"))
-
- (goto-char 7)
- (insert "a")
-
- (when (not (string= (srecode-overlaid-text f1)
- (srecode-overlaid-text f2)))
- (error "Linkage Test: mid-insert strings are not ="))
- (when (string= (srecode-overlaid-text f1)
- (srecode-overlaid-text f3))
- (error "Linkage Test: mid-insert string on dissimilar fields is now the same"))
-
- (goto-char 9)
- (insert "t")
-
- (when (not (string= (srecode-overlaid-text f1) "iast"))
- (error "Linkage Test: tail-insert failed to captured added char"))
- (when (not (string= (srecode-overlaid-text f1)
- (srecode-overlaid-text f2)))
- (error "Linkage Test: tail-insert strings are not ="))
- (when (string= (srecode-overlaid-text f1)
- (srecode-overlaid-text f3))
- (error "Linkage Test: tail-insert string on dissimilar fields is now the same"))
-
- (goto-char 6)
- (insert "b")
-
- (when (not (string= (srecode-overlaid-text f1) "biast"))
- (error "Linkage Test: tail-insert failed to captured added char"))
- (when (not (string= (srecode-overlaid-text f1)
- (srecode-overlaid-text f2)))
- (error "Linkage Test: tail-insert strings are not ="))
- (when (string= (srecode-overlaid-text f1)
- (srecode-overlaid-text f3))
- (error "Linkage Test: tail-insert string on dissimilar fields is now the same"))
-
- ;; Cleanup
- (srecode-delete reg))
-
- (set-buffer-modified-p nil)))
-
-;;; srecode/fields-tests.el ends here
'(1 . 6)))))
(ert-deftest completion-table-test-quoting ()
+ ;; FIXME: Update data following removal of CEDET.
(let ((process-environment
`("CTTQ1=ed" "CTTQ2=et/" ,@process-environment))
(default-directory (ert-resource-directory)))
+++ /dev/null
-;;; cedet-utests.el --- Run all unit tests in the CEDET suite. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-;;
-;; Remembering to run all the unit tests available in CEDET one at a
-;; time is a bit time consuming. This links all the tests together
-;; into one command.
-
-(require 'cedet)
-
-(defvar cedet-utest-directory
- (let* ((C (file-name-directory (locate-library "cedet")))
- (D (expand-file-name "../../test/manual/cedet/" C)))
- D)
- "Location of test files for this test suite.")
-
-(defvar cedet-utest-libs '("ede-tests"
- "semantic-tests"
- )
- "List of test srcs that need to be loaded.")
-
-;;; Code:
-(defvar cedet-utest-test-alist
- '(
- ;;
- ;; COMMON
- ;;
-
- ;; Test inversion
- ;; ("inversion" . inversion-unit-test) ; moved to automated suite
-
- ;; EZ Image dumping.
- ("ezimage associations" . ezimage-image-association-dump)
- ("ezimage images" . (lambda ()
- (ezimage-image-dump)
- (kill-buffer "*Ezimage Images*")))
-
- ;; Pulse
- ("pulse interactive test" . (lambda () (pulse-test t)))
-
- ;; Files
- ;; ("cedet file conversion" . cedet-files-utest) ; moved to automated suite
-
- ;;
- ;; EIEIO
- ;;
-
- ("eieio: browser" . (lambda ()
- (eieio-browse)
- (kill-buffer "*EIEIO OBJECT BROWSE*")))
- ("eieio: custom" . (lambda ()
- (require 'eieio-custom)
- (customize-variable 'eieio-widget-test)
- (kill-buffer "*Customize Option: Eieio Widget Test*")
- ))
- ("eieio: chart" . (lambda ()
- (require 'chart)
- (if noninteractive
- (message " ** Skipping test in noninteractive mode.")
- (chart-test-it-all))))
- ;;
- ;; EDE
- ;;
-
- ;; @todo - Currently handled in the integration tests. Need
- ;; some simpler unit tests here.
-
- ;;
- ;; SEMANTIC
- ;;
- ("semantic: lex spp table write" . semantic-lex-spp-write-utest)
- ;;("semantic: multi-lang parsing" . semantic-utest-main)
- ;;("semantic: C preprocessor" . semantic-utest-c) - Now in automated suite
- ;;("semantic: analyzer tests" . semantic-ia-utest)
- ("semanticdb: data cache" . semantic-test-data-cache)
- ("semantic: throw-on-input" .
- (lambda ()
- (if noninteractive
- (message " ** Skipping test in noninteractive mode.")
- (semantic-test-throw-on-input))))
-
- ;;("semantic: gcc: output parse test" . semantic-gcc-test-output-parser) ; moved to automated suite
-
- ;;
- ;; SRECODE
- ;;
-
- ;; TODO - fix the fields test
- ;;("srecode: fields" . srecode-field-utest) ; moved to automated suite
- ;;("srecode: templates" . srecode-utest-template-output)
- ("srecode: show maps" . srecode-get-maps)
- ;;("srecode: getset" . srecode-utest-getset-output)
- )
- "Alist of all the tests in CEDET we should run.")
-
-(defvar cedet-running-master-tests nil
- "Non-nil when CEDET-utest is running all the tests.")
-
-(defun cedet-utest (&optional exit-on-error)
- "Run the CEDET unit tests.
-EXIT-ON-ERROR causes the test suite to exit on an error, instead
-of just logging the error."
- (interactive)
- (unless (and (fboundp 'semanticdb-minor-mode-p)
- (semanticdb-minor-mode-p))
- (error "CEDET Tests require semantic-mode to be enabled"))
- (dolist (L cedet-utest-libs)
- (load-file (expand-file-name (concat L ".el") cedet-utest-directory)))
- (cedet-utest-log-setup "ALL TESTS")
- (let ((tl cedet-utest-test-alist)
- (notes nil)
- (err nil)
- (start (current-time))
- (end nil)
- (cedet-running-master-tests t)
- )
- (dolist (T tl)
- (cedet-utest-add-log-item-start (car T))
- (setq notes nil err nil)
- (condition-case Cerr
- (progn
- (funcall (cdr T))
- )
- (error
- (setq err (format "ERROR: %S" Cerr))
- ;;(message "Error caught: %s" Cerr)
- ))
-
- ;; Cleanup stray input and events that are in the way.
- ;; Not doing this causes sit-for to not refresh the screen.
- ;; Doing this causes the user to need to press keys more frequently.
- (when (and (called-interactively-p 'interactive) (input-pending-p))
- (if (fboundp 'read-event)
- (read-event)
- (read-char)))
-
- (cedet-utest-add-log-item-done notes err)
- (when (and exit-on-error err)
- (message "to debug this test point, execute:")
- (message "%S" (cdr T))
- (message "\n ** Exiting Test Suite. ** \n")
- (throw 'cedet-utest-exit-on-error t)
- )
- )
- (setq end (current-time))
- (cedet-utest-log-shutdown-msg "ALL TESTS" start end)
- nil))
-
-(defun cedet-utest-noninteractive ()
- "Return non-nil if running non-interactively."
- (declare (obsolete nil "27.1"))
- noninteractive)
-
-(defvar srecode-map-save-file)
-
-;;;###autoload
-(defun cedet-utest-batch ()
- "Run the CEDET unit test in BATCH mode."
- (unless noninteractive
- (error "`cedet-utest-batch' is to be used only with -batch"))
- (condition-case err
- (when (catch 'cedet-utest-exit-on-error
- ;; Get basic semantic features up.
- ;; FIXME: I can't see any such function in our code!
- (semantic-load-enable-minimum-features)
- ;; Disables all caches related to semantic DB so all
- ;; tests run as if we have bootstrapped CEDET for the
- ;; first time.
- (setq-default semanticdb-new-database-class 'semanticdb-project-database)
- (message "Disabling existing Semantic Database Caches.")
-
- ;; Disabling the srecoder map, we won't load a pre-existing one
- ;; and will be forced to bootstrap a new one.
- (setq srecode-map-save-file nil)
-
- ;; Run the tests
- (cedet-utest t)
- )
- (kill-emacs 1))
- (error
- (error "Error in unit test harness:\n %S" err))
- )
- )
-
-;;; Logging utility.
-;;
-(defvar cedet-utest-frame nil
- "Frame used during cedet unit test logging.")
-(defvar cedet-utest-buffer nil
- "Frame used during cedet unit test logging.")
-(defvar cedet-utest-frame-parameters
- '((name . "CEDET-UTEST")
- (width . 80)
- (height . 25)
- (minibuffer . t))
- "Frame parameters used for the cedet utest log frame.")
-
-(defvar cedet-utest-last-log-item nil
- "Remember the last item we were logging for.")
-
-(defvar cedet-utest-log-timer nil
- "During a test, track the start time.")
-
-(defun cedet-utest-log-setup (&optional title)
- "Setup a frame and buffer for unit testing.
-Optional argument TITLE is the title of this testing session."
- (setq cedet-utest-log-timer (current-time))
- (if noninteractive
- (message "\n>> Setting up %s tests to run @ %s\n"
- (or title "")
- (current-time-string))
-
- ;; Interactive mode needs a frame and buffer.
- (when (or (not cedet-utest-frame) (not (frame-live-p cedet-utest-frame)))
- (setq cedet-utest-frame (make-frame cedet-utest-frame-parameters)))
- (when (or (not cedet-utest-buffer) (not (buffer-live-p cedet-utest-buffer)))
- (setq cedet-utest-buffer (get-buffer-create "*CEDET utest log*")))
- (with-current-buffer cedet-utest-buffer
- (setq cedet-utest-last-log-item nil)
- (when (not cedet-running-master-tests)
- (erase-buffer))
- (insert "\n\nSetting up "
- (or title "")
- " tests to run @ " (current-time-string) "\n\n"))
- (let ((oframe (selected-frame)))
- (unwind-protect
- (progn
- (select-frame cedet-utest-frame)
- (switch-to-buffer cedet-utest-buffer t))
- (select-frame oframe)))
- ))
-
-(defun cedet-utest-elapsed-time (start end)
- "Copied from elp.el. Was elp-elapsed-time.
-Argument START and END bound the time being calculated."
- (float-time (time-subtract start end)))
-
-(defun cedet-utest-log-shutdown (title &optional _errorcondition)
- "Shut-down a larger test suite.
-TITLE is the section that is done.
-ERRORCONDITION is some error that may have occurred during testing."
- (let ((endtime (current-time))
- )
- (cedet-utest-log-shutdown-msg title cedet-utest-log-timer endtime)
- (setq cedet-utest-log-timer nil)
- ))
-
-(defun cedet-utest-log-shutdown-msg (title startime endtime)
- "Show a shutdown message with TITLE, STARTIME, and ENDTIME."
- (if noninteractive
- (progn
- (message "\n>> Test Suite %s ended at @ %s"
- title
- (format-time-string "%c" endtime))
- (message " Elapsed Time %.2f Seconds\n"
- (cedet-utest-elapsed-time startime endtime)))
-
- (with-current-buffer cedet-utest-buffer
- (goto-char (point-max))
- (insert "\n>> Test Suite " title " ended at @ "
- (format-time-string "%c" endtime) "\n"
- " Elapsed Time "
- (number-to-string
- (cedet-utest-elapsed-time startime endtime))
- " Seconds\n * "))
- ))
-
-(defun cedet-utest-show-log-end ()
- "Show the end of the current unit test log."
- (unless noninteractive
- (let* ((cb (current-buffer))
- (cf (selected-frame))
- (bw (or (get-buffer-window cedet-utest-buffer t)
- (get-buffer-window (switch-to-buffer cedet-utest-buffer) t)))
- (lf (window-frame bw))
- )
- (select-frame lf)
- (select-window bw)
- (goto-char (point-max))
- (select-frame cf)
- (set-buffer cb)
- )))
-
-(defun cedet-utest-post-command-hook ()
- "Hook run after the current log command was run."
- (if noninteractive
- (message "")
- (with-current-buffer cedet-utest-buffer
- (goto-char (point-max))
- (insert "\n\n")))
- (setq cedet-utest-last-log-item nil)
- (remove-hook 'post-command-hook #'cedet-utest-post-command-hook)
- )
-
-(defun cedet-utest-add-log-item-start (item)
- "Add ITEM into the log as being started."
- (unless (equal item cedet-utest-last-log-item)
- (setq cedet-utest-last-log-item item)
- ;; This next line makes sure we clear out status during logging.
- (add-hook 'post-command-hook #'cedet-utest-post-command-hook)
-
- (if noninteractive
- (message " - Running %s ..." item)
- (with-current-buffer cedet-utest-buffer
- (goto-char (point-max))
- (when (not (bolp)) (insert "\n"))
- (insert "Running " item " ... ")
- (sit-for 0)
- ))
- (cedet-utest-show-log-end)
- ))
-
-(defun cedet-utest-add-log-item-done (&optional notes err precr)
- "Add into the log that the last item is done.
-Apply NOTES to the doneness of the log.
-Apply ERR if there was an error in previous item.
-Optional argument PRECR indicates to prefix the done message with
-a newline."
- (if noninteractive
- ;; Non-interactive-mode - show a message.
- (if notes
- (message " * %s {%s}" (or err "done") notes)
- (message " * %s" (or err "done")))
- ;; Interactive-mode - insert into the buffer.
- (with-current-buffer cedet-utest-buffer
- (goto-char (point-max))
- (when precr (insert "\n"))
- (if err
- (insert err)
- (insert "done")
- (when notes (insert " (" notes ")")))
- (insert "\n")
- (setq cedet-utest-last-log-item nil)
- (sit-for 0)
- )))
-
-;;; INDIVIDUAL TEST API
-;;
-;; Use these APIs to start and log information.
-;;
-;; The other fcns will be used to log across all the tests at once.
-(defun cedet-utest-log-start (testname)
- "Setup the log for the test TESTNAME."
- ;; Make sure we have a log buffer.
- (save-window-excursion
- (when (or (not cedet-utest-buffer)
- (not (buffer-live-p cedet-utest-buffer))
- (not (get-buffer-window cedet-utest-buffer t))
- )
- (cedet-utest-log-setup))
- ;; Add our startup message.
- (cedet-utest-add-log-item-start testname)
- ))
-
-(defun cedet-utest-log (format &rest args)
- "Log the text string FORMAT.
-The rest of the ARGS are used to fill in FORMAT with `format'."
- (if noninteractive
- (apply #'message format args)
- (with-current-buffer cedet-utest-buffer
- (goto-char (point-max))
- (when (not (bolp)) (insert "\n"))
- (insert (apply #'format format args))
- (insert "\n")
- (sit-for 0)
- ))
- (cedet-utest-show-log-end)
- )
-
-;;; pulse test
-
-(defun pulse-test (&optional no-error)
- "Test the lightening function for pulsing a line.
-When optional NO-ERROR don't throw an error if we can't run tests."
- (interactive)
- (if (not (and (bound-and-true-p pulse-flag)
- (fboundp 'pulse-available-p)
- (pulse-available-p)))
- (if no-error
- nil
- (error (concat "Pulse test only works on versions of Emacs"
- " that support pulsing")))
- (declare-function pulse-momentary-highlight-overlay
- "pulse.el" (o &optional face))
- ;; Run the tests
- (when (called-interactively-p 'interactive)
- (message "<Press a key> Pulse one line.")
- (read-char))
- (pulse-momentary-highlight-one-line (point))
- (when (called-interactively-p 'interactive)
- (message "<Press a key> Pulse a region.")
- (read-char))
- (pulse-momentary-highlight-region (point)
- (save-excursion
- (condition-case nil
- (forward-char 30)
- (error nil))
- (point)))
- (when (called-interactively-p 'interactive)
- (message "<Press a key> Pulse line a specific color.")
- (read-char))
- (pulse-momentary-highlight-one-line (point) 'mode-line)
- (when (called-interactively-p 'interactive)
- (message "<Press a key> Pulse a pre-existing overlay.")
- (read-char))
- (let* ((start (point-at-bol))
- (end (save-excursion
- (end-of-line)
- (when (not (eobp))
- (forward-char 1))
- (point)))
- (o (make-overlay start end))
- )
- (pulse-momentary-highlight-overlay o)
- (if (overlay-buffer o)
- (delete-overlay o)
- (error "Non-temporary overlay was deleted!"))
- )
- (when (called-interactively-p 'interactive)
- (message "Done!"))))
-
-(provide 'cedet-utests)
-
-;;; cedet-utests.el ends here
+++ /dev/null
-;;; ede-tests.el --- Some tests for the Emacs Development Environment -*- lexical-binding: t -*-
-
-;; Copyright (C) 2008-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Extracted from ede-locate.el in the CEDET distribution.
-
-;;; Code:
-
-;;; From ede-locate:
-
-(require 'ede/locate)
-
-;;; TESTS
-;;
-;; Some testing routines.
-(defun ede-locate-test-locate (file)
- "Test EDE Locate on FILE using LOCATE type.
-The search is done with the current EDE root."
- (interactive "sFile: ")
- (let ((loc (ede-locate-locate
- "test"
- :root (ede-project-root-directory
- (ede-toplevel)))))
- (data-debug-new-buffer "*EDE Locate ADEBUG*")
- (ede-locate-file-in-project loc file)
- (data-debug-insert-object-slots loc "]")))
-
-(defun ede-locate-test-global (file)
- "Test EDE Locate on FILE using GNU Global type.
-The search is done with the current EDE root."
- (interactive "sFile: ")
- (let ((loc (ede-locate-global
- "test"
- :root (ede-project-root-directory
- (ede-toplevel)))))
- (data-debug-new-buffer "*EDE Locate ADEBUG*")
- (ede-locate-file-in-project loc file)
- (data-debug-insert-object-slots loc "]")))
-
-(defun ede-locate-test-idutils (file)
- "Test EDE Locate on FILE using ID Utils type.
-The search is done with the current EDE root."
- (interactive "sFile: ")
- (let ((loc (ede-locate-idutils
- "test"
- :root (ede-project-root-directory
- (ede-toplevel)))))
- (data-debug-new-buffer "*EDE Locate ADEBUG*")
- (ede-locate-file-in-project loc file)
- (data-debug-insert-object-slots loc "]")))
-
-(defun ede-locate-test-cscope (file)
- "Test EDE Locate on FILE using CScope type.
-The search is done with the current EDE root."
- (interactive "sFile: ")
- (let ((loc (ede-locate-cscope
- "test"
- :root (ede-project-root-directory
- (ede-toplevel)))))
- (data-debug-new-buffer "*EDE Locate ADEBUG*")
- (ede-locate-file-in-project loc file)
- (data-debug-insert-object-slots loc "]")))
-
-;;; ede-tests.el ends here
+++ /dev/null
-;;; semantic-tests.el --- Miscellaneous Semantic tests. -*- lexical-binding: t; -*-
-
-;; Copyright (C) 2003-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Originally, there are many test functions scattered among the
-;; Semantic source files. This file consolidates them.
-
-;;; Code:
-
-(require 'data-debug)
-
-;;; From semantic-complete
-
-(require 'semantic/complete)
-
-(defun semantic-complete-test ()
- "Test completion mechanisms."
- (interactive)
- (message "%S"
- (semantic-format-tag-prototype
- (semantic-complete-read-tag-project "Symbol: "))))
-
-;;; From semanticdb-global:
-
-(require 'semantic/db-global)
-
-(defvar semanticdb-test-gnu-global-startfile "~/src/global-5.7.3/global/global.c"
- "File to use for testing.")
-
-(defun semanticdb-test-gnu-global (searchfor &optional standardfile)
- "Test the GNU Global semanticdb.
-Argument SEARCHFOR is the text to search for.
-If optional arg STANDARDFILE is non-nil, use a standard file with
-global enabled."
- (interactive "sSearch For Tag: \nP")
-
- (require 'data-debug)
- (save-excursion
- (when standardfile
- (save-match-data
- (set-buffer (find-file-noselect semanticdb-test-gnu-global-startfile))))
-
- (condition-case err
- (semanticdb-enable-gnu-global-in-buffer)
- (error (if standardfile
- (error err)
- (save-match-data
- (set-buffer (find-file-noselect semanticdb-test-gnu-global-startfile)))
- (semanticdb-enable-gnu-global-in-buffer))))
-
- (let* ((db (semanticdb-project-database-global)) ;; "global"
- (tab (semanticdb-file-table db (buffer-file-name)))
- (result (semanticdb-deep-find-tags-for-completion-method tab searchfor))
- )
- (data-debug-new-buffer "*SemanticDB Gnu Global Result*")
- (data-debug-insert-thing result "?" ""))))
-
-;;; From semantic-format
-
-(require 'semantic/format)
-
-(defun semantic-test-all-format-tag-functions (&optional arg)
- "Test all outputs from `semantic-format-tag-functions'.
-Output is generated from the function under `point'.
-Optional argument ARG specifies not to use color."
- (interactive "P")
- (semantic-fetch-tags)
- (let* ((tag (semantic-current-tag))
- (par (semantic-current-tag-parent))
- (fns semantic-format-tag-functions))
- (with-output-to-temp-buffer "*format-tag*"
- (princ "Tag->format function tests:")
- (while fns
- (princ "\n")
- (princ (car fns))
- (princ ":\n ")
- (let ((s (funcall (car fns) tag par (not arg))))
- (with-current-buffer "*format-tag*"
- (goto-char (point-max))
- (insert s)))
- (setq fns (cdr fns))))
- ))
-
-;;; From semantic-fw:
-
-(require 'semantic/fw)
-
-(defun semantic-test-throw-on-input ()
- "Test that throw on input will work."
- (interactive)
- (semantic-throw-on-input 'done-die)
- (message "Exit Code: %s"
- (semantic-exit-on-input 'testing
- (let ((inhibit-quit nil)
- (message-log-max nil))
- (while t
- (message "Looping ... press a key to test")
- (semantic-throw-on-input 'test-inner-loop))
- 'exit)))
- (when (input-pending-p)
- (if (fboundp 'read-event)
- (read-event)
- (read-char))))
-
-;;; From semantic-idle:
-
-(require 'semantic/idle)
-
-(defun semantic-idle-pnf-test ()
- "Test `semantic-idle-scheduler-work-parse-neighboring-files' and time it."
- (interactive)
- (let ((start (current-time))
- (_junk (semantic-idle-scheduler-work-parse-neighboring-files)))
- (message "Work took %.2f seconds." (semantic-elapsed-time start nil))))
-
-;;; From semantic-lex:
-
-(require 'semantic/lex)
-
-(defun semantic-lex-test-full-depth (arg)
- "Test the semantic lexer in the current buffer parsing through lists.
-Usually the lexer parses.
-If universal argument ARG, then try the whole buffer."
- (interactive "P")
- (let* ((start (current-time))
- (result (semantic-lex
- (if arg (point-min) (point))
- (point-max)
- 100)))
- (message "Elapsed Time: %.2f seconds."
- (semantic-elapsed-time start nil))
- (pop-to-buffer "*Lexer Output*")
- (require 'pp)
- (erase-buffer)
- (insert (pp-to-string result))
- (goto-char (point-min))))
-
-(defun semantic-lex-test-region (beg end)
- "Test the semantic lexer in the current buffer.
-Analyze the area between BEG and END."
- (interactive "r")
- (let ((result (semantic-lex beg end)))
- (pop-to-buffer "*Lexer Output*")
- (require 'pp)
- (erase-buffer)
- (insert (pp-to-string result))
- (goto-char (point-min))))
-
-;;; From semantic-lex-spp:
-
-(require 'semantic/lex-spp)
-
-(defun semantic-lex-spp-write-test ()
- "Test the semantic tag writer against the current buffer."
- (interactive)
- (with-output-to-temp-buffer "*SPP Write Test*"
- (semantic-lex-spp-table-write-slot-value
- (semantic-lex-spp-save-table))))
-
-(defvar cedet-utest-directory) ;From test/manual/cedet/cedet-utests.el?
-
-(defun semantic-lex-spp-write-utest ()
- "Unit test using the test spp file to test the slot write fcn."
- (interactive)
- (save-excursion
- (let ((buff (find-file-noselect
- (expand-file-name "tests/testsppreplace.c"
- cedet-utest-directory))))
- (set-buffer buff)
- (semantic-lex-spp-write-test)
- (kill-buffer buff)
- (when (not (called-interactively-p 'interactive))
- (kill-buffer "*SPP Write Test*"))
- )))
-
-;;; From semantic-tag-write:
-
-;;; TESTING.
-
-(require 'semantic/tag-write)
-
-(defun semantic-tag-write-test ()
- "Test the semantic tag writer against the tag under point."
- (interactive)
- (with-output-to-temp-buffer "*Tag Write Test*"
- (semantic-tag-write-one-tag (semantic-current-tag))))
-
-(defun semantic-tag-write-list-test ()
- "Test the semantic tag writer against the tag under point."
- (interactive)
- (with-output-to-temp-buffer "*Tag Write Test*"
- (semantic-tag-write-tag-list (semantic-fetch-tags))))
-
-;;; From semantic-symref-filter:
-
-(require 'semantic/symref/filter)
-
-(defun semantic-symref-test-count-hits-in-tag ()
- "Lookup in the current tag the symbol under point.
-Then count all the other references to the same symbol within the
-tag that contains point, and return that."
- (interactive)
- (let* ((ctxt (semantic-analyze-current-context))
- (target (car (reverse (oref ctxt prefix))))
- (tag (semantic-current-tag))
- (start (current-time))
- (Lcount 0))
- (when (semantic-tag-p target)
- (semantic-symref-hits-in-region
- target (lambda (_start _end _prefix) (setq Lcount (1+ Lcount)))
- (semantic-tag-start tag)
- (semantic-tag-end tag))
- (when (called-interactively-p 'interactive)
- (message "Found %d occurrences of %s in %.2f seconds"
- Lcount (semantic-tag-name target)
- (semantic-elapsed-time start nil)))
- Lcount)))
-
-;;; semantic-tests.el ends here
+++ /dev/null
-/* test.c --- Semantic unit test for C.
-
- Copyright (C) 2001-2024 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 <https://www.gnu.org/licenses/>.
-*/
-
-/* Attempt to include as many aspects of the C language as possible.
- */
-
-/* types of include files */
-#include "includeme1.h"
-#include <includeme2.h>
-#include <subdir/includeme3.h>
-#include <includeme.notanhfile>
-#include <stdlib.h>
-#include <cmath>
-
-#if 0
-int dont_show_function()
-{
-}
-#endif
-
-/* Global types */
-struct mystruct1 {
- int slot11;
- char slot12;
- float slot13;
-};
-
-struct mystruct2 {
- int slot21;
- char slot22;
- float slot23;
-} var_of_type_mystruct2;
-
-struct {
- int slot31;
- char slot32;
- float slot33;
-} var_of_anonymous_struct;
-
-typedef struct mystruct1 typedef_of_mystruct1;
-typedef struct mystruct1 *typedef_of_pointer_mystruct1;
-typedef struct { int slot_a; } typedef_of_anonymous_struct;
-typedef struct A {
-} B;
-
-typedef struct mystruct1 td1, td2;
-
-union myunion1 {
- int slot41;
- char slot42;
- float slot43;
-};
-
-union myunion2 {
- int slot51;
- char slot52;
- float slot53;
-} var_of_type_myunion2;
-
-struct {
- int slot61;
- char slot72;
- float slot83;
-} var_of_anonymous_union;
-
-typedef union myunion1 typedef_of_myunion1;
-typedef union myunion1 *typedef_of_pointer_myunion1;
-typedef union { int slot_a; } typedef_of_anonymous_union;
-
-enum myenum1 { enum11 = 1, enum12 };
-enum myenum2 { enum21, enum22 = 2 } var_of_type_myenum2;
-enum { enum31, enum32 } var_of_anonymous_enum;
-
-typedef enum myenum1 typedef_of_myenum1;
-typedef enum myenum1 *typedef_of_pointer_myenum1;
-typedef enum { enum_a = 3, enum_b } typedef_of_anonymous_enum;
-
-typedef int typedef_of_int;
-
-/* Here are some simpler variable types */
-int var1;
-int varbit1:1;
-char var2;
-float var3;
-mystruct1 var3;
-struct mystruct1 var4;
-union myunion1 var5;
-enum myenum1 var6;
-
-char *varp1;
-char **varp2;
-char varv1[1];
-char varv2[1][2];
-
-char *varpa1 = "moose";
-struct mystruct2 vara2 = { 1, 'a', 0.0 };
-enum myenum1 vara3 = enum11;
-int vara4 = (int)0.0;
-int vara5 = funcall();
-
-int mvar1, mvar2, mvar3;
-char *mvarp1, *mvarp2, *mvarp3;
-char *mvarpa1 = 'a', *mvarpa2 = 'b', *mvarpa3 = 'c';
-char mvaras1[10], mvaras2[12][13], *mvaras3 = 'd';
-
-static register const unsigned int tmvar1;
-
-#define MACRO1 1
-#define MACRO2(foo) (1+foo)
-
-/* Here are some function prototypes */
-
-/* This is legal, but I decided not to support inferred integer
- * types on functions and variables.
- */
-fun0();
-int funp1();
-char funp2(int arg11);
-float funp3(char arg21, char arg22);
-struct mystrct1 funp4(struct mystruct2 arg31, union myunion2 arg32);
-enum myenum1 funp5(char *arg41, union myunion1 *arg42);
-
-char funpp1 __P(char argp1, struct mystruct2 argp2, char *arg4p);
-
-int fun1();
-
-/* Here is a function pointer */
-int (*funcptr)(int a, int b);
-
-/* Function Definitions */
-
-/* This is legal, but I decided not to support inferred integer
- * types on functions and variables.
- */
-fun0()
-{
- int sv = 0;
-}
-
-int fun1 ()
-{
- int sv = 1;
-}
-
-int fun1p1 (void)
-{
- int sv = 1;
-}
-
-char fun2(int arg_11)
-{
- char sv = 2;
-}
-
-float fun3(char arg_21, char arg_22)
-{
- char sv = 3;
-}
-
-struct mystrct1 fun4(struct mystruct2 arg31, union myunion2 arg32)
-{
- sv = 4;
-}
-
-enum myenum1 fun5(char *arg41, union myunion1 *arg42)
-{
- sv = 5;
-}
-
-/* Functions with K&R syntax. */
-struct mystrct1 funk1(arg_31, arg_32)
- struct mystruct2 arg_31;
- union myunion2 arg32;
-{
- sv = 4;
-}
-
-enum myenum1 *funk2(arg_41, arg_42)
- char *arg_41;
- union myunion1 *arg_42;
-{
- sv = 5;
-
- if(foo) {
- }
-}
-
-int funk3(arg_51, arg_53)
- int arg_51;
- char arg_53;
-{
- char q = 'a';
- int sv = 6;
- td1 ms1;
- enum myenum1 testconst;
-
- /* Function argument analysis */
- funk3(ms1.slot11, arg_53 );
- sv = 7;
-
- /* Slot deref on assignee */
- ms1.slot11 = s;
-
- /* Enum/const completion */
- testconst = e;
-
- /* Bad var/slot and param */
- blah.notafunction(moose);
-
- /* Print something. */
- printf("Moose", );
-
- tan();
-}
-
-int funk4_fixme(arg_61, arg_62)
- int arg_61, arg_62;
-{
-
-}
-
-/* End of C tests */
+++ /dev/null
-;;; test.el --- Unit test file for Semantic Emacs Lisp support. -*- lexical-binding: t -*-
-
-;; Copyright (C) 2005-2024 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 <https://www.gnu.org/licenses/>.
-
-;;; Code:
-
-(require 'semantic)
-(require 'eieio "../eieio")
-
-;; tags encapsulated in eval-when-compile and eval-and-compile
-;; should be expanded out into the outer environment.
-(eval-when-compile
- (require 'semantic-imenu))
-
-(eval-and-compile
- (defconst const-1 nil)
- (defun function-1 (arg)
- nil))
-
-;;; Functions
-;;
-(defun a-defun (arg1 arg2 &optional arg3)
- "Doc a."
- nil)
-
-(defun a-defun-interactive (arg1 arg2 &optional arg3)
- "Doc a that is a command."
- (interactive "R")
- nil)
-
-(defun* a-defun* (arg1 arg2 &optional arg3)
- "doc a*"
- nil)
-
-(defsubst a-defsubst (arg1 arg2 &optional arg3)
- "Doc a-subst."
- nil)
-
-(defmacro a-defmacro (arg1 arg2 &optional arg3)
- "Doc a-macro."
- nil)
-
-(define-overload a-overload (arg)
- "Doc a-overload."
- nil)
-
-;;; Methods
-;;
-(cl-defmethod a-method ((obj some-class) &optional arg2)
- "Doc String for a method."
- (call-next-method))
-
-(cl-defgeneric a-generic (arg1 arg2)
- "General description of a-generic.")
-
-;;; Advice
-;;
-(defadvice existing-function-to-advise (around test activate)
- "Do something special to this fcn."
- (ad-do-it))
-
-;;; Variables
-;;
-(defvar a-defvar (cons 1 2)
- "Variable a.")
-
-;; FIXME: This practice is not recommended in recent Emacs. Remove?
-(defvar a-defvar-star (cons 1 2)
- "*User visible var a.")
-
-(defconst a-defconst 'a "Var doc const.")
-
-(defcustom a-defcustom nil
- "Doc custom."
- :group 'a-defgroup
- :type 'boolean)
-
-(defface a-defface 'bold
- "A face that is bold.")
-
-(defimage ezimage-page-minus
- ((:type xpm :file "page-minus.xpm" :ascent center))
- "Image used for open files with stuff in them.")
-
-;;; Autoloads
-;;
-(autoload (quote a-autoload) "somefile"
- "Non-interactive autoload." nil nil)
-
-(autoload (quote a-autoload-interactive) "somefile"
-"Interactive autoload." t nil)
-
-
-(defgroup a-defgroup nil
- "Group for `emacs-lisp' regression-test.")
-
-;;; Classes
-;;
-(defclass a-class (a-parent)
- ((slot-1)
- (slot-2 :initarg :slot-2)
- (slot-3 :documentation "Doc about slot3")
- (slot-4 :type 'boolean)
- )
- "Doc String for class.")
-
-(defclass a-class-abstract ()
- nil
- "Doc string for abstract class."
- :abstract t)
-
-;;; Structures
-;;
-(defstruct (test-struct-1 :test 'equal)
- (slot-1 :equal 'eq)
- slot-2)
-
-(defstruct test-struct-2
- slot-1
- slot-2)
-
-;;; Semantic specific macros
-;;
-(define-lex a-lexer
- "Doc String"
- this
- that)
-
-(define-mode-local-override a-overridden-function
- emacs-lisp-mode (tag)
- "A function that is overloaded."
- nil)
-
-(defvar-mode-local emacs-lisp-mode a-mode-local-def
- "some value")
-
-(provide 'test)
-
-;;; test.el ends here
+++ /dev/null
-# test.make --- Semantic unit test for Make -*- makefile -*-
-
-# Copyright (C) 2001-2002, 2010-2024 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 <https://www.gnu.org/licenses/>.
-
-top=
-ede_FILES=Project.ede Makefile
-
-example_MISC=semantic-skel.el skeleton.bnf
-init_LISP=semantic-load.el
-DISTDIR=$(top)semantic-$(VERSION)
-
-# really goofy & variables tabs
-A= B
-A =B
-A=B C
-A=B\
- C
-
-A= http://${B} \
- ftp://${B}
-B= test
-
-all: example semantic Languages tools senator semantic.info
-
-test ${B}: foo bar
- @echo ${A}
-
-example:
- @
-
-init: $(init_LISP)
- @echo "(add-to-list 'load-path nil)" > $@-compile-script
- @if test ! -z "${LOADPATH}" ; then\
- for loadpath in ${LOADPATH}; do \
- echo "(add-to-list 'load-path \"$$loadpath\")" >> $@-compile-script; \
- done;\
- fi
- @echo "(setq debug-on-error t)" >> $@-compile-script
- $(EMACS) -batch -l $@-compile-script -f batch-byte-compile $^
-
-include tesset.mk tusset.mk
-include oneset.mk
-
-ifdef SOME_SYMBOL
- VAR1 = foo
-else
- VAR1 = bar
-endif
-
-ifndef SOME_OTHER_SYMBOL
- VAR1 = baz
-endif
-
-ifeq ($(VAR1), foo)
- VAR2 = gleep
-else
- ifneq ($(VAR1), foo)
- VAR2 = glop
- endif
-endif
-
-# End of Makefile
+++ /dev/null
-/** testpolymorph.cpp --- A sequence of polymorphism examples.
- *
- * Copyright (C) 2009-2024 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 <https://www.gnu.org/licenses/>.
- */
-
-#include <cmath>
-
-// Test 1 - Functions with prototypes
-namespace proto {
-
- int pt_func1(int arg1);
- int pt_func1(int arg1) {
- return 0;
- }
-
-}
-
-// Test 2 - Functions with different arg lists.
-namespace fcn_poly {
-
- int pm_func(void) {
- return 0;
- }
- int pm_func(int a) {
- return a;
- }
- int pm_func(char a) {
- return int(a);
- }
- int pm_func(double a) {
- return int(floor(a));
- }
-
-}
-
-// Test 3 - Methods with different arg lists.
-class meth_poly {
-public:
- int pm_meth(void) {
- return 0;
- }
- int pm_meth(int a) {
- return a;
- }
- int pm_meth(char a) {
- return int(a);
- }
- int pm_meth(double a) {
- return int(floor(a));
- }
-
-};
-
-// Test 4 - Templates with partial specifiers.
-namespace template_partial_spec {
- template <typename T> class test
- {
- public:
- void doSomething(T t) { };
- };
-
- template <typename T> class test<T *>
- {
- public:
- void doSomething(T* t) { };
- };
-}
-
-// Test 5 - Templates with full specialization which may or may not share
-// common functions.
-namespace template_full_spec {
- template <typename T> class test
- {
- public:
- void doSomething(T t) { };
- void doSomethingElse(T t) { };
- };
-
- template <> class test<int>
- {
- public:
- void doSomethingElse(int t) { };
- void doSomethingCompletelyDifferent(int t) { };
- };
-}
-
-// Test 6 - Dto., but for templates with multiple parameters.
-namespace template_multiple_spec {
- template <typename T1, typename T2> class test
- {
- public:
- void doSomething(T1 t) { };
- void doSomethingElse(T2 t) { };
- };
-
- template <typename T2> class test<int, T2>
- {
- public:
- void doSomething(int t) { };
- void doSomethingElse(T2 t) { };
- };
-
- template <> class test<float, int>
- {
- public:
- void doSomething(float t) { };
- void doSomethingElse(int t) { };
- void doNothing(void) { };
- };
-}
-
-
-// End of polymorphism test file.
+++ /dev/null
-/* testspp.cpp --- Semantic unit test for the C preprocessor
-
- Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-*/
-
-int some_fcn (){}
-
-
-#ifndef MOOSE
-int pre_show_moose(){}
-#endif
-
-#ifdef MOOSE
-int pre_dont_show_moose(){}
-#endif
-
-#if !defined(MOOSE)
-int pre_show_moose_if(){}
-#endif
-
-#if defined(MOOSE)
-int pre_dont_show_moose_if(){}
-#endif
-
-#define MOOSE
-
-#if 0
-int dont_show_function_if_0(){}
-#endif
-
-#if 1
-int show_function_if_1(){}
-#endif
-
-#ifdef MOOSE
-int moose_function(){}
-#endif
-
-#ifndef MOOSE
-int dont_show_moose(){}
-#endif
-
-#if defined(MOOSE)
-int moose_function_if(){}
-#endif
-
-#if !defined(MOOSE)
-int dont_show_moose_if() {}
-#endif
-
-#undef MOOSE
-
-#ifdef MOOSE
-int no_handy_moose(){}
-#endif
-
-#ifndef MOOSE
-int show_moose_else() {}
-#else
-int no_show_moose_else(){}
-#endif
-
-
-#ifdef MOOSE
-int no_show_moose_else_2() {}
-#else
-int show_moose_else_2() {}
-#endif
-
-#if defined(MOOSE)
-int no_show_moose_elif() {}
-#elif !defined(MOOSE)
-int show_moose_elif() {}
-#else
-int no_show_moose_elif_else() {}
-#endif
-
-#if defined(MOOSE)
-int no_show_moose_if_elif_2() {}
-#elif defined(COW)
-int no_show_moose_elif_2() {}
-#else
-int show_moose_elif_else() {}
-#endif
+++ /dev/null
-/* testsppreplace.c --- unit test for CPP/SPP Replacement
- Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-*/
-
-/* TEST: The EMU keyword doesn't screw up the function defn. */
-#define EMU
-#define EMU2 /*comment*/
-char EMU parse_around_emu EMU2 (EMU)
-{
-}
-
-/* TEST: A simple word can be replaced in a definition. */
-#define SUBFLOAT /* Some Float */ float
-SUBFLOAT returnanfloat()
-{
-}
-
-/* TEST: Punctuation an be replaced in a definition. */
-#define COLON :
-int foo COLON COLON bar ()
-{
-}
-
-/* TEST: Multiple lexical characters in a definition */
-#define SUPER mysuper::
-int SUPER baz ()
-{
-}
-
-/* TEST: Macro replacement. */
-#define INT_FCN(name) int name (int in)
-
-INT_FCN(increment) {
- return in+1;
-}
-
-/* TEST: Macro replacement with complex args */
-#define P_(proto) ()
-
-int myFcn1 P_((a,b));
-
-#define P__(proto) proto
-
-int myFcn2 P__((int a, int b));
-int myFcn3 (int a, int b);
-
-/* TEST: Multiple args to a macro. */
-#define MULTI_ARGS(name, field1, field2, field3) struct name { int field1; int field2; int field3; }
-
-MULTI_ARGS(ma_struct, moose, penguin, emu);
-
-/* TEST: Macro with args, but no body. */
-#define NO_BODY(name)
-
-NO_BODY(Moose);
-
-/* TEST: Not a macro with args, but close. */
-#define NOT_WITH_ARGS (moose)
-
-int not_with_args_fcn NOT_WITH_ARGS
-{
-}
-
-/* TEST: macro with continuation. */
-#define WITH_CONT \
- continuation_symbol
-
-int WITH_CONT () { };
-
-/* TEST: macros in a macro - tail processing */
-#define tail_with_args_and_long_name(a) (int a)
-#define int_arg tail_with_args_and_long_name
-
-int tail int_arg(q) {}
-
-/* TEST: macros used improperly. */
-#define tail_fail tail_with_args_and_long_name(q)
-
-int tail_fcn tail_fail(q);
-
-/* TEST: feature of CPP from LSD <lsdsgster@...> */
-#define __gthrw_(name) __gthrw_ ## name
-
-int __gthrw_(foo) (int arg1) { }
-
-/* TEST: macros using macros */
-#define macro_foo foo
-#define mf_declare int macro_foo
-
-mf_declare;
-
-/* TEST: macros with args using macros */
-#define Amacro(A) (int A)
-#define mf_Amacro(B) int B Amacro(B)
-
-mf_Amacro(noodle);
-
-/* TEST: Double macro using the argument stack. */
-#define MACRO0(name) int that_ ## name(int i);
-#define MACRO1(name) int this_ ## name(int i);
-#define MACRO2(name) MACRO0(name) MACRO1(name)
-
-MACRO2(foo)
-
-/* TEST: The G++ namespace macro hack. Not really part of SPP. */
-_GLIBCXX_BEGIN_NAMESPACE(baz)
-
- int bazfnc(int b) { }
-
-_GLIBCXX_END_NAMESPACE;
-
-_GLIBCXX_BEGIN_NESTED_NAMESPACE(foo,bar)
-
- int foo_bar_func(int a) { }
-
-_GLIBCXX_END_NESTED_NAMESPACE;
-
-
-/* TEST: The VC++ macro hack. */
-_STD_BEGIN
-
- int inside_std_namespace(int a) { }
-
-_STD_END
-
-/* TEST: Recursion prevention. CPP doesn't allow even 1 level of recursion. */
-#define STARTMACRO MACROA
-#define MACROA MACROB
-#define MACROB MACROA
-
-int STARTMACRO () {
-
-}
-
-
-/* END */
+++ /dev/null
-/* testsppreplaced.c --- unit test for CPP/SPP Replacement
- Copyright (C) 2007-2024 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 <https://www.gnu.org/licenses/>.
-*/
-
-/* What the SPP replace file would looklike with MACROS replaced: */
-
-/* TEST: The EMU keyword doesn't screw up the function defn. */
-char parse_around_emu ()
-{
-}
-
-/* TEST: A simple word can be replaced in a definition. */
-float returnanfloat()
-{
-}
-
-/* TEST: Punctuation an be replaced in a definition. */
-int foo::bar ()
-{
-}
-
-/* TEST: Multiple lexical characters in a definition */
-int mysuper::baz ()
-{
-}
-
-/* TEST: Macro replacement. */
-int increment (int in) {
- return in+1;
-}
-
-/* TEST: Macro replacement with complex args */
-int myFcn1 ();
-
-int myFcn2 (int a, int b);
-int myFcn3 (int a, int b);
-
-/* TEST: Multiple args to a macro. */
-struct ma_struct { int moose; int penguin; int emu; };
-
-/* TEST: Macro with args, but no body. */
-
-/* TEST: Not a macro with args, but close. */
-int not_with_args_fcn (moose)
-{
-}
-
-/* TEST: macro with continuation. */
-int continuation_symbol () { };
-
-/* TEST: macros in a macro - tail processing */
-
-int tail (int q) {}
-
-/* TEST: macros used improperly */
-
-int tail_fcn(int q);
-
-/* TEST: feature of CPP from LSD <lsdsgster@...> */
-
-int __gthrw_foo (int arg1) { }
-
-/* TEST: macros using macros */
-int foo;
-
-/* TEST: macros with args using macros */
-int noodle(int noodle);
-
-/* TEST: Double macro using the argument stack. */
-int that_foo(int i);
-int this_foo(int i);
-
-/* TEST: The G++ namespace macro hack. Not really part of SPP. */
-namespace baz {
-
- int bazfnc(int b) { }
-
-}
-
-namespace foo { namespace bar {
-
- int foo_bar_func(int a) { }
-
- }
-}
-
-/* TEST: The VC++ macro hack. */
-namespace std {
-
- int inside_std_namespace(int a) { }
-
-}
-
-/* TEST: Recursion prevention. CPP doesn't allow even 1 level of recursion. */
-int MACROA () {
-
-}
-
-
-/* End */
projects / emacs.git / commitdiff