diff options
Diffstat (limited to 'lisp/cedet/semantic')
57 files changed, 3415 insertions, 814 deletions
diff --git a/lisp/cedet/semantic/analyze.el b/lisp/cedet/semantic/analyze.el index 63acc555343..d03c72a5983 100644 --- a/lisp/cedet/semantic/analyze.el +++ b/lisp/cedet/semantic/analyze.el @@ -527,7 +527,7 @@ Returns an object based on symbol `semantic-analyze-context'." (function nil) (fntag nil) arg fntagend argtag - assign asstag + assign asstag newseq ) ;; Pattern for Analysis: @@ -601,16 +601,26 @@ Returns an object based on symbol `semantic-analyze-context'." (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 'prefixtypes 'unfindable))) + prefix scope '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 '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 'prefixtypes)) + (progn + (setq prefix (semantic-analyze-find-tag-sequence + prefix scope 'prefixtypes)) + (when (setq newseq + (semantic-analyze-dereference-alias prefix)) + (setq prefix (semantic-analyze-find-tag-sequence + newseq scope 'prefixtypes)))) (error (semantic-analyze-push-error err)))) ) @@ -679,6 +689,20 @@ Returns an object based on symbol `semantic-analyze-context'." ;; 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))))) (defun semantic-adebug-analyze (&optional ctxt) "Perform `semantic-analyze-current-context'. diff --git a/lisp/cedet/semantic/analyze/complete.el b/lisp/cedet/semantic/analyze/complete.el index edc3cdc230c..a83f4ff0ac8 100644 --- a/lisp/cedet/semantic/analyze/complete.el +++ b/lisp/cedet/semantic/analyze/complete.el @@ -87,20 +87,25 @@ in a buffer." ;; In theory, we don't need the below since the context will ;; do it for us. ;;(semantic-refresh-tags-safe) - (with-syntax-table semantic-lex-syntax-table - (let* ((context (if (semantic-analyze-context-child-p context) - context - (semantic-analyze-current-context context))) - (ans (if (not context) - (error "Nothing to complete") - (: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))) + (if (semantic-active-p) + (with-syntax-table semantic-lex-syntax-table + (let* ((context (if (semantic-analyze-context-child-p context) + context + (semantic-analyze-current-context context))) + (ans (if (not context) + (error "Nothing to complete") + (: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.")))) (defun semantic-analyze-possible-completions-default (context &optional flags) "Default method for producing smart completions. diff --git a/lisp/cedet/semantic/analyze/debug.el b/lisp/cedet/semantic/analyze/debug.el index 5fe0078478d..19c61cb74c7 100644 --- a/lisp/cedet/semantic/analyze/debug.el +++ b/lisp/cedet/semantic/analyze/debug.el @@ -443,7 +443,7 @@ or implementing a version specific to ") (semanticdb-file-table-object fileinner t)))) (cond ((not fileinner) (setq unknown (1+ unknown))) - ((number-or-marker-p (oref tableinner pointmax)) + ((and tableinner (number-or-marker-p (oref tableinner pointmax))) (setq ok (1+ ok))) (t (setq unparsed (1+ unparsed)))))) diff --git a/lisp/cedet/semantic/analyze/fcn.el b/lisp/cedet/semantic/analyze/fcn.el index a27356c784b..d780327b7e9 100644 --- a/lisp/cedet/semantic/analyze/fcn.el +++ b/lisp/cedet/semantic/analyze/fcn.el @@ -37,24 +37,6 @@ ;; ;; These queries allow a major mode to help the analyzer make decisions. ;; -(define-overloadable-function semantic-analyze-tag-prototype-p (tag) - "Non-nil if TAG is a prototype." - ) - -(defun semantic-analyze-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. - ((eq (semantic-tag-class tag) 'type) - (not (semantic-tag-type-members tag))) - ;; No other heuristics. - (t nil)) - )) - -;;------------------------------------------------------------ (define-overloadable-function semantic-analyze-split-name (name) "Split a tag NAME into a sequence. @@ -219,7 +201,7 @@ used by the analyzer debugger." (if (and type-declaration (semantic-tag-p type-declaration) (semantic-tag-of-class-p type-declaration 'type) - (not (semantic-analyze-tag-prototype-p type-declaration)) + (not (semantic-tag-prototype-p type-declaration)) ) ;; We have an anonymous type for TAG with children. ;; Use this type directly. @@ -312,7 +294,7 @@ SCOPE is the current scope." (when (and (semantic-tag-p ans) (eq (semantic-tag-class ans) 'type)) ;; We have a tag. - (if (semantic-analyze-tag-prototype-p ans) + (if (semantic-tag-prototype-p ans) ;; It is a prototype.. find the real one. (or (and scope (car-safe diff --git a/lisp/cedet/semantic/analyze/refs.el b/lisp/cedet/semantic/analyze/refs.el index 09a4c08c059..05ac56eac69 100644 --- a/lisp/cedet/semantic/analyze/refs.el +++ b/lisp/cedet/semantic/analyze/refs.el @@ -87,7 +87,7 @@ Use `semantic-analyze-current-tag' to debug this fcn." (semantic-go-to-tag tag db) (setq scope (semantic-calculate-scope)) - (setq allhits (semantic--analyze-refs-full-lookup tag scope)) + (setq allhits (semantic--analyze-refs-full-lookup tag scope t)) (semantic-analyze-references (semantic-tag-name tag) :tag tag @@ -115,7 +115,10 @@ Optional argument IN-BUFFER indicates that the returned tag should be in an acti (aDB (car ans)) ) (when (and (not (semantic-tag-prototype-p aT)) - (semantic-tag-similar-p tag aT :prototype-flag :parent)) + (semantic-tag-similar-p tag aT + :prototype-flag + :parent + :typemodifiers)) (when in-buffer (save-excursion (semantic-go-to-tag aT aDB))) (push aT impl)))) allhits) @@ -135,7 +138,10 @@ Optional argument IN-BUFFER indicates that the returned tag should be in an acti (aDB (car ans)) ) (when (and (semantic-tag-prototype-p aT) - (semantic-tag-similar-p tag aT :prototype-flag :parent)) + (semantic-tag-similar-p tag aT + :prototype-flag + :parent + :typemodifiers)) (when in-buffer (save-excursion (semantic-go-to-tag aT aDB))) (push aT proto)))) allhits) @@ -143,14 +149,15 @@ Optional argument IN-BUFFER indicates that the returned tag should be in an acti ;;; LOOKUP ;; -(defun semantic--analyze-refs-full-lookup (tag scope) +(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." +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) + (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. diff --git a/lisp/cedet/semantic/bovine/c-by.el b/lisp/cedet/semantic/bovine/c-by.el index b47dac49a52..96e12bba900 100644 --- a/lisp/cedet/semantic/bovine/c-by.el +++ b/lisp/cedet/semantic/bovine/c-by.el @@ -19,17 +19,21 @@ ;;; Commentary: ;; -;; This file was generated from etc/grammars/c.by. +;; This file was generated from admin/grammars/c.by. ;;; Code: (require 'semantic/lex) (eval-when-compile (require 'semantic/bovine)) - + +;;; Prologue +;; (declare-function semantic-c-reconstitute-token "semantic/bovine/c") (declare-function semantic-c-reconstitute-template "semantic/bovine/c") (declare-function semantic-expand-c-tag "semantic/bovine/c") - + +;;; Declarations +;; (defconst semantic-c-by--keyword-table (semantic-lex-make-keyword-table '(("extern" . EXTERN) @@ -42,6 +46,7 @@ ("inline" . INLINE) ("virtual" . VIRTUAL) ("mutable" . MUTABLE) + ("explicit" . EXPLICIT) ("struct" . STRUCT) ("union" . UNION) ("enum" . ENUM) @@ -124,6 +129,7 @@ ("enum" summary "Enumeration Type Declaration: enum [name] { ... };") ("union" summary "Union Type Declaration: union [name] { ... };") ("struct" summary "Structure Type Declaration: struct [name] { ... };") + ("explicit" summary "Forbids implicit type conversion: explicit <constructor>") ("mutable" summary "Member Declaration Modifier: mutable <type> <name> ...") ("virtual" summary "Method Modifier: virtual <type> <name>(...) ...") ("inline" summary "Function Modifier: inline <return type> <name>(...) {...};") @@ -486,6 +492,12 @@ ) (template) (using) + (spp-include + ,(semantic-lambda + (semantic-tag + (nth 0 vals) + 'include :inside-ns t)) + ) ( ;;EMPTY ) ) ;; end namespacesubparts @@ -1987,6 +1999,15 @@ "*" (nth 2 vals)))) ) + (open-paren + "(" + symbol + close-paren + ")" + ,(semantic-lambda + (list + (nth 1 vals))) + ) ) ;; end function-pointer (fun-or-proto-end @@ -2186,6 +2207,10 @@ semantic-flex-keywords-obarray semantic-c-by--keyword-table semantic-equivalent-major-modes '(c-mode c++-mode) )) + + +;;; Analyzers +;; ;;; Epilogue ;; diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el index 886b15d183e..a3d57108d1d 100644 --- a/lisp/cedet/semantic/bovine/c.el +++ b/lisp/cedet/semantic/bovine/c.el @@ -27,10 +27,13 @@ (require 'semantic) (require 'semantic/analyze) +(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)) @@ -103,8 +106,13 @@ NOTE: In process of obsoleting this." '( ("__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.") @@ -118,7 +126,15 @@ part of the preprocessor map.") (defun semantic-c-reset-preprocessor-symbol-map () "Reset the C preprocessor symbol map based on all input variables." - (when (featurep 'semantic/bovine/c) + (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) @@ -141,17 +157,17 @@ part of the preprocessor map.") (error (message "Error updating tables for %S" (object-name table))))) (setq filemap (append filemap (oref table lexical-table))) - ) - )))) - - (setq-mode-local c-mode - semantic-lex-spp-macro-symbol-obarray - (semantic-lex-make-spp-table - (append semantic-lex-c-preprocessor-symbol-map-builtin - semantic-lex-c-preprocessor-symbol-map - filemap)) - ) - ))) + ;; 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. @@ -236,6 +252,7 @@ Return the defined symbol as a special spp lex token." 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 "("))) @@ -246,7 +263,13 @@ Return the defined symbol as a special spp lex token." (raw-stream (semantic-lex-spp-stream-for-macro (save-excursion (semantic-c-end-of-macro) - (point)))) + ;; 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)) + (1- (point))) + (point))))) ) ;; Only do argument checking if the paren was immediately after @@ -295,8 +318,10 @@ Moves completely over balanced #if blocks." (cond ((looking-at "^\\s-*#\\s-*if") ;; We found a nested if. Skip it. - ;; @TODO - can we use the new c-scan-conditionals - (c-forward-conditional 1)) + (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) @@ -315,34 +340,207 @@ Moves completely over balanced #if blocks." ;; 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. +Pulls 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 + (point-at-bol) (point-at-eol))) + (point-at-bol) (point-at-eol)) + 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\\|ifndef\\|ifdef\\|elif\\)\\s-+\\(!?defined(\\|\\)\\s-*\\(\\(\\sw\\|\\s_\\)+\\)\\(\\s-*)\\)?\\s-*$" + "^\\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) + (error nil)))) + + (let ((eval-form (eval parsedtokelist))) + (if (or (not eval-form) + (and (numberp eval-form) + (equal eval-form 0)));; ifdefline 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 (point-at-bol) (point-at-eol))) + (point-at-bol) (point-at-eol)) + (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_\\)+\\)$" + (semantic-c-do-lex-ifdef)) + +(defun semantic-c-do-lex-ifdef () "Handle lexical CPP if statements." (let* ((sym (buffer-substring-no-properties - (match-beginning 3) (match-end 3))) - (defstr (buffer-substring-no-properties - (match-beginning 2) (match-end 2))) - (defined (string= defstr "defined(")) - (notdefined (string= defstr "!defined(")) + (match-beginning 2) (match-end 2))) (ift (buffer-substring-no-properties (match-beginning 1) (match-end 1))) - (ifdef (or (string= ift "ifdef") - (and (string= ift "if") defined) - (and (string= ift "elif") defined) - )) - (ifndef (or (string= ift "ifndef") - (and (string= ift "if") notdefined) - (and (string= ift "elif") notdefined) - )) + (ifdef (string= ift "ifdef")) + (ifndef (string= ift "ifndef")) ) - (if (or (and (or (string= ift "if") (string= ift "elif")) - (string= sym "0")) - (and ifdef (not (semantic-lex-spp-symbol-p sym))) + (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)) @@ -556,6 +754,7 @@ 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 @@ -724,14 +923,16 @@ the regular parser." ;; Hack in mode-local (activate-mode-local-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-hooks 'semantic-lex-spp-reset-hook - t) + (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) @@ -800,51 +1001,18 @@ now. ) ;; Expand an EXTERN C first. (when (eq (semantic-tag-class tag) 'extern) - (let* ((mb (semantic-tag-get-attribute tag :members)) - (ret mb)) - (while mb - (let ((mods (semantic-tag-get-attribute (car mb) :typemodifiers))) - (setq mods (cons "extern" (cons "\"C\"" mods))) - (semantic-tag-put-attribute (car mb) :typemodifiers mods)) - (setq mb (cdr mb))) - (setq return-list ret))) + (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)) - ;; Function or variables that have a :type that is some complex - ;; thing, extract it, and replace it with a reference. - ;; - ;; Thus, struct A { int a; } B; - ;; - ;; will create 2 toplevel tags, one is type A, and the other variable B - ;; where the :type of B is just a type tag A that is a prototype, and - ;; the actual struct info of A is its own toplevel tag. + ;; Check if we have a complex type (when (or (semantic-tag-of-class-p tag 'function) (semantic-tag-of-class-p tag 'variable)) - (let* ((basetype (semantic-tag-type tag)) - (typeref nil) - (tname (when (consp basetype) - (semantic-tag-name basetype)))) - ;; Make tname be a string. - (when (consp tname) (setq tname (car (car tname)))) - ;; Is the basetype a full type with a name of its own? - (when (and basetype (semantic-tag-p basetype) - (not (semantic-tag-prototype-p basetype)) - tname - (not (string= tname ""))) - ;; a type tag referencing the type we are extracting. - (setq typeref (semantic-tag-new-type - (semantic-tag-name basetype) - (semantic-tag-type basetype) - nil nil - :prototype t)) - ;; Convert original tag to only have a reference. - (setq tag (semantic-tag-copy tag)) - (semantic-tag-put-attribute tag :type typeref) - ;; Convert basetype to have the location information. - (semantic--tag-copy-properties tag basetype) - (semantic--tag-set-overlay basetype - (semantic-tag-overlay tag)) - ;; Store the base tag as part of the return list. - (setq return-list (cons basetype return-list))))) + (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; @@ -865,13 +1033,63 @@ now. ;; If we didn't have a list, but the return-list is non-empty, ;; that means we still need to take our existing tag, and glom ;; it onto our extracted type. - (if (consp return-list) + (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) @@ -1238,6 +1456,22 @@ Override function for `semantic-tag-protection'." '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) @@ -1342,7 +1576,7 @@ SCOPE is not used, and TYPE-DECLARATION is used only if TYPE is not a typedef." (string= (semantic-tag-type type) "typedef")) (let ((dt (semantic-tag-get-attribute type :typedef))) (cond ((and (semantic-tag-p dt) - (not (semantic-analyze-tag-prototype-p dt))) + (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)) @@ -1656,6 +1890,58 @@ For types with a :parent, create faux namespaces to put TAG into." ;; 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 prefix parenttable newtable) + (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 "include with context")) + (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)) @@ -1693,6 +1979,52 @@ For types with a :parent, create faux namespaces to put TAG into." 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.") @@ -1725,6 +2057,12 @@ For types with a :parent, create faux namespaces to put TAG into." (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." @@ -1735,7 +2073,9 @@ For types with a :parent, create faux namespaces to put TAG into." ) (setq semantic-lex-analyzer #'semantic-c-lexer) - (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t) + (add-hook 'semantic-lex-reset-functions 'semantic-lex-spp-reset-hook nil t) + (when (eq major-mode 'c++-mode) + (add-to-list 'semantic-lex-c-preprocessor-symbol-map '("__cplusplus" . ""))) ) ;;;###autoload @@ -1759,7 +2099,7 @@ For types with a :parent, create faux namespaces to put TAG into." (defun semantic-c-describe-environment () "Describe the Semantic features of the current C environment." (interactive) - (if (not (or (eq major-mode 'c-mode) (eq major-mode 'c++-mode))) + (if (not (member 'c-mode (mode-local-equivalent-mode-p major-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)) @@ -1780,13 +2120,20 @@ For types with a :parent, create faux namespaces to put TAG into." (princ "\n\nInclude Path Summary:\n") (when (and (boundp 'ede-object) ede-object) (princ "\n This file's project include is handled by:\n") - (princ " ") - (princ (object-print ede-object)) - (princ "\n with the system path:\n") - (dolist (dir (ede-system-include-path ede-object)) - (princ " ") - (princ dir) - (princ "\n")) + (let ((objs (if (listp ede-object) + ede-object + (list ede-object)))) + (dolist (O objs) + (princ " EDE : ") + (princ (object-print O)) + (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 diff --git a/lisp/cedet/semantic/bovine/el.el b/lisp/cedet/semantic/bovine/el.el index 818b8b581a4..ea99df9edb9 100644 --- a/lisp/cedet/semantic/bovine/el.el +++ b/lisp/cedet/semantic/bovine/el.el @@ -956,7 +956,7 @@ ELisp variables can be pretty long, so track this one too.") ;; (add-hook 'lisp-mode-hook 'semantic-default-elisp-setup) -(eval-after-load "semanticdb" +(eval-after-load "semantic/db" '(require 'semantic/db-el) ) diff --git a/lisp/cedet/semantic/bovine/gcc.el b/lisp/cedet/semantic/bovine/gcc.el index 8b47ae14eee..842ef0914fd 100644 --- a/lisp/cedet/semantic/bovine/gcc.el +++ b/lisp/cedet/semantic/bovine/gcc.el @@ -33,30 +33,32 @@ ;;; Code: (defun semantic-gcc-query (gcc-cmd &rest gcc-options) - "Return program output to both standard output and standard error. + "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"))) + (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 - (apply 'call-process gcc-cmd nil (cons buff t) nil gcc-options) + (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 - (apply 'call-process gcc-cmd nil (cons buff t) nil gcc-options) + (setq err (apply 'call-process gcc-cmd options)) (error ;; gcc doesn't exist??? nil))))) (setenv "LC_ALL" old-lc-messages) (prog1 - (buffer-string) - (kill-buffer buff) - ) - ))) + (if (zerop err) + (buffer-string) + err) + (kill-buffer buff))))) ;;(semantic-gcc-get-include-paths "c") ;;(semantic-gcc-get-include-paths "c++") @@ -148,7 +150,14 @@ It should also include other symbols GCC was compiled with.") (interactive) (let* ((fields (or semantic-gcc-setup-data (semantic-gcc-fields (semantic-gcc-query "gcc" "-v")))) - (defines (semantic-cpp-defs (semantic-gcc-query "cpp" "-E" "-dM" "-x" "c++" null-device))) + (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 (semantic-cpp-defs query)) (ver (cdr (assoc 'version fields))) (host (or (cdr (assoc 'target fields)) (cdr (assoc '--target fields)) @@ -156,13 +165,14 @@ It should also include other symbols GCC was compiled with.") (prefix (cdr (assoc '--prefix fields))) ;; gcc output supplied paths (c-include-path (semantic-gcc-get-include-paths "c")) - (c++-include-path (semantic-gcc-get-include-paths "c++"))) + (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) - (unless c-include-path + (when (and (not c-include-path) gcc-exe) ;; Fallback to guesses (let* ( ;; gcc include dirs - (gcc-exe (locate-file "gcc" exec-path exec-suffixes 'executable)) (gcc-root (expand-file-name ".." (file-name-directory gcc-exe))) (gcc-include (expand-file-name "include" gcc-root)) (gcc-include-c++ (expand-file-name "c++" gcc-include)) @@ -196,20 +206,24 @@ It should also include other symbols GCC was compiled with.") (semantic-add-system-include D 'c-mode)) (dolist (D (semantic-gcc-get-include-paths "c++")) (semantic-add-system-include D 'c++-mode) - (let ((cppconfig (concat D "/bits/c++config.h"))) - ;; Presumably there will be only one of these files in the try-paths list... - (when (file-readable-p cppconfig) + (let ((cppconfig (list (concat D "/bits/c++config.h") (concat D "/sys/cdefs.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 cppconfig) + (add-to-list 'semantic-lex-c-preprocessor-symbol-file cur) ;; Setup the core macro header - (setq semantic-lex-c-preprocessor-symbol-file (list cppconfig))) - ))) + (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 OS X 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)) diff --git a/lisp/cedet/semantic/bovine/grammar.el b/lisp/cedet/semantic/bovine/grammar.el new file mode 100644 index 00000000000..cc27c5b0646 --- /dev/null +++ b/lisp/cedet/semantic/bovine/grammar.el @@ -0,0 +1,506 @@ +;;; semantic/bovine/grammar.el --- Bovine's input grammar mode +;; +;; Copyright (C) 2002-2012 Free Software Foundation, Inc. +;; +;; Author: David Ponce <david@dponce.com> +;; Maintainer: 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Major mode for editing Bovine's input grammar (.by) files. + +;;; History: + +;;; 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 (>= emacs-major-version 24) + (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)") + ;; 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"))) +) + +(defun bovine-grammar-parsetable-builder () + "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-setupcode-builder () + "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-flex-keywords-obarray %s\n\ + %s)" + (semantic-grammar-parsetable) + (buffer-name) + (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) + (semantic-install-function-overrides + '((grammar-parsetable-builder . bovine-grammar-parsetable-builder) + (grammar-setupcode-builder . bovine-grammar-setupcode-builder)))) + +(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-parsers () + "Generate Emacs' 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\\'")) + (let ((packagename + (condition-case err + (with-current-buffer (find-file-noselect f) + (semantic-grammar-create-package)) + (error (message "%s" (error-message-string err)) nil))) + lang filename) + (when (and packagename + (string-match "^.*/\\(.*\\)-by\\.el\\'" packagename)) + (setq lang (match-string 1 packagename)) + (setq filename (concat lang "-by.el")) + (with-temp-buffer + (insert-file-contents filename) + (setq buffer-file-name (expand-file-name 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 <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file was generated from admin/grammars/" + lang ".by. + +;;; Code: +") + (goto-char (point-min)) + (delete-region (point-min) (line-end-position)) + (insert ";;; " packagename + " --- Generated parser support file") + (delete-trailing-whitespace) + (re-search-forward ";;; \\(.*\\) ends here") + (replace-match packagename nil nil nil 1) + (save-buffer)))))) + +(provide 'semantic/bovine/grammar) + +;;; semantic/bovine/grammar.el ends here diff --git a/lisp/cedet/semantic/bovine/make-by.el b/lisp/cedet/semantic/bovine/make-by.el index ac38d1707c3..59738188bbe 100644 --- a/lisp/cedet/semantic/bovine/make-by.el +++ b/lisp/cedet/semantic/bovine/make-by.el @@ -19,13 +19,12 @@ ;;; Commentary: ;; -;; This file was generated from etc/grammars/make.by. +;; This file was generated from admin/grammars/make.by. ;;; Code: (require 'semantic/lex) (eval-when-compile (require 'semantic/bovine)) - ;;; Prologue ;; @@ -380,6 +379,13 @@ semantic-flex-keywords-obarray semantic-make-by--keyword-table )) + +;;; Analyzers +;; + +;;; Epilogue +;; + (provide 'semantic/bovine/make-by) ;;; semantic/bovine/make-by.el ends here diff --git a/lisp/cedet/semantic/bovine/make.el b/lisp/cedet/semantic/bovine/make.el index 4098b2c0374..041e1f11902 100644 --- a/lisp/cedet/semantic/bovine/make.el +++ b/lisp/cedet/semantic/bovine/make.el @@ -27,6 +27,7 @@ (require 'make-mode) (require 'semantic) +(require 'semantic/bovine) (require 'semantic/bovine/make-by) (require 'semantic/analyze) (require 'semantic/dep) diff --git a/lisp/cedet/semantic/bovine/scm-by.el b/lisp/cedet/semantic/bovine/scm-by.el index d580a5fb22e..476945fa8a3 100644 --- a/lisp/cedet/semantic/bovine/scm-by.el +++ b/lisp/cedet/semantic/bovine/scm-by.el @@ -1,4 +1,4 @@ -;;; semantic-scm-by.el --- Generated parser support file +;;; semantic/bovine/scm-by.el --- Generated parser support file ;; Copyright (C) 2001, 2003, 2009-2012 Free Software Foundation, Inc. @@ -19,12 +19,11 @@ ;;; Commentary: ;; -;; This file was generated from etc/grammars/scm.by. +;; This file was generated from admin/grammars/scm.by. ;;; Code: (require 'semantic/lex) - (eval-when-compile (require 'semantic/bovine)) ;;; Prologue @@ -185,6 +184,13 @@ semantic-flex-keywords-obarray semantic-scm-by--keyword-table )) + +;;; Analyzers +;; + +;;; Epilogue +;; + (provide 'semantic/bovine/scm-by) ;;; semantic/bovine/scm-by.el ends here diff --git a/lisp/cedet/semantic/bovine/scm.el b/lisp/cedet/semantic/bovine/scm.el index 5c4e2ae6d60..cf2b1f0e212 100644 --- a/lisp/cedet/semantic/bovine/scm.el +++ b/lisp/cedet/semantic/bovine/scm.el @@ -24,6 +24,7 @@ ;; Use the Semantic Bovinator for Scheme (guile) (require 'semantic) +(require 'semantic/bovine) (require 'semantic/bovine/scm-by) (require 'semantic/format) (require 'semantic/dep) @@ -37,7 +38,7 @@ 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) +(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)) @@ -46,7 +47,7 @@ actually on the local machine.") (concat (semantic-tag-name tag) " (" (mapconcat (lambda (a) a) args " ") ")") - (semantic-format-tag-prototype-default tag)))) + (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. diff --git a/lisp/cedet/semantic/chart.el b/lisp/cedet/semantic/chart.el index c6b13475862..2c6f7344acf 100644 --- a/lisp/cedet/semantic/chart.el +++ b/lisp/cedet/semantic/chart.el @@ -26,12 +26,9 @@ ;; the output of the semantic parser. ;; -(require 'semantic) (require 'chart) (require 'semantic/db) -(require 'semantic/tag) - -(eval-when-compile (require 'semantic/find)) +(require 'semantic/find) ;;; Code: diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 18d4052eb43..59d17f2f8bb 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -113,6 +113,7 @@ (require 'semantic/ctxt) (require 'semantic/decorate) (require 'semantic/format) +(require 'semantic/idle) (eval-when-compile ;; For the semantic-find-tags-for-completion macro. @@ -685,7 +686,7 @@ a reasonable distance." (cond ;; EXIT when we are no longer in a good place. ((or (not (eq b (current-buffer))) - (< (point) s) + (<= (point) s) (> (point) e)) ;;(message "Exit: %S %S %S" s e (point)) (semantic-complete-inline-exit) @@ -904,13 +905,44 @@ a completion displayor 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.") + +(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))))) + (defmethod semantic-collector-cleanup ((obj semantic-collector-abstract)) "Clean up any mess this collector may have." nil) (defmethod semantic-collector-next-action ((obj semantic-collector-abstract) partial) - "What should we do next? OBJ can predict a next good action. + "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))) @@ -966,21 +998,38 @@ Output must be in semanticdb Find result format." "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 - (if (or same-prefix-p - (and (slot-boundp obj 'last-prefix) - (eq (compare-strings (oref obj last-prefix) 0 nil - prefix 0 (length prefix)) - t))) - ;; New prefix is subset of old prefix - (oref obj last-all-completions) - (semantic-collector-get-cache obj))) + (cond ((or same-prefix-p + (and last-prefix (eq (compare-strings + last-prefix 0 nil + prefix 0 (length last-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 re-use cache. + (oref obj last-all-completions)) + ((and last-prefix + (> (length prefix) 1) + (eq (compare-strings + prefix 0 nil + last-prefix 0 (length 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)) - ) + obj prefix completionlist))) (completion nil) (complete-not-uniq nil) ) @@ -1153,7 +1202,7 @@ NEWCACHE is the new tag table, but we ignore it." (semantic-collector-buffer-abstract) () "Completion engine for tags in the current buffer. -When searching for a tag, uses semantic deep searche functions. +When searching for a tag, uses semantic deep search functions. Basics search only in the current buffer.") (defmethod semantic-collector-calculate-cache @@ -1225,37 +1274,6 @@ Uses semanticdb for searching all tags in the current project." (semantic-find-tags-for-completion prefix localstuff))))) ;(semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path)))) -;;; 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.") - -(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))))) - ;;; ------------------------------------------------------------ ;;; Tag List Display Engines @@ -1300,8 +1318,9 @@ a collector, and tracking tables of completion to display." (defmethod semantic-displayor-next-action ((obj semantic-displayor-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)) + (or (eq this-command 'semantic-complete-inline-TAB) + (and (string= (oref obj last-prefix) (semantic-completion-text)) + (eq last-command this-command)))) 'scroll 'display)) @@ -1477,7 +1496,7 @@ one in the source buffer." (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. @@ -1502,17 +1521,14 @@ one in the source buffer." (switch-to-buffer-other-window buf t) (select-window (get-buffer-window buf))) ;; Now do some positioning - (unwind-protect - (if (semantic-tag-with-position-p tag) - ;; Full tag positional information available - (progn - (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 (minibuffer-window))) + (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)) @@ -1530,32 +1546,66 @@ one in the source buffer." ;; * Safe compatibility for tooltip free systems. ;; * Don't use 'avoid package for tooltip positioning. +;;;###autoload +(defcustom semantic-displayor-tooltip-mode 'standard + "Mode for the tooltip inline completion. + +Standard: Show only `semantic-displayor-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-displayor-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-displayor-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-displayor-tooltip-initial-max-tags 5 + "Maximum number of tags to be displayed initially. +See doc-string of `semantic-displayor-tooltip-mode' for details." + :group 'semantic + :version "24.3" + :type 'integer) + +(defcustom semantic-displayor-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) + (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size)))))) + + (defclass semantic-displayor-tooltip (semantic-displayor-traditional) - ((max-tags :type integer - :initarg :max-tags - :initform 5 - :custom integer - :documentation - "Max number of tags displayed on tooltip at once. -If `force-show' is 1, this value is ignored with typing tab or space twice continuously. -if `force-show' is 0, this value is always ignored.") - (force-show :type integer - :initarg :force-show - :initform 1 - :custom (choice (const - :tag "Show when double typing" - 1) - (const - :tag "Show always" - 0) - (const - :tag "Show if the number of tags is less than `max-tags'." - -1)) - :documentation - "Control the behavior of the number of tags is greater than `max-tags'. --1 means tags are never shown. -0 means the tags are always shown. -1 means tags are shown if space or tab is typed twice continuously.") + ((mode :initarg :mode + :initform + (symbol-value 'semantic-displayor-tooltip-mode) + :documentation + "See `semantic-displayor-tooltip-mode'.") + (max-tags-initial :initarg max-tags-initial + :initform + (symbol-value 'semantic-displayor-tooltip-initial-max-tags) + :documentation + "See `semantic-displayor-tooltip-initial-max-tags'.") (typing-count :type integer :initform 0 :documentation @@ -1563,7 +1613,7 @@ if `force-show' is 0, this value is always ignored.") (shown :type boolean :initform nil :documentation - "Flag representing whether tags is shown once or not.") + "Flag representing whether tooltip has been shown yet.") ) "Display completions options in a tooltip. Display mechanism using tooltip for a list of possible completions.") @@ -1583,50 +1633,63 @@ Display mechanism using tooltip for a list of possible completions.") (call-next-method) (let* ((tablelong (semanticdb-strip-find-results (oref obj table))) (table (semantic-unique-tag-table-by-name tablelong)) - (l (mapcar semantic-completion-displayor-format-tag-function table)) - (ll (length l)) + (completions (mapcar semantic-completion-displayor-format-tag-function table)) + (numcompl (length completions)) (typing-count (oref obj typing-count)) - (force-show (oref obj force-show)) + (mode (oref obj mode)) + (max-tags (oref obj max-tags-initial)) (matchtxt (semantic-completion-text)) - msg) - (if (or (oref obj shown) - (< ll (oref obj max-tags)) - (and (<= 0 force-show) - (< (1- force-show) typing-count))) - (progn - (oset obj typing-count 0) - (oset obj shown t) - (if (eq 1 ll) - ;; We Have only one possible match. There could be two cases. - ;; 1) input text != single match. - ;; --> Show it! - ;; 2) input text == single match. - ;; --> Complain about it, but still show the match. - (if (string= matchtxt (semantic-tag-name (car table))) - (setq msg (concat "[COMPLETE]\n" (car l))) - (setq msg (car l))) - ;; Create the long message. - (setq msg (mapconcat 'identity l "\n")) - ;; If there is nothing, say so! - (if (eq 0 (length msg)) - (setq msg "[NO MATCH]"))) - (semantic-displayor-tooltip-show msg)) - ;; The typing count determines if the user REALLY REALLY - ;; wanted to show that much stuff. Only increment - ;; if the current command is a completion command. - (if (and (stringp (this-command-keys)) - (string= (this-command-keys) "\C-i")) - (oset obj typing-count (1+ typing-count))) - ;; At this point, we know we have too many items. - ;; Let's be brave, and truncate l - (setcdr (nthcdr (oref obj max-tags) l) nil) - (setq msg (mapconcat 'identity l "\n")) + msg msg-tail) + ;; Keep a count of the consecutive completion commands entered by the user. + (if (and (stringp (this-command-keys)) + (string= (this-command-keys) "\C-i")) + (oset obj typing-count (1+ (oref obj typing-count))) + (oset 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 semantic-displayor-tooltip-max-tags) + (setq max-tags semantic-displayor-tooltip-max-tags))) + (unless msg + (oset obj shown t) (cond - ((= force-show -1) - (semantic-displayor-tooltip-show (concat msg "\n..."))) - ((= force-show 1) - (semantic-displayor-tooltip-show (concat msg "\n(TAB for more)"))) - ))))) + ((> numcompl max-tags) + ;; We have too many items, be brave and truncate 'completions'. + (setcdr (nthcdr (1- max-tags) completions) nil) + (if (= max-tags semantic-displayor-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 (eq msg "")) + (semantic-displayor-tooltip-show msg))))) ;;; Compatibility ;; @@ -1644,8 +1707,10 @@ Display mechanism using tooltip for a list of possible completions.") "Return the location of POINT as positioned on the selected frame. Return a cons cell (X . Y)" (let* ((frame (selected-frame)) - (left (frame-parameter frame 'left)) - (top (frame-parameter frame 'top)) + (left (or (car-safe (cdr-safe (frame-parameter frame 'left))) + (frame-parameter frame 'left))) + (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) @@ -1668,7 +1733,7 @@ Return a cons cell (X . Y)" (defmethod semantic-displayor-scroll-request ((obj semantic-displayor-tooltip)) "A request to for the displayor to scroll the completion list (if needed)." ;; Do scrolling in the tooltip. - (oset obj max-tags 30) + (oset obj max-tags-initial 30) (semantic-displayor-show-request obj) ) @@ -2023,6 +2088,7 @@ completion works." (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) @@ -2036,6 +2102,7 @@ completion works." (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) @@ -2050,6 +2117,7 @@ completion works." (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) @@ -2151,6 +2219,23 @@ use `semantic-complete-analyze-inline' to complete." (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: diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el index 23410b1eb1b..dbb3bfae34d 100644 --- a/lisp/cedet/semantic/db-el.el +++ b/lisp/cedet/semantic/db-el.el @@ -31,14 +31,10 @@ ;; (require 'semantic/db) - -(eval-when-compile - ;; For generic function searching. - (require 'eieio) - (require 'eieio-opt) - (require 'eieio-base)) +(require 'eieio-opt) (declare-function semantic-elisp-desymbolify "semantic/bovine/el") +(declare-function semantic-tag-similar-p "semantic/tag-ls") ;;; Code: @@ -57,6 +53,11 @@ It does not need refreshing." "Return nil, we never need a refresh." nil) +(defmethod object-print ((obj semanticdb-table-emacs-lisp) &rest strings) + "Pretty printer extension for `semanticdb-table-emacs-lisp'. +Adds the number of tags in this file to the object print name." + (apply 'call-next-method obj (cons " (proxy)" strings))) + (defclass semanticdb-project-database-emacs-lisp (semanticdb-project-database eieio-singleton) ((new-table-class :initform semanticdb-table-emacs-lisp @@ -66,6 +67,15 @@ It does not need refreshing." ) "Database representing Emacs core.") +(defmethod object-print ((obj semanticdb-project-database-emacs-lisp) &rest strings) + "Pretty printer extension for `semanticdb-table-emacs-lisp'. +Adds the number of tags in this file to the object print name." + (let ((count 0)) + (mapatoms (lambda (sym) (setq count (1+ count)))) + (apply 'call-next-method obj (cons + (format " (%d known syms)" count) + strings)))) + ;; Create the database, and add it to searchable databases for Emacs Lisp mode. (defvar-mode-local emacs-lisp-mode semanticdb-project-system-databases (list @@ -159,9 +169,9 @@ If Emacs cannot resolve this symbol to a particular file, then return nil." (setq file (concat file ".gz")))) (let* ((tab (semanticdb-file-table-object file)) - (alltags (semanticdb-get-tags tab)) - (newtags (semanticdb-find-tags-by-name-method - tab (semantic-tag-name tag))) + (alltags (when tab (semanticdb-get-tags tab))) + (newtags (when tab (semanticdb-find-tags-by-name-method + tab (semantic-tag-name tag)))) (match nil)) ;; Find the best match. (dolist (T newtags) @@ -171,32 +181,12 @@ If Emacs cannot resolve this symbol to a particular file, then return nil." (when (not match) (setq match (car newtags))) ;; Return it. - (cons tab match))))) - -(defun semanticdb-elisp-sym-function-arglist (sym) - "Get the argument list for SYM. -Deal with all different forms of function. -This was snarfed out of eldoc." - (let* ((prelim-def - (let ((sd (and (fboundp sym) - (symbol-function sym)))) - (and (symbolp sd) - (condition-case err - (setq sd (indirect-function sym)) - (error (setq sd nil)))) - sd)) - (def (if (eq (car-safe prelim-def) 'macro) - (cdr prelim-def) - prelim-def)) - (arglist (cond ((null def) nil) - ((byte-code-function-p def) - ;; This is an eieio compatibility function. - ;; We depend on EIEIO, so use this. - (eieio-compiled-function-arglist def)) - ((eq (car-safe def) 'lambda) - (nth 1 def)) - (t nil)))) - arglist)) + (when tab (cons tab match)))))) + +(autoload 'help-function-arglist "help-fns") +(defalias 'semanticdb-elisp-sym-function-arglist 'help-function-arglist) +(make-obsolete 'semanticdb-elisp-sym-function-arglist + 'help-function-arglist "CEDET 1.1") (defun semanticdb-elisp-sym->tag (sym &optional toktype) "Convert SYM into a semantic tag. @@ -210,7 +200,7 @@ TOKTYPE is a hint to the type of tag desired." (symbol-name sym) nil ;; return type (semantic-elisp-desymbolify - (semanticdb-elisp-sym-function-arglist sym)) ;; arg-list + (help-function-arglist sym)) ;; arg-list :user-visible-flag (condition-case nil (interactive-form sym) (error nil)) diff --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el index c487e39c7b2..905c62a89dd 100644 --- a/lisp/cedet/semantic/db-file.el +++ b/lisp/cedet/semantic/db-file.el @@ -25,9 +25,9 @@ ;; A set of semanticdb classes for persistently saving caches on disk. ;; -(require 'semantic) (require 'semantic/db) (require 'cedet-files) +(require 'data-debug) (defvar semanticdb-file-version semantic-version "Version of semanticdb we are writing files to disk with.") @@ -67,7 +67,9 @@ passes a list of predicates in `semanticdb-project-predicate-functions'." :group 'semanticdb :type nil) -(defcustom semanticdb-save-database-hooks nil +(define-obsolete-variable-alias 'semanticdb-save-database-hooks + 'semanticdb-save-database-functions "24.3") +(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." @@ -140,7 +142,7 @@ If DIRECTORY doesn't exist, create a new one." directory)) "/") :file fn :tables nil - :semantic-tag-version semantic-version + :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. @@ -154,7 +156,7 @@ If DIRECTORY doesn't exist, create a new one." (defun semanticdb-load-database (filename) "Load the database FILENAME." (condition-case foo - (let* ((r (eieio-persistent-read filename)) + (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)) @@ -248,7 +250,7 @@ If DB is not specified, then use the current database." (message "Save Error: %S: %s" (car (cdr foo)) objname) (error "%S" (car (cdr foo)))))))) - (run-hook-with-args 'semanticdb-save-database-hooks + (run-hook-with-args 'semanticdb-save-database-functions (or DB semanticdb-current-database)) ;;(message "Saving tag summary for %s...done" objname) ) diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el index 15ef3b09238..d42ecf7c4fc 100644 --- a/lisp/cedet/semantic/db-find.el +++ b/lisp/cedet/semantic/db-find.el @@ -123,6 +123,7 @@ (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") @@ -167,6 +168,8 @@ the following keys: :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) @@ -879,8 +882,9 @@ instead." ;; Find-file-match allows a tool to make sure the tag is ;; 'live', somewhere in a buffer. (cond ((eq find-file-match 'name) - (let ((f (semanticdb-full-filename nametable))) - (semantic--tag-put-property ntag :filename f))) + (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)) ) @@ -1322,7 +1326,12 @@ Returns a table of all matching 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." - (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table)))) + ;; 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 (semanticdb-get-tags table))) + (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table))))) (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. diff --git a/lisp/cedet/semantic/db-global.el b/lisp/cedet/semantic/db-global.el index eceb830341f..a7bb130810e 100644 --- a/lisp/cedet/semantic/db-global.el +++ b/lisp/cedet/semantic/db-global.el @@ -40,10 +40,17 @@ ;;; Code: ;;;###autoload -(defun semanticdb-enable-gnu-global-databases (mode) +(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." +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 signalled 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 @@ -51,17 +58,18 @@ in a GNU Global supported hierarchy." t (symbol-name major-mode)))) ;; First, make sure the version is ok. - (cedet-gnu-global-version-check) - - ;; Make sure mode is a symbol. - (when (stringp mode) - (setq mode (intern mode))) - - (let ((ih (mode-local-value mode 'semantic-init-mode-hook))) - (eval `(setq-mode-local - ,mode semantic-init-mode-hook - (cons 'semanticdb-enable-gnu-global-hook ih)))) - + (if (not (cedet-gnu-global-version-check noerror)) + nil + ;; Make sure mode is a symbol. + (when (stringp mode) + (setq mode (intern mode))) + + (let ((ih (mode-local-value mode 'semantic-init-mode-hook))) + (eval `(setq-mode-local + ,mode semantic-init-mode-hook + (cons 'semanticdb-enable-gnu-global-hook ih)))) + t + ) ) (defun semanticdb-enable-gnu-global-hook () @@ -72,6 +80,8 @@ MODE is the major mode to support." (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.") @@ -102,6 +112,11 @@ if optional DONT-ERR-IF-NOT-AVAILABLE is non-nil; else throw an error." ) "A table for returning search results from GNU Global.") +(defmethod object-print ((obj semanticdb-table-global) &rest strings) + "Pretty printer extension for `semanticdb-table-global'. +Adds the number of tags in this file to the object print name." + (apply 'call-next-method obj (cons " (proxy)" strings))) + (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' diff --git a/lisp/cedet/semantic/db-typecache.el b/lisp/cedet/semantic/db-typecache.el index 4698949b5e0..0da98a6d357 100644 --- a/lisp/cedet/semantic/db-typecache.el +++ b/lisp/cedet/semantic/db-typecache.el @@ -483,6 +483,11 @@ found tag to be loaded." (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. @@ -577,7 +582,11 @@ If there isn't one, create it. (interactive) (let* ((path (semanticdb-find-translate-path nil nil))) (dolist (P path) - (oset P pointmax nil) + (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 () diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el index 4e09f9fc3f2..afac974d7fb 100644 --- a/lisp/cedet/semantic/db.el +++ b/lisp/cedet/semantic/db.el @@ -33,8 +33,15 @@ (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." @@ -80,6 +87,11 @@ same major mode as the current buffer.") :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 refering 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 @@ -148,13 +160,16 @@ them to convert TAG into a more complete form." (cons obj tag)) (defmethod object-print ((obj semanticdb-abstract-table) &rest strings) - "Pretty printer extension for `semanticdb-table'. + "Pretty printer extension for `semanticdb-abstract-table'. Adds the number of tags in this file to the object print name." - (apply 'call-next-method obj - (cons (format " (%d tags)" - (length (semanticdb-get-tags obj)) - ) - strings))) + (if (or (not strings) + (and (= (length strings) 1) (stringp (car strings)) + (string= (car strings) ""))) + ;; Else, add a tags quantifier. + (call-next-method obj (format " (%d tags)" (length (semanticdb-get-tags obj)))) + ;; Pass through. + (apply 'call-next-method obj strings) + )) ;;; Index Cache ;; @@ -201,8 +216,7 @@ If one doesn't exist, create it." ;; 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.") @@ -299,7 +313,8 @@ If OBJ's file is not loaded, read it in first." "Pretty printer extension for `semanticdb-table'. Adds the number of tags in this file to the object print name." (apply 'call-next-method obj - (cons (if (oref obj dirty) ", DIRTY" "") strings))) + (cons (format " (%d tags)" (length (semanticdb-get-tags obj))) + (cons (if (oref obj dirty) ", DIRTY" "") strings)))) ;;; DATABASE BASE CLASS ;; @@ -324,7 +339,7 @@ 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 list + :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 @@ -416,7 +431,7 @@ 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 filename)) + (dd (file-name-directory (file-truename filename))) ) ;; Allow a database override function (setq cdb (semanticdb-create-database semanticdb-new-database-class @@ -555,7 +570,7 @@ This will call `semantic-fetch-tags' if that file is in memory." ;; semanticdb-create-table-for-file-not-in-buffer (save-excursion (let ((buff (semantic-find-file-noselect - (semanticdb-full-filename obj)))) + (semanticdb-full-filename obj) t))) (set-buffer buff) (semantic-fetch-tags) ;; Kill off the buffer if it didn't exist when we were called. @@ -620,7 +635,7 @@ The file associated with OBJ does not need to be in a buffer." ) ;; Update cross references - ;; (semanticdb-refresh-references table) + (semanticdb-refresh-references table) ) (defmethod semanticdb-partial-synchronize ((table semanticdb-abstract-table) @@ -650,8 +665,8 @@ The file associated with OBJ does not need to be in a buffer." ) ;; Update cross references - ;;(when (semantic-find-tags-by-class 'include new-tags) - ;; (semanticdb-refresh-references table)) + (when (semantic-find-tags-by-class 'include new-tags) + (semanticdb-refresh-references table)) ) ;;; SAVE/LOAD @@ -667,9 +682,11 @@ form." (defun semanticdb-save-current-db () "Save the current tag database." (interactive) - (message "Saving current tag summaries...") + (unless noninteractive + (message "Saving current tag summaries...")) (semanticdb-save-db semanticdb-current-database) - (message "Saving current tag summaries...done")) + (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. @@ -678,10 +695,12 @@ form." (defun semanticdb-save-all-db () "Save all semantic tag databases." (interactive) - (message "Saving tag summaries...") + (unless noninteractive + (message "Saving tag summaries...")) (let ((semanticdb--inhibit-make-directory nil)) (mapc 'semanticdb-save-db semanticdb-database-list)) - (message "Saving tag summaries...done")) + (unless noninteractive + (message "Saving tag summaries...done"))) (defun semanticdb-save-all-db-idle () "Save all semantic tag databases from idle time. diff --git a/lisp/cedet/semantic/debug.el b/lisp/cedet/semantic/debug.el index e88517b15ce..3c0bf877728 100644 --- a/lisp/cedet/semantic/debug.el +++ b/lisp/cedet/semantic/debug.el @@ -308,13 +308,13 @@ Argument ONOFF is non-nil when we are entering debug mode. ;; Install our map onto this buffer (use-local-map semantic-debug-mode-map) ;; Make the buffer read only - (toggle-read-only 1) + (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 - (toggle-read-only 1) + (setq buffer-read-only t) ;; Hooks (run-hooks 'semantic-debug-mode-hook) ) diff --git a/lisp/cedet/semantic/decorate/include.el b/lisp/cedet/semantic/decorate/include.el index 50b50398e16..0c2c5e3ce37 100644 --- a/lisp/cedet/semantic/decorate/include.el +++ b/lisp/cedet/semantic/decorate/include.el @@ -175,6 +175,69 @@ Used by the decoration style: `semantic-decoration-on-unknown-includes'." :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-decoratiton-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" + (semantic-menu-item + ["What Is This?" semantic-decoration-fileless-include-describe + :active t + :help "Describe why this include has been marked this way." ]) + (semantic-menu-item + ["List all unknown includes" semanticdb-find-adebug-lost-includes + :active t + :help "Show a list of all includes semantic cannot find for this file." ]) + "---" + (semantic-menu-item + ["Summarize includes current buffer" semantic-decoration-all-include-summary + :active t + :help "Show a summary for the current buffer containing this include." ]) + (semantic-menu-item + ["List found includes (load unparsed)" semanticdb-find-test-translate-path + :active t + :help "List all includes found for this file, and parse unparsed files." ]) + (semantic-menu-item + ["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." ]) + "---" + (semantic-menu-item + ["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." ]) + (semantic-menu-item + ["Add a System Include Path" semantic-add-system-include + :active t + :help "Add an include path for this session." ]) + (semantic-menu-item + ["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 @@ -272,17 +335,22 @@ This mode provides a nice context menu on the include statements." (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)) - (table (when file - (semanticdb-file-table-object file t))) + (table (semanticdb-find-table-for-include tag (current-buffer))) (face nil) (map nil) ) (cond - ((not file) + ((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 @@ -319,7 +387,7 @@ This mode provides a nice context menu on the include statements." ;;; Regular Include Functions ;; (defun semantic-decoration-include-describe () - "Describe what unparsed includes are in the current buffer. + "Describe the current include tag. Argument EVENT is the mouse clicked event." (interactive) (let* ((tag (or (semantic-current-tag) @@ -421,7 +489,7 @@ Argument EVENT describes the event that caused this function to be called." ;;; Unknown Include functions ;; (defun semantic-decoration-unknown-include-describe () - "Describe what unknown includes are in the current buffer. + "Describe the current unknown include. Argument EVENT is the mouse clicked event." (interactive) (let ((tag (semantic-current-tag)) @@ -484,7 +552,7 @@ 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 unparsed includes. + "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)) @@ -501,6 +569,49 @@ Argument EVENT describes the event that caused this function to be called." (select-window startwin))) +;;; 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 (object-print 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)) + ;; This line has an issue in XEmacs. + (win (semantic-event-window event)) + ) + (select-window win t) + (save-excursion + ;(goto-char (window-start win)) + (mouse-set-point event) + (sit-for 0) + (semantic-popup-menu semantic-decoration-on-fileless-include-menu) + ) + (select-window startwin))) + + ;;; Interactive parts of unparsed includes ;; (defun semantic-decoration-unparsed-include-describe () @@ -667,6 +778,9 @@ Argument EVENT describes the event that caused this function to be called." (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")) )) diff --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el index f67978a2620..69dfa119167 100644 --- a/lisp/cedet/semantic/decorate/mode.el +++ b/lisp/cedet/semantic/decorate/mode.el @@ -265,6 +265,8 @@ minor mode is enabled." (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook) (add-hook 'semantic-after-toplevel-cache-change-hook 'semantic-decorate-tags-after-full-reparse nil t) + ;; Decorate includes by default + (require 'semantic/decorate/include) ;; Add decorations to available tags. The above hooks ensure ;; that new tags will be decorated when they become available. (semantic-decorate-add-decorations (semantic-fetch-available-tags))) diff --git a/lisp/cedet/semantic/doc.el b/lisp/cedet/semantic/doc.el index ddf1518f539..8a4e61fbad2 100644 --- a/lisp/cedet/semantic/doc.el +++ b/lisp/cedet/semantic/doc.el @@ -115,7 +115,10 @@ If NOSNARF is 'lex, then return the lex token." ;; 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)))))) + (substring ct (match-end 0))))) + ;; Remove comment delimiter at the end of the string. + (when (string-match (concat (regexp-quote comment-end) "$") ct) + (setq ct (substring ct 0 (match-beginning 0))))) ;; Now return the text. ct)))) diff --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el index 0fc1829566c..16cf0ca96a2 100644 --- a/lisp/cedet/semantic/ede-grammar.el +++ b/lisp/cedet/semantic/ede-grammar.el @@ -32,7 +32,7 @@ (require 'semantic/grammar) ;;; Code: -(defclass semantic-ede-proj-target-grammar (ede-proj-target-makefile) +(defclass semantic-ede-proj-target-grammar (ede-proj-target-elisp) ((menu :initform nil) (keybindings :initform nil) (phony :initform t) @@ -44,15 +44,33 @@ (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.") +(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 "semantic-ede-grammar-source-wisent" :name "Wisent Grammar" :sourcepattern "\\.wy$" + :garbagepattern '("*-wy.el") ) "Semantic Grammar source code definition for wisent.") @@ -64,21 +82,17 @@ parsing different languages.") (semantic-ede-grammar-compiler-class "ede-emacs-wisent-compiler" :name "emacs" - :variables '(("EMACS" . "emacs")) - :commands - '( - "@echo \"(add-to-list 'load-path nil)\" > grammar-make-script" - "@for loadpath in . ${LOADPATH}; do \\" - " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> grammar-make-script; \\" - "done;" - "@echo \"(require 'semantic/load)\" >> grammar-make-script" - "@echo \"(require 'semantic/grammar)\" >> grammar-make-script" - ;; "@echo \"(setq debug-on-error t)\" >> grammar-make-script" - "\"$(EMACS)\" -batch --no-site-file -l grammar-make-script -f semantic-grammar-batch-build-packages $^" - ) - ;; :autoconf '("AM_PATH_LISPDIR") + :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 + "elisp-inference-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.elc" + :objectextention "-wy.el" ) "Compile Emacs Lisp programs.") @@ -87,6 +101,7 @@ parsing different languages.") (ede-sourcecode "semantic-ede-grammar-source-bovine" :name "Bovine Grammar" :sourcepattern "\\.by$" + :garbagepattern '("*-by.el") ) "Semantic Grammar source code definition for the bovinator.") @@ -94,21 +109,17 @@ parsing different languages.") (semantic-ede-grammar-compiler-class "ede-emacs-wisent-compiler" :name "emacs" - :variables '(("EMACS" . "emacs")) - :commands - '( - "@echo \"(add-to-list 'load-path nil)\" > grammar-make-script" - "@for loadpath in . ${LOADPATH}; do \\" - " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> grammar-make-script; \\" - "done;" - "@echo \"(require 'semantic/load)\" >> grammar-make-script" - "@echo \"(require 'semantic/grammar)\" >> grammar-make-script" - ;; "@echo \"(setq debug-on-error t)\" >> grammar-make-script" - "\"$(EMACS)\" -batch --no-site-file -l grammar-make-script -f semantic-grammar-batch-build-packages $^" - ) - ;; :autoconf '("AM_PATH_LISPDIR") + :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 + "elisp-inference-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.elc" + :objectextention "-by.el" ) "Compile Emacs Lisp programs.") @@ -127,15 +138,32 @@ Lays claim to all -by.el, and -wy.el files." "Compile all sources in a Lisp target OBJ." (let* ((cb (current-buffer)) (proj (ede-target-parent obj)) - (default-directory (oref proj directory))) + (default-directory (oref proj directory)) + (comp 0) + (utd 0)) (mapc (lambda (src) (with-current-buffer (find-file-noselect src) - (save-excursion - (semantic-grammar-create-package)) - (save-buffer) - (byte-recompile-file (concat (semantic-grammar-package) ".el") nil 0))) - (oref obj source))) - (message "All Semantic Grammar sources are up to date in %s" (object-name obj))) + (let* ((package (semantic-grammar-create-package)) + (fname (progn (string-match ".*/\\(.+\\.el\\)" package) + (match-string 1 package))) + (src (with-current-buffer fname (buffer-file-name))) + (csrc (concat (file-name-sans-extension src) ".elc"))) + (if (< emacs-major-version 24) + ;; Does not have `byte-recompile-file' + (if (or (not (file-exists-p csrc)) + (file-newer-than-file-p src csrc)) + (progn + (setq comp (1+ comp)) + (byte-compile-file src)) + (setq utd (1+ utd))) + ;; Emacs 24 and newer + (with-no-warnings + (if (eq (byte-recompile-file src nil 0) t) + (setq comp (1+ comp)) + (setq utd (1+ utd)))))))) + (oref obj source)) + (message "All Semantic Grammar sources are up to date in %s" (object-name obj)) + (cons comp utd))) ;;; Makefile generation functions ;; @@ -164,18 +192,13 @@ Lays claim to all -by.el, and -wy.el files." " "))) ) -(defmethod ede-proj-makefile-insert-rules ((this semantic-ede-proj-target-grammar)) - "Insert rules needed by THIS target." - ;; Add in some dependencies. -;; (mapc (lambda (src) -;; (let ((nm (file-name-sans-extension src))) -;; (insert nm "-wy.el: " src "\n" -;; nm "-wy.elc: " nm "-wy.el\n\n") -;; )) -;; (oref this source)) - ;; Call the normal insertion of rules. - (call-next-method) - ) +(defmethod ede-proj-makefile-insert-rules :after ((this semantic-ede-proj-target-grammar)) + "Insert rules needed by THIS target. +This raises `max-specpdl-size' and `max-lisp-eval-depth', which can be +needed for the compilation of the resulting parsers." + (insert (format "%s: EMACSFLAGS+= --eval '(setq max-specpdl-size 1500 \ +max-lisp-eval-depth 700)'\n" + (oref this name)))) (defmethod ede-proj-makefile-insert-dist-dependencies ((this semantic-ede-proj-target-grammar)) "Insert dist dependencies, or intermediate targets. diff --git a/lisp/cedet/semantic/edit.el b/lisp/cedet/semantic/edit.el index 23b6784fe2a..5b39dec2628 100644 --- a/lisp/cedet/semantic/edit.el +++ b/lisp/cedet/semantic/edit.el @@ -72,7 +72,9 @@ updated in the current buffer. For language specific hooks, make sure you define this as a local hook.") -(defvar semantic-change-hooks +(define-obsolete-variable-alias 'semantic-change-hooks + 'semantic-change-functions "24.3") +(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 @@ -89,11 +91,15 @@ 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-hooks nil +(define-obsolete-variable-alias 'semantic-edits-new-change-hooks + 'semantic-edits-new-change-functions "24.3") +(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-hooks nil +(define-obsolete-variable-alias 'semantic-edits-delete-change-hooks + 'semantic-edits-delete-change-functions "24.3") +(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.") @@ -104,7 +110,9 @@ 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-hooks nil +(define-obsolete-variable-alias 'semantic-edits-reparse-change-hooks + 'semantic-edits-reparse-change-functions "24.3") +(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.") @@ -133,7 +141,7 @@ Argument START, END, and LENGTH specify the bounds of the change." (setq semantic-unmatched-syntax-cache-check t) (let ((inhibit-point-motion-hooks t) ) - (run-hook-with-args 'semantic-change-hooks start end length) + (run-hook-with-args 'semantic-change-functions start end length) )) (defun semantic-changes-in-region (start end &optional buffer) @@ -168,7 +176,7 @@ Argument START, END, and LENGTH specify the bounds of the change." ;; function will be removed from the list of active change ;; functions. (condition-case nil - (run-hook-with-args 'semantic-edits-new-change-hooks o) + (run-hook-with-args 'semantic-edits-new-change-functions o) (error nil))) (let ((tmp changes-in-change)) ;; Find greatest bounds of all changes @@ -188,7 +196,7 @@ Argument START, END, and LENGTH specify the bounds of the 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-hooks + (run-hook-with-args 'semantic-edits-delete-change-functions (car changes-in-change)) (error nil)) (semantic-overlay-delete (car changes-in-change)) @@ -198,7 +206,7 @@ Argument START, END, and LENGTH specify the bounds of the change." (defsubst semantic-edits-flush-change (change) "Flush the CHANGE overlay." (condition-case nil - (run-hook-with-args 'semantic-edits-delete-change-hooks + (run-hook-with-args 'semantic-edits-delete-change-functions change) (error nil)) (semantic-overlay-delete change)) diff --git a/lisp/cedet/semantic/find.el b/lisp/cedet/semantic/find.el index ce7ba9926d2..5c724a96d40 100644 --- a/lisp/cedet/semantic/find.el +++ b/lisp/cedet/semantic/find.el @@ -49,6 +49,7 @@ (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 ;; @@ -362,12 +363,19 @@ See `semantic-tag-protected-p' for details on which tags are returned." table (require 'semantic/tag-ls) (semantic--find-tags-by-macro - (not (semantic-tag-protected-p (car tags) scopeprotection parent)) + (not (and (semantic-tag-protected-p (car tags) scopeprotection parent) + (semantic-tag-package-protected-p (car tags) parent))) table))) -(defsubst semantic-find-tags-included (&optional 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'." +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 diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index 851d5cd9e8e..6dd85309967 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -33,42 +33,138 @@ (load "semantic/loaddefs" nil 'nomessage) ;;; Compatibility - -(defalias 'semantic-buffer-local-value 'buffer-local-value) -(defalias 'semantic-overlay-live-p 'overlay-buffer) -(defalias 'semantic-make-overlay 'make-overlay) -(defalias 'semantic-overlay-put 'overlay-put) -(defalias 'semantic-overlay-get 'overlay-get) -(defalias 'semantic-overlay-properties 'overlay-properties) -(defalias 'semantic-overlay-move 'move-overlay) -(defalias 'semantic-overlay-delete 'delete-overlay) -(defalias 'semantic-overlays-at 'overlays-at) -(defalias 'semantic-overlays-in 'overlays-in) -(defalias 'semantic-overlay-buffer 'overlay-buffer) -(defalias 'semantic-overlay-start 'overlay-start) -(defalias 'semantic-overlay-end 'overlay-end) -(defalias 'semantic-overlay-size 'overlay-size) -(defalias 'semantic-overlay-next-change 'next-overlay-change) -(defalias 'semantic-overlay-previous-change 'previous-overlay-change) -(defalias 'semantic-overlay-lists 'overlay-lists) -(defalias 'semantic-overlay-p 'overlayp) -(defalias 'semantic-read-event 'read-event) -(defalias 'semantic-popup-menu 'popup-menu) -(defalias 'semantic-make-local-hook 'identity) -(defalias 'semantic-mode-line-update 'force-mode-line-update) -(defalias 'semantic-run-mode-hooks 'run-mode-hooks) -(defalias 'semantic-compile-warn 'byte-compile-warn) -(defalias 'semantic-menu-item 'identity) - -(defun semantic-event-window (event) - "Extract the window from EVENT." - (car (car (cdr event)))) +;; +(eval-and-compile + (if (featurep 'xemacs) + (progn + (defalias 'semantic-buffer-local-value 'symbol-value-in-buffer) + (defalias 'semantic-overlay-live-p + (lambda (o) + (and (extent-live-p o) + (not (extent-detached-p o)) + (bufferp (extent-buffer o))))) + (defalias 'semantic-make-overlay + (lambda (beg end &optional buffer &rest rest) + "Xemacs `make-extent', supporting the front/rear advance options." + (let ((ol (make-extent beg end buffer))) + (when rest + (set-extent-property ol 'start-open (car rest)) + (setq rest (cdr rest))) + (when rest + (set-extent-property ol 'end-open (car rest))) + ol))) + (defalias 'semantic-overlay-put 'set-extent-property) + (defalias 'semantic-overlay-get 'extent-property) + (defalias 'semantic-overlay-properties 'extent-properties) + (defalias 'semantic-overlay-move 'set-extent-endpoints) + (defalias 'semantic-overlay-delete 'delete-extent) + (defalias 'semantic-overlays-at + (lambda (pos) + (condition-case nil + (extent-list nil pos pos) + (error nil)) + )) + (defalias 'semantic-overlays-in + (lambda (beg end) (extent-list nil beg end))) + (defalias 'semantic-overlay-buffer 'extent-buffer) + (defalias 'semantic-overlay-start 'extent-start-position) + (defalias 'semantic-overlay-end 'extent-end-position) + (defalias 'semantic-overlay-size 'extent-length) + (defalias 'semantic-overlay-next-change 'next-extent-change) + (defalias 'semantic-overlay-previous-change 'previous-extent-change) + (defalias 'semantic-overlay-lists + (lambda () (list (extent-list)))) + (defalias 'semantic-overlay-p 'extentp) + (defalias 'semantic-event-window 'event-window) + (defun semantic-read-event () + (let ((event (next-command-event))) + (if (key-press-event-p event) + (let ((c (event-to-character event))) + (if (char-equal c (quit-char)) + (keyboard-quit) + c))) + event)) + (defun semantic-popup-menu (menu) + "Blocking version of `popup-menu'" + (popup-menu menu) + ;; Wait... + (while (popup-up-p) (dispatch-event (next-event)))) + ) + ;; Emacs Bindings + (defalias 'semantic-overlay-live-p 'overlay-buffer) + (defalias 'semantic-make-overlay 'make-overlay) + (defalias 'semantic-overlay-put 'overlay-put) + (defalias 'semantic-overlay-get 'overlay-get) + (defalias 'semantic-overlay-properties 'overlay-properties) + (defalias 'semantic-overlay-move 'move-overlay) + (defalias 'semantic-overlay-delete 'delete-overlay) + (defalias 'semantic-overlays-at 'overlays-at) + (defalias 'semantic-overlays-in 'overlays-in) + (defalias 'semantic-overlay-buffer 'overlay-buffer) + (defalias 'semantic-overlay-start 'overlay-start) + (defalias 'semantic-overlay-end 'overlay-end) + (defalias 'semantic-overlay-next-change 'next-overlay-change) + (defalias 'semantic-overlay-previous-change 'previous-overlay-change) + (defalias 'semantic-overlay-lists 'overlay-lists) + (defalias 'semantic-overlay-p 'overlayp) + (defalias 'semantic-read-event 'read-event) + (defalias 'semantic-popup-menu 'popup-menu) + (defun semantic-event-window (event) + "Extract the window from EVENT." + (car (car (cdr event)))) + + (if (> emacs-major-version 21) + (defalias 'semantic-buffer-local-value 'buffer-local-value) + + (defun semantic-buffer-local-value (sym &optional buf) + "Get the value of SYM from buffer local variable in BUF." + (cdr (assoc sym (buffer-local-variables buf))))) + ) + + + (defalias 'semantic-make-local-hook + (if (and (not (featurep 'xemacs)) + (>= emacs-major-version 21)) + #'identity #'make-local-hook)) + + (defalias 'semantic-mode-line-update + (if (featurep 'xemacs) #'redraw-modeline #'force-mode-line-update)) + + ;; Since Emacs 22 major mode functions should use `run-mode-hooks' to + ;; run major mode hooks. + (defalias 'semantic-run-mode-hooks + (if (fboundp 'run-mode-hooks) + 'run-mode-hooks + 'run-hooks)) + + ;; Fancy compat usage now handled in cedet-compat + (defalias 'semantic-subst-char-in-string 'subst-char-in-string) + ) (defun semantic-delete-overlay-maybe (overlay) "Delete OVERLAY if it is a semantic token overlay." (if (semantic-overlay-get overlay 'semantic) (semantic-overlay-delete overlay))) +;;; Menu Item compatibility +;; +(defun semantic-menu-item (item) + "Build an XEmacs compatible menu item from vector ITEM. +That is remove the unsupported :help stuff." + (if (featurep 'xemacs) + (let ((n (length item)) + (i 0) + slot l) + (while (< i n) + (setq slot (aref item i)) + (if (and (keywordp slot) + (eq slot :help)) + (setq i (1+ i)) + (setq l (cons slot l))) + (setq i (1+ i))) + (apply #'vector (nreverse l))) + item)) + ;;; Positional Data Cache ;; (defvar semantic-cache-data-overlays nil @@ -138,6 +234,23 @@ Remove self from `post-command-hook' if it is empty." (when ans (semantic-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) @@ -161,7 +274,7 @@ will throw a warning when it encounters this symbol." (not (string-match "cedet" byte-compile-current-file)) ) (make-obsolete-overload oldfnalias newfn when) - (semantic-compile-warn + (byte-compile-warn "%s: `%s' obsoletes overload `%s'" byte-compile-current-file newfn @@ -179,7 +292,7 @@ will throw a warning when it encounters this symbol." ;; Only throw this warning when byte compiling things. (when (and (boundp 'byte-compile-current-file) byte-compile-current-file) - (semantic-compile-warn + (byte-compile-warn "variable `%s' obsoletes, but isn't alias of `%s'" newvar oldvaralias) )))) @@ -276,6 +389,17 @@ calling this one." "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'" + ;; Hack - + ;; Check if we are in set-auto-mode, and if so, warn about this. + (when (or (and (featurep 'emacs) (boundp 'keep-mode-if-same)) + (and (featurep 'xemacs) (boundp 'just-from-file-name))) + (let ((filename (or (and (boundp 'filename) filename) + "(unknown)"))) + (message "WARNING: semantic-find-file-noselect called for \ +%s while in set-auto-mode for %s. You should call the responsible function \ +into `mode-local-init-hook'." file filename) + (sit-for 1))) + (let* ((recentf-exclude '( (lambda (f) t) )) ;; This is a brave statement. Don't waste time loading in ;; lots of modes. Especially decoration mode can waste a lot @@ -285,21 +409,17 @@ FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'" (ede-auto-add-method 'never) ;; Ask font-lock to not colorize these buffers, nor to ;; whine about it either. - (font-lock-maximum-size 0) + (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 - (if (featurep 'xemacs) - ;; XEmacs only has nil as an option? - nil - ;; Emacs 23 has the spiffy :safe option, nil otherwise. - (if (>= emacs-major-version 22) - nil - :safe))) + (enable-local-variables :safe) ;; ... or eval variables (enable-local-eval nil) ) diff --git a/lisp/cedet/semantic/grammar-wy.el b/lisp/cedet/semantic/grammar-wy.el index 7408dd6702e..a926f636b4b 100644 --- a/lisp/cedet/semantic/grammar-wy.el +++ b/lisp/cedet/semantic/grammar-wy.el @@ -2,9 +2,6 @@ ;; Copyright (C) 2002-2004, 2009-2012 Free Software Foundation, Inc. -;; Author: 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 @@ -26,7 +23,10 @@ ;;; Code: -(require 'semantic/lex) +(require 'semantic) + +;;; Prologue +;; (defvar semantic-grammar-lex-c-char-re) ;; Current parsed nonterminal name. @@ -45,6 +45,7 @@ ("%left" . LEFT) ("%nonassoc" . NONASSOC) ("%package" . PACKAGE) + ("%provide" . PROVIDE) ("%prec" . PREC) ("%put" . PUT) ("%quotemode" . QUOTEMODE) @@ -109,7 +110,7 @@ (eval-when-compile (require 'semantic/wisent/comp)) (wisent-compile-grammar - '((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE LEFT NONASSOC PACKAGE 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) + '((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE LEFT NONASSOC PACKAGE 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)) @@ -133,6 +134,7 @@ ((no_default_prec_decl)) ((languagemode_decl)) ((package_decl)) + ((provide_decl)) ((precedence_decl)) ((put_decl)) ((quotemode_decl)) @@ -161,6 +163,10 @@ ((PACKAGE SYMBOL) `(wisent-raw-tag (semantic-tag-new-package ',$2 nil)))) + (provide_decl + ((PROVIDE SYMBOL) + `(wisent-raw-tag + (semantic-tag ',$2 'provide)))) (precedence_decl ((associativity token_type_opt items) `(wisent-raw-tag @@ -411,31 +417,17 @@ '((parse-stream . wisent-parse-stream))) (setq semantic-parser-name "LALR" semantic--parse-table semantic-grammar-wy--parse-table - semantic-debug-parser-source "semantic-grammar.wy" + 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 (semantic-make-local-hook 'wisent-discarding-token-functions) (add-hook 'wisent-discarding-token-functions - 'wisent-collect-unmatched-syntax nil t)) + 'wisent-collect-unmatched-syntax nil t)) ;;; Analyzers - -(define-lex-sexp-type-analyzer semantic-grammar-wy--<sexp>-sexp-analyzer - "sexp analyzer for <sexp> tokens." - "\\=" - 'SEXP) - -(define-lex-sexp-type-analyzer semantic-grammar-wy--<qlist>-sexp-analyzer - "sexp analyzer for <qlist> tokens." - "\\s'\\s-*(" - 'PREFIXED_LIST) - -(define-lex-keyword-type-analyzer semantic-grammar-wy--<keyword>-keyword-analyzer - "keyword analyzer for <keyword> tokens." - "\\(\\sw\\|\\s_\\)+") - +;; (define-lex-block-type-analyzer semantic-grammar-wy--<block>-block-analyzer "block analyzer for <block> tokens." "\\s(\\|\\s)" @@ -451,17 +443,22 @@ nil 'CHARACTER) -(define-lex-sexp-type-analyzer semantic-grammar-wy--<string>-sexp-analyzer - "sexp analyzer for <string> tokens." - "\\s\"" - 'STRING) - (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--<string>-sexp-analyzer + "sexp analyzer for <string> tokens." + "\\s\"" + 'STRING) + (define-lex-string-type-analyzer semantic-grammar-wy--<punctuation>-string-analyzer "string analyzer for <punctuation> tokens." "\\(\\s.\\|\\s$\\|\\s'\\)+" @@ -472,6 +469,22 @@ (COLON . ":")) 'punctuation) +(define-lex-keyword-type-analyzer semantic-grammar-wy--<keyword>-keyword-analyzer + "keyword analyzer for <keyword> tokens." + "\\(\\sw\\|\\s_\\)+") + +(define-lex-sexp-type-analyzer semantic-grammar-wy--<sexp>-sexp-analyzer + "sexp analyzer for <sexp> tokens." + "\\=" + 'SEXP) + + +;;; Epilogue +;; + + + + (provide 'semantic/grammar-wy) ;;; semantic/grammar-wy.el ends here diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el index ac28702787d..8535c067e09 100644 --- a/lisp/cedet/semantic/grammar.el +++ b/lisp/cedet/semantic/grammar.el @@ -30,10 +30,13 @@ ;;; Code: (require 'semantic) +(require 'semantic/wisent) (require 'semantic/ctxt) (require 'semantic/format) (require 'semantic/grammar-wy) (require 'semantic/idle) +(require 'help-fns) + (declare-function semantic-momentary-highlight-tag "semantic/decorate") (declare-function semantic-analyze-context "semantic/analyze") (declare-function semantic-analyze-tags-of-class-list @@ -42,7 +45,11 @@ (eval-when-compile (require 'eldoc) (require 'semantic/edit) - (require 'semantic/find)) + (require 'semantic/find) + (require 'semantic/db)) + +(declare-function semantic-grammar-wy--install-parser + "semantic/gram-wy-fallback") ;;;; @@ -488,33 +495,27 @@ Also load the specified macro libraries." ;;;; (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 (file-name-sans-extension - (semantic-grammar-buffer-file - semantic--grammar-output-buffer)) + (concat semantic--grammar-package "--keyword-table")) (defsubst semantic-grammar-tokentable () "Return the variable name of the token table." - (concat (file-name-sans-extension - (semantic-grammar-buffer-file - semantic--grammar-output-buffer)) + (concat semantic--grammar-package "--token-table")) (defsubst semantic-grammar-parsetable () "Return the variable name of the parse table." - (concat (file-name-sans-extension - (semantic-grammar-buffer-file - semantic--grammar-output-buffer)) + (concat semantic--grammar-package "--parse-table")) (defsubst semantic-grammar-setupfunction () "Return the name of the parser setup function." - (concat (file-name-sans-extension - (semantic-grammar-buffer-file - semantic--grammar-output-buffer)) + (concat semantic--grammar-package "--install-parser")) (defmacro semantic-grammar-as-string (object) @@ -592,6 +593,9 @@ Typically a DEFINE expression should look like this: ;; ;;; Code: + +(require 'semantic/lex) +(eval-when-compile (require 'semantic/bovine)) ") "Generated header template. The symbols in the template are local variables in @@ -642,7 +646,8 @@ The symbols in the list are local variables in "Return text of a generated standard footer." (let* ((file (semantic-grammar-buffer-file semantic--grammar-output-buffer)) - (libr (file-name-sans-extension file)) + (libr (or semantic--grammar-provide + semantic--grammar-package)) (out "")) (dolist (S semantic-grammar-footer-template) (cond ((stringp S) @@ -748,9 +753,7 @@ Block definitions are read from the current table of lexical types." ;; explicitly declared in a %type statement, and if at least the ;; syntax property has been provided. (when (and declared syntax) - (setq prefix (file-name-sans-extension - (semantic-grammar-buffer-file - semantic--grammar-output-buffer)) + (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)) @@ -801,7 +804,6 @@ Block definitions are read from the current table of lexical types." (with-current-buffer semantic--grammar-input-buffer (setq tokens (semantic-grammar-tokens) props (semantic-grammar-token-properties tokens))) - (insert "(require 'semantic/lex)\n\n") (let ((semantic-lex-types-obarray (semantic-lex-make-type-table tokens props)) semantic-grammar--lex-block-specs) @@ -827,16 +829,22 @@ Does nothing if the Lisp code seems up to date. 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. - (package (semantic-grammar-package)) - (output (concat package ".el")) + (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 output)) + (semantic--grammar-output-buffer + (find-file-noselect + (file-name-nondirectory output))) (header (semantic-grammar-header)) (prologue (semantic-grammar-prologue)) (epilogue (semantic-grammar-epilogue)) @@ -847,7 +855,7 @@ Lisp code." (file-newer-than-file-p (buffer-file-name semantic--grammar-output-buffer) (buffer-file-name semantic--grammar-input-buffer))) - (message "Package `%s' is up to date." package) + (message "Package `%s' is up to date." semantic--grammar-package) ;; Create the package (set-buffer semantic--grammar-output-buffer) ;; Use Unix EOLs, so that the file is portable to all platforms. @@ -965,7 +973,11 @@ Return non-nil if there were no errors, nil if errors." (let ((packagename (condition-case err (with-current-buffer (find-file-noselect file) - (semantic-grammar-create-package)) + (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))) (error (message "%s" (error-message-string err)) nil)))) @@ -1000,7 +1012,6 @@ See also the variable `semantic-grammar-file-regexp'." ;; 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))) - (message "Compiling Grammars from: %s" (locate-library "semantic-grammar")) (dolist (arg command-line-args-left) (unless (and arg (file-exists-p arg)) (error "Argument %s is not a valid file name" arg)) @@ -1322,8 +1333,8 @@ the change bounds to encompass the whole nonterminal tag." (add-hook 'before-change-functions 'semantic--grammar-clear-macros-regexp-2 nil t) ;; Handle safe re-parse of grammar rules. - (semantic-make-local-hook 'semantic-edits-new-change-hooks) - (add-hook 'semantic-edits-new-change-hooks + (semantic-make-local-hook 'semantic-edits-new-change-functions) + (add-hook 'semantic-edits-new-change-functions 'semantic-grammar-edits-new-change-hook-fcn nil t) (semantic-run-mode-hooks 'semantic-grammar-mode-hook)) @@ -1631,6 +1642,12 @@ Select the buffer containing the tag's definition, and move point there." ) "Association of syntax elements, and the corresponding help.") +(declare-function eldoc-function-argstring "eldoc") +(declare-function eldoc-docstring-format-sym-doc "eldoc") +(declare-function eldoc-last-data-store "eldoc") +(declare-function eldoc-get-fnsym-args-string "eldoc") +(declare-function eldoc-get-var-docstring "eldoc") + (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." diff --git a/lisp/cedet/semantic/ia.el b/lisp/cedet/semantic/ia.el index 1aedc7b6d45..9f6a82159e8 100644 --- a/lisp/cedet/semantic/ia.el +++ b/lisp/cedet/semantic/ia.el @@ -37,9 +37,10 @@ (require 'semantic/analyze) (require 'semantic/format) (require 'pulse) +(require 'semantic/senator) +(require 'semantic/analyze/refs) (eval-when-compile (require 'semantic/analyze) - (require 'semantic/analyze/refs) (require 'semantic/find)) (declare-function imenu--mouse-menu "imenu") @@ -143,11 +144,50 @@ Completion options are calculated with `semantic-analyze-possible-completions'." (mapcar semantic-ia-completion-format-tag-function syms))))))))) (defcustom semantic-ia-completion-menu-format-tag-function - 'semantic-uml-concise-prototype-nonterminal + '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. 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) + (senator-completion-menu-point-as-event) + "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, diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el index 7ed1612d592..57cb17a233e 100644 --- a/lisp/cedet/semantic/idle.el +++ b/lisp/cedet/semantic/idle.el @@ -41,6 +41,7 @@ (require 'semantic/format) (require 'semantic/tag) (require 'timer) +;;(require 'working) ;; For the semantic-find-tags-by-name macro. (eval-when-compile (require 'semantic/find)) @@ -150,12 +151,18 @@ all buffers regardless of their size." "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." - (and semantic-idle-scheduler-mode - (not (and (boundp 'semantic-debug-enabled) - semantic-debug-enabled)) - (not semantic-lex-debug) - (or (<= semantic-idle-scheduler-max-buffer-size 0) - (< (buffer-size) semantic-idle-scheduler-max-buffer-size)))) + (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 @@ -554,10 +561,11 @@ 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:" (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"))) - (func (intern (concat (symbol-name name) "-idle-function")))) + (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")))) `(eval-and-compile (define-minor-mode ,global @@ -607,7 +615,10 @@ turned on in every Semantic-supported buffer.") (symbol-name mode) "'.") ,@forms)))) (put 'define-semantic-idle-service 'lisp-indent-function 1) - +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec define-semantic-idle-service + (&define name stringp def-body)))) ;;; SUMMARY MODE ;; @@ -878,7 +889,7 @@ Call `semantic-symref-hits-in-region' to identify local references." ;; We use pulse, but we don't want the flashy version, ;; just the stable version. (pulse-flag nil)) - (when ctxt + (when (and ctxt tag) ;; Highlight the original tag? Protect against problems. (condition-case nil (semantic-idle-symbol-maybe-highlight target) @@ -932,15 +943,18 @@ doing fancy completions." "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. Ignore problems. - ;; If something doesn't do what you expect, run - ;; the below command by hand instead. - (condition-case nil + ;; 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 nil)) + (error + (when semantic-idle-scheduler-verbose-flag + (message " %s" (error-message-string err))))) )) (define-semantic-idle-service semantic-idle-completions @@ -1133,7 +1147,7 @@ be called." ;; :active t ;; :style 'toggle ;; :selected '(let ((tag (semantic-current-tag))) - ;; (and tag (semantic-tag-folded-p tag))) + ;; (and tag (semantic-tag-folded-p tag))) ;; :help "Fold the current tag to one line")) "---" (semantic-menu-item @@ -1168,17 +1182,19 @@ be called." ;; Format TAG-LIST and put the formatted string into the header ;; line. (setq header-line-format - (concat - 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))))) + (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)) @@ -1192,7 +1208,9 @@ TODO THIS FUNCTION DOES NOT WORK YET." (let ((width (- (nth 2 (window-edges)) (nth 0 (window-edges))))) (setq mode-line-format - (semantic-idle-breadcrumbs--format-tag-list tag-list width))) + (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)) diff --git a/lisp/cedet/semantic/java.el b/lisp/cedet/semantic/java.el index 8747d793ab8..e560e6ecab2 100644 --- a/lisp/cedet/semantic/java.el +++ b/lisp/cedet/semantic/java.el @@ -121,6 +121,7 @@ corresponding compound declaration." (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)) @@ -139,7 +140,20 @@ corresponding compound declaration." (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-match "\\." (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)) ;;; Environment @@ -159,6 +173,15 @@ corresponding compound declaration." (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) @@ -242,7 +265,6 @@ Optional argument COLOR indicates that color should be mixed in." (let ((name (semantic-tag-name tag))) (concat (mapconcat 'identity (split-string name "\\.") "/") ".java"))) - ;; Documentation handler ;; (defsubst semantic-java-skip-spaces-backward () diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el index 5f121d88ac6..ad366c2b94f 100644 --- a/lisp/cedet/semantic/lex-spp.el +++ b/lisp/cedet/semantic/lex-spp.el @@ -30,7 +30,7 @@ ;; If you use SPP in your language, be sure to specify this in your ;; semantic language setup function: ;; -;; (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t) +;; (add-hook 'semantic-lex-reset-functions 'semantic-lex-spp-reset-hook nil t) ;; ;; ;; Special Lexical Tokens: @@ -497,7 +497,7 @@ and what valid VAL values are." ;; (symbol "name" 569 . 573) ;; (semantic-list "(int in)" 574 . 582)) ;; - ;; In the second case, a macro with an argument list as the a rgs as the + ;; In the second case, a macro with an argument list as the args as the ;; first entry. ;; ;; CASE 3: Symbol text merge @@ -577,13 +577,7 @@ and what valid VAL values are." (cond ;; CASE 3: Merge symbols together. ((eq (semantic-lex-token-class v) 'spp-symbol-merge) - ;; We need to merge the tokens in the 'text segment together, - ;; and produce a single symbol from it. - (let ((newsym - (mapconcat (lambda (tok) - (semantic-lex-spp-one-token-to-txt tok)) - txt - ""))) + (let ((newsym (semantic-lex-spp-symbol-merge txt))) (semantic-lex-push-token (semantic-lex-token 'symbol beg end newsym)) )) @@ -637,6 +631,27 @@ and what valid VAL values are." (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 + "")) + ;;; Macro Merging ;; ;; Used when token streams from different macros include each other. @@ -869,7 +884,14 @@ Parsing starts inside the parens, and ends at the end of TOKEN." (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)) + ;; 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))))) @@ -890,6 +912,7 @@ and variable state from the current buffer." (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 @@ -913,14 +936,19 @@ and variable state from the current buffer." ;; Hack in mode-local (activate-mode-local-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-hooks 'semantic-lex-spp-reset-hook - t) + (remove-hook 'semantic-lex-reset-functions + 'semantic-lex-spp-reset-hook t) )) ;; Second Cheat: copy key variables regarding macro state from the diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el index e47cc1eaee9..274df355901 100644 --- a/lisp/cedet/semantic/lex.el +++ b/lisp/cedet/semantic/lex.el @@ -691,20 +691,6 @@ Return the overlay." (semantic-overlay-put o 'face 'highlight) o)) -(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))) - (semantic-read-event - (format "%S :: SPC - continue" token)) - ) - (when o - (semantic-overlay-delete o)))))) - ;;; Lexical analyzer creation ;; ;; Code for creating a lex function from lists of analyzers. @@ -743,7 +729,9 @@ 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-hooks nil +(define-obsolete-variable-alias 'semantic-lex-reset-hooks + 'semantic-lex-reset-functions "24.3") +(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 @@ -754,6 +742,20 @@ a LOCAL option.") ;;(defvar semantic-lex-timeout 5 ;; "*Number of sections of lexing before giving up.") +(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))) + (semantic-read-event + (format "%S :: Depth: %d :: SPC - continue" token semantic-lex-current-depth)) + ) + (when o + (semantic-overlay-delete o)))))) + (defmacro define-lex (name doc &rest analyzers) "Create a new lexical analyzer with NAME. DOC is a documentation string describing this analyzer. @@ -771,7 +773,7 @@ analyzer which might mistake a number for as a symbol." ;; 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-hooks start end) + (run-hook-with-args 'semantic-lex-reset-functions start end) ;; Lexing state. (let* (;(starttime (current-time)) (starting-position (point)) @@ -1205,11 +1207,13 @@ symbols returned in open and close tokens." )) )) ((setq match (assoc text ',clist)) - (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))))))) + (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))))))))) ))) ;;; Analyzers diff --git a/lisp/cedet/semantic/mru-bookmark.el b/lisp/cedet/semantic/mru-bookmark.el index 4216e099857..1358fc7d062 100644 --- a/lisp/cedet/semantic/mru-bookmark.el +++ b/lisp/cedet/semantic/mru-bookmark.el @@ -53,6 +53,7 @@ (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 ;; @@ -291,13 +292,13 @@ minor mode is enabled." (setq semantic-mru-bookmark-mode nil) (error "Buffer %s was not set up for parsing" (buffer-name))) - (semantic-make-local-hook 'semantic-edits-new-change-hooks) - (add-hook 'semantic-edits-new-change-hooks + (semantic-make-local-hook 'semantic-edits-new-change-functions) + (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-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))) diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el index c5b07b9d440..0882120fc65 100644 --- a/lisp/cedet/semantic/scope.el +++ b/lisp/cedet/semantic/scope.el @@ -56,6 +56,7 @@ (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: @@ -158,7 +159,7 @@ If nil, then the typescope is reset." ;; tag can be passed in and a scope derived from it. (defun semantic-scope-tag-clone-with-scope (tag scopetags) - "Close TAG, and return it. Add SCOPETAGS as a tag-local scope. + "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)) ) @@ -197,7 +198,7 @@ Use `semantic-ctxt-scoped-types' to find types." (semanticdb-typecache-find (car sp))) ;(semantic-analyze-find-tag (car sp) 'type)) ((semantic-tag-p (car sp)) - (if (semantic-analyze-tag-prototype-p (car sp)) + (if (semantic-tag-prototype-p (car sp)) (semanticdb-typecache-find (semantic-tag-name (car sp))) ;;(semantic-analyze-find-tag (semantic-tag-name (car sp)) 'type) (car sp))) @@ -271,9 +272,11 @@ are from nesting data types." (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. - (setq returnlist (cons (car stack) returnlist)) - (setq stack (cdr stack))) + ;; 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)) )) diff --git a/lisp/cedet/semantic/senator.el b/lisp/cedet/semantic/senator.el index 64f99a8ad6f..1138c13096a 100644 --- a/lisp/cedet/semantic/senator.el +++ b/lisp/cedet/semantic/senator.el @@ -255,6 +255,7 @@ TEXT, BOUND, NOERROR, and COUNT arguments are interpreted." "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) @@ -294,6 +295,7 @@ Return the tag or nil if at end of buffer." "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) @@ -519,6 +521,7 @@ 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") diff --git a/lisp/cedet/semantic/symref.el b/lisp/cedet/semantic/symref.el index 1c8063134d6..ad897680d7f 100644 --- a/lisp/cedet/semantic/symref.el +++ b/lisp/cedet/semantic/symref.el @@ -185,7 +185,7 @@ to perform the search. This was added for use by a test harness." ;;;###autoload (defun semantic-symref-find-tags-by-name (name &optional scope) - "Find a list of references to NAME in the current project. + "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. @@ -356,7 +356,7 @@ already." (lambda (hit) (let* ((line (car hit)) (file (cdr hit)) - (buff (get-file-buffer file)) + (buff (find-buffer-visiting file)) (tag nil) ) (cond @@ -389,9 +389,11 @@ already." (forward-line (1- line)) ;; Search forward for the matching text - (re-search-forward (regexp-quote txt) - (point-at-eol) - t) + (when (re-search-forward (regexp-quote txt) + (point-at-eol) + t) + (goto-char (match-beginning 0)) + ) (setq tag (semantic-current-tag)) diff --git a/lisp/cedet/semantic/symref/filter.el b/lisp/cedet/semantic/symref/filter.el index 57d628b2681..c6aa48bfbc3 100644 --- a/lisp/cedet/semantic/symref/filter.el +++ b/lisp/cedet/semantic/symref/filter.el @@ -85,6 +85,27 @@ Search occurs in the current buffer between START and END." (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 (current-time)))) + Lcount))) + (defun semantic-symref-rename-local-variable () "Fancy way to rename the local variable under point. Depends on the SRecode Field editing API." diff --git a/lisp/cedet/semantic/symref/list.el b/lisp/cedet/semantic/symref/list.el index 9a3cb1f524a..729bd8e153c 100644 --- a/lisp/cedet/semantic/symref/list.el +++ b/lisp/cedet/semantic/symref/list.el @@ -69,7 +69,7 @@ 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-buffer-deep + (interactive (list (semantic-tag-name (semantic-complete-read-tag-project "Symrefs for: ")))) (semantic-fetch-tags) (let ((res nil) @@ -120,6 +120,7 @@ Display the references in`semantic-symref-results-mode'." (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) diff --git a/lisp/cedet/semantic/tag-ls.el b/lisp/cedet/semantic/tag-ls.el index e4c248934c3..094ea554287 100644 --- a/lisp/cedet/semantic/tag-ls.el +++ b/lisp/cedet/semantic/tag-ls.el @@ -30,9 +30,217 @@ ;; 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 +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." + (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-stream', +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-stream', +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)))) + +(make-obsolete-overload 'semantic-nonterminal-full-name + 'semantic-tag-full-name "23.2") + +(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 @@ -93,10 +301,38 @@ See `semantic-tag-protection'." ((string= s "private") 'private) ((string= s "protected") - '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 @@ -213,36 +449,6 @@ something without an implementation." (t nil)) )) -;;; 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-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-stream', -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 language 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 use -`semantic-tag-name'. Override functions only need to handle -STREAM-OR-BUFFER with a tag stream value, or nil." - (let ((stream (semantic-something-to-tag-table - (or stream-or-buffer tag)))) - (:override-with-args (tag stream)))) - -(make-obsolete-overload 'semantic-nonterminal-full-name - 'semantic-tag-full-name "23.2") - -(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." - (semantic-tag-name tag)) - (provide 'semantic/tag-ls) ;; Local variables: diff --git a/lisp/cedet/semantic/tag-write.el b/lisp/cedet/semantic/tag-write.el index 757609fac3f..69d26245850 100644 --- a/lisp/cedet/semantic/tag-write.el +++ b/lisp/cedet/semantic/tag-write.el @@ -41,12 +41,12 @@ INDENT is the amount of indentation to use for this tag." (signal 'wrong-type-argument (list tag 'semantic-tag-p))) (when (not indent) (setq indent 0)) ;(princ (make-string indent ? )) - (princ "(\"") + (princ "(") ;; Base parts (let ((name (semantic-tag-name tag)) (class (semantic-tag-class tag))) - (princ name) - (princ "\" ") + (prin1 name) + (princ " ") (princ (symbol-name class)) ) (let ((attr (semantic-tag-attributes tag)) diff --git a/lisp/cedet/semantic/tag.el b/lisp/cedet/semantic/tag.el index 29e83cd558b..38166871cea 100644 --- a/lisp/cedet/semantic/tag.el +++ b/lisp/cedet/semantic/tag.el @@ -51,6 +51,7 @@ (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") (defconst semantic-tag-version "2.0" "Version string of semantic tags made with this code.") @@ -362,45 +363,6 @@ of different cons cells." (equal (semantic-tag-bounds tag1) (semantic-tag-bounds tag2)))))) -(defun 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." - (let* ((A1 (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2)) - (semantic-tag-of-class-p tag1 (semantic-tag-class tag2)) - (semantic-tag-of-type-p tag1 (semantic-tag-type tag2)))) - (attr1 (semantic-tag-attributes tag1)) - (A2 (= (length attr1) (length (semantic-tag-attributes tag2)))) - (A3 t) - ) - (when (and (not A2) ignorable-attributes) - (setq A2 t)) - (while (and A2 attr1 A3) - (let ((a (car attr1)) - (v (car (cdr attr1)))) - - (cond ((or (eq a :type) ;; already tested above. - (memq a ignorable-attributes)) ;; Ignore them... - nil) - - ;; Don't test sublists of tags - ((and (listp v) (semantic-tag-p (car v))) - nil) - - ;; The attributes are not the same? - ((not (equal v (semantic-tag-get-attribute tag2 a))) - (setq A3 nil)) - (t - nil)) - ) - (setq attr1 (cdr (cdr attr1)))) - - (and A1 A2 A3) - )) (defun semantic-tag-similar-with-subtags-p (tag1 tag2 &rest ignorable-attributes) "Test to see if TAG1 and TAG2 are similar. @@ -408,28 +370,8 @@ 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'." - (let ((C1 (semantic-tag-components tag1)) - (C2 (semantic-tag-components tag2)) - ) - (if (or (/= (length C1) (length C2)) - (not (semantic-tag-similar-p tag1 tag2 ignorable-attributes)) - ) - ;; Basic test fails. - nil - ;; Else, check component lists. - (catch 'component-dissimilar - (while C1 - - (if (not (semantic-tag-similar-with-subtags-p - (car C1) (car C2) ignorable-attributes)) - (throw 'component-dissimilar nil)) - - (setq C1 (cdr C1)) - (setq C2 (cdr C2)) - ) - ;; If we made it this far, we are ok. - t) ))) - + ;; 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. @@ -612,6 +554,51 @@ You can identify a faux tag with `semantic-tag-faux-p'" "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 3 +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) @@ -1350,6 +1337,7 @@ of parent classes. The `cdr' of the list is the list of interfaces, or abstract classes which are parents of TAG." (cons (semantic-tag-get-attribute tag :superclasses) (semantic-tag-type-interfaces tag))) + (make-obsolete 'semantic-token-type-parent "\ use `semantic-tag-type-superclass' \ diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el index 36c14ce7c2a..d79e71bb265 100644 --- a/lisp/cedet/semantic/texi.el +++ b/lisp/cedet/semantic/texi.el @@ -26,17 +26,11 @@ ;; parser plug-in is the function `semantic-texi-parse-region' that ;; overrides `semantic-parse-region'. -(require 'semantic) +(require 'semantic/db-find) (require 'semantic/format) +(require 'semantic/ctxt) (require 'texinfo) -(eval-when-compile - (require 'semantic/db) - (require 'semantic/db-find) - (require 'semantic/ctxt) - (require 'semantic/find) - (require 'semantic/doc)) - (defvar ede-minor-mode) (declare-function lookup-words "ispell") (declare-function ede-current-project "ede") @@ -451,6 +445,7 @@ that start with that symbol." (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. @@ -687,4 +682,9 @@ If TAG is nil, it is derived from the deffn under POINT." (provide 'semantic/texi) +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-load-name: "semantic/texi" +;; End: + ;;; semantic/texi.el ends here diff --git a/lisp/cedet/semantic/util-modes.el b/lisp/cedet/semantic/util-modes.el index c9a0faefe6c..744d37ff189 100644 --- a/lisp/cedet/semantic/util-modes.el +++ b/lisp/cedet/semantic/util-modes.el @@ -221,11 +221,11 @@ minor mode is enabled." (setq semantic-highlight-edits-mode nil) (error "Buffer %s was not set up for parsing" (buffer-name))) - (semantic-make-local-hook 'semantic-edits-new-change-hooks) - (add-hook 'semantic-edits-new-change-hooks + (semantic-make-local-hook 'semantic-edits-new-change-functions) + (add-hook 'semantic-edits-new-change-functions 'semantic-highlight-edits-new-change-hook-fcn nil t)) ;; Remove hooks - (remove-hook 'semantic-edits-new-change-hooks + (remove-hook 'semantic-edits-new-change-functions 'semantic-highlight-edits-new-change-hook-fcn t))) (semantic-add-minor-mode 'semantic-highlight-edits-mode @@ -460,8 +460,8 @@ minor mode is enabled." (append mode-line-modified '(semantic-show-parser-state-string)))) ;; Add hooks - (semantic-make-local-hook 'semantic-edits-new-change-hooks) - (add-hook 'semantic-edits-new-change-hooks + (semantic-make-local-hook 'semantic-edits-new-change-functions) + (add-hook 'semantic-edits-new-change-functions 'semantic-show-parser-state-marker nil t) (semantic-make-local-hook 'semantic-edits-incremental-reparse-failed-hook) (add-hook 'semantic-edits-incremental-reparse-failed-hook @@ -491,7 +491,7 @@ minor mode is enabled." (setq mode-line-modified (delq 'semantic-show-parser-state-string mode-line-modified)) ;; Remove hooks - (remove-hook 'semantic-edits-new-change-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) diff --git a/lisp/cedet/semantic/util.el b/lisp/cedet/semantic/util.el index 1cc4d898a34..f3d30f6af5c 100644 --- a/lisp/cedet/semantic/util.el +++ b/lisp/cedet/semantic/util.el @@ -280,7 +280,7 @@ If TAG is not specified, use the tag at point." semantic-parser-name semantic-parse-tree-state semantic-lex-analyzer - semantic-lex-reset-hooks + semantic-lex-reset-functions semantic-lex-syntax-modifications ))) (dolist (V vars) @@ -298,6 +298,7 @@ If TAG is not specified, use the tag at point." 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))) diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el index 30dbafaa6cc..388c8f332a4 100644 --- a/lisp/cedet/semantic/wisent/comp.el +++ b/lisp/cedet/semantic/wisent/comp.el @@ -134,8 +134,11 @@ If optional LEFT is non-nil insert spaces on left." ;;;; ------------------------ (defconst wisent-BITS-PER-WORD - (let ((i 1)) - (while (not (zerop (lsh 1 i))) + (let ((i 1) + (do-shift (if (boundp 'most-positive-fixnum) + (lambda (i) (lsh most-positive-fixnum (- i))) + (lambda (i) (lsh 1 i))))) + (while (not (zerop (funcall do-shift i))) (setq i (1+ i))) i)) @@ -3539,4 +3542,12 @@ See also `wisent-compile-grammar' for more details on AUTOMATON." (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) +;; End: + ;;; semantic/wisent/comp.el ends here diff --git a/lisp/cedet/semantic/wisent/grammar.el b/lisp/cedet/semantic/wisent/grammar.el new file mode 100644 index 00000000000..6fa52dc2adc --- /dev/null +++ b/lisp/cedet/semantic/wisent/grammar.el @@ -0,0 +1,526 @@ +;;; semantic/wisent/grammar.el --- Wisent's input grammar mode + +;; Copyright (C) 2002-2012 Free Software Foundation, Inc. +;; +;; Author: David Ponce <david@dponce.com> +;; Maintainer: 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 <http://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)))) + +(defun wisent-grammar-parsetable-builder () + "Return the value of the parser table." + `(progn + ;; Ensure that the grammar [byte-]compiler is available. + (eval-when-compile (require 'semantic/wisent/comp)) + (wisent-compile-grammar + ',(wisent-grammar-grammar) + ',(semantic-grammar-start)))) + +(defun wisent-grammar-setupcode-builder () + "Return the parser setup code." + (format + "(semantic-install-function-overrides\n\ + '((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\ + (semantic-make-local-hook 'wisent-discarding-token-functions)\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) + (semantic-install-function-overrides + '((grammar-parsetable-builder . wisent-grammar-parsetable-builder) + (grammar-setupcode-builder . wisent-grammar-setupcode-builder)))) + +(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 <http://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 +;; +;; http://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))) + +(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\\'")) + (let ((packagename + (condition-case err + (with-current-buffer (find-file-noselect f) + (semantic-grammar-create-package)) + (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 (progn (string-match ".*/\\(.*\\)" packagename) (match-string 1 packagename))) + copyright-end) + ;; Touch up the generated parsers for Emacs integration. + (with-temp-buffer + (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/" + f ".") + (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") + (re-search-forward ";;; \\(.*\\) ends here") + (replace-match packagename nil nil nil 1) + (delete-trailing-whitespace) + (write-region nil nil (expand-file-name filename)))))))) + +(provide 'semantic/wisent/grammar) + +;;; semantic/wisent/grammar.el ends here diff --git a/lisp/cedet/semantic/wisent/java-tags.el b/lisp/cedet/semantic/wisent/java-tags.el index 6bdc2736b1b..a85935ad83b 100644 --- a/lisp/cedet/semantic/wisent/java-tags.el +++ b/lisp/cedet/semantic/wisent/java-tags.el @@ -59,6 +59,7 @@ 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)) @@ -71,8 +72,31 @@ This function override `get-local-variables'." '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 ;;;; @@ -109,6 +133,10 @@ Use the alternate LALR(1) parser." (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)) diff --git a/lisp/cedet/semantic/wisent/javascript.el b/lisp/cedet/semantic/wisent/javascript.el index 8ed83e87bce..610df0edc86 100644 --- a/lisp/cedet/semantic/wisent/javascript.el +++ b/lisp/cedet/semantic/wisent/javascript.el @@ -51,8 +51,8 @@ to this variable NAME." 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 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)) @@ -70,10 +70,56 @@ This function overrides `get-local-variables'." ;; Does javascript have identifiable local variables? nil) +(define-mode-local-override semantic-tag-protection javascript-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 javascript-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 javascript-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) + symlist tmp end) + (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-" (point-at-bol) t) + (beginning-of-line)) + (setq tmp (buffer-substring-no-properties (point) end)) + (if (string-match "\\(.+\\)\\." tmp) + (setq symlist (list (match-string 1 tmp) + (substring tmp (1+ (match-end 1)) (length tmp)))) + (setq symlist (list tmp)))))))) + ;;; Setup Function ;; -;; This sets up the javascript parser +;; Since javascript-mode is an alias for js-mode, let it inherit all +;; the overrides. +(define-child-mode js-mode javascript-mode) ;; Since javascript-mode is an alias for js-mode, let it inherit all ;; the overrides. diff --git a/lisp/cedet/semantic/wisent/javat-wy.el b/lisp/cedet/semantic/wisent/javat-wy.el Binary files differindex 1f0a480d554..01f80d3c598 100644 --- a/lisp/cedet/semantic/wisent/javat-wy.el +++ b/lisp/cedet/semantic/wisent/javat-wy.el diff --git a/lisp/cedet/semantic/wisent/js-wy.el b/lisp/cedet/semantic/wisent/js-wy.el index 05346b02c8d..92c5aa6b0d2 100644 --- a/lisp/cedet/semantic/wisent/js-wy.el +++ b/lisp/cedet/semantic/wisent/js-wy.el @@ -60,6 +60,7 @@ ;;; Code: (require 'semantic/lex) +(eval-when-compile (require 'semantic/bovine)) ;;; Prologue ;; @@ -416,6 +417,29 @@ ;;; Analyzers +;; +(define-lex-block-type-analyzer wisent-javascript-jv-wy--<block>-block-analyzer + "block analyzer for <block> tokens." + "\\s(\\|\\s)" + '((("(" OPEN_PARENTHESIS PAREN_BLOCK) + ("{" START_BLOCK BRACE_BLOCK) + ("[" OPEN_SQ_BRACKETS BRACK_BLOCK)) + (")" CLOSE_PARENTHESIS) + ("}" END_BLOCK) + ("]" CLOSE_SQ_BRACKETS)) + ) + +(define-lex-regex-type-analyzer wisent-javascript-jv-wy--<symbol>-regexp-analyzer + "regexp analyzer for <symbol> tokens." + "\\(\\sw\\|\\s_\\)+" + nil + 'VARIABLE) + +(define-lex-regex-type-analyzer wisent-javascript-jv-wy--<number>-regexp-analyzer + "regexp analyzer for <number> tokens." + semantic-lex-number-expression + nil + 'NUMBER) (define-lex-string-type-analyzer wisent-javascript-jv-wy--<punctuation>-string-analyzer "string analyzer for <punctuation> tokens." @@ -462,29 +486,6 @@ (ASSIGN_SYMBOL . "=")) 'punctuation) -(define-lex-block-type-analyzer wisent-javascript-jv-wy--<block>-block-analyzer - "block analyzer for <block> tokens." - "\\s(\\|\\s)" - '((("(" OPEN_PARENTHESIS PAREN_BLOCK) - ("{" START_BLOCK BRACE_BLOCK) - ("[" OPEN_SQ_BRACKETS BRACK_BLOCK)) - (")" CLOSE_PARENTHESIS) - ("}" END_BLOCK) - ("]" CLOSE_SQ_BRACKETS)) - ) - -(define-lex-regex-type-analyzer wisent-javascript-jv-wy--<symbol>-regexp-analyzer - "regexp analyzer for <symbol> tokens." - "\\(\\sw\\|\\s_\\)+" - nil - 'VARIABLE) - -(define-lex-regex-type-analyzer wisent-javascript-jv-wy--<number>-regexp-analyzer - "regexp analyzer for <number> tokens." - semantic-lex-number-expression - nil - 'NUMBER) - (define-lex-sexp-type-analyzer wisent-javascript-jv-wy--<string>-sexp-analyzer "sexp analyzer for <string> tokens." "\\s\"" diff --git a/lisp/cedet/semantic/wisent/python-wy.el b/lisp/cedet/semantic/wisent/python-wy.el index e8229dcd9ea..d215a4b2414 100644 --- a/lisp/cedet/semantic/wisent/python-wy.el +++ b/lisp/cedet/semantic/wisent/python-wy.el @@ -1,6 +1,6 @@ ;;; semantic/wisent/python-wy.el --- Generated parser support file -;; Copyright (C) 2002-2004, 2007, 2010-2012 Free Software Foundation, Inc. +;; Copyright (C) 2002-2012 Free Software Foundation, Inc. ;; Copyright (c) 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, ;; 2009, 2010 Python Software Foundation; All Rights Reserved @@ -77,9 +77,12 @@ ;;; Code: (require 'semantic/lex) +(eval-when-compile (require 'semantic/bovine)) ;;; Prologue ;; +(declare-function wisent-python-reconstitute-function-tag "semantic/wisent/python") +(declare-function wisent-python-reconstitute-class-tag "semantic/wisent/python") ;;; Declarations ;; @@ -114,8 +117,10 @@ ("return" . RETURN) ("try" . TRY) ("while" . WHILE) + ("with" . WITH) ("yield" . YIELD)) '(("yield" summary "Create a generator function") + ("with" summary "Start statement with an associated context object") ("while" summary "Start a 'while' loop") ("try" summary "Start of statements protected by exception handlers") ("return" summary "Return from a function") @@ -156,6 +161,7 @@ ("string" (STRING_LITERAL)) ("punctuation" + (AT . "@") (BACKQUOTE . "`") (ASSIGN . "=") (COMMA . ",") @@ -226,7 +232,7 @@ (eval-when-compile (require 'semantic/wisent/comp)) (wisent-compile-grammar - '((BACKSLASH NEWLINE INDENT DEDENT INDENT_BLOCK PAREN_BLOCK BRACE_BLOCK BRACK_BLOCK LPAREN RPAREN LBRACE RBRACE LBRACK RBRACK LTLTEQ GTGTEQ EXPEQ DIVDIVEQ DIVDIV LTLT GTGT EXPONENT EQ GE LE PLUSEQ MINUSEQ MULTEQ DIVEQ MODEQ AMPEQ OREQ HATEQ LTGT NE HAT LT GT AMP MULT DIV MOD PLUS MINUS PERIOD TILDE BAR COLON SEMICOLON COMMA ASSIGN BACKQUOTE STRING_LITERAL NUMBER_LITERAL NAME AND AS ASSERT BREAK CLASS CONTINUE DEF DEL ELIF ELSE EXCEPT EXEC FINALLY FOR FROM GLOBAL IF IMPORT IN IS LAMBDA NOT OR PASS PRINT RAISE RETURN TRY WHILE YIELD) + '((BACKSLASH NEWLINE INDENT DEDENT INDENT_BLOCK PAREN_BLOCK BRACE_BLOCK BRACK_BLOCK LPAREN RPAREN LBRACE RBRACE LBRACK RBRACK LTLTEQ GTGTEQ EXPEQ DIVDIVEQ DIVDIV LTLT GTGT EXPONENT EQ GE LE PLUSEQ MINUSEQ MULTEQ DIVEQ MODEQ AMPEQ OREQ HATEQ LTGT NE HAT LT GT AMP MULT DIV MOD PLUS MINUS PERIOD TILDE BAR COLON SEMICOLON COMMA ASSIGN BACKQUOTE AT STRING_LITERAL NUMBER_LITERAL NAME AND AS ASSERT BREAK CLASS CONTINUE DEF DEL ELIF ELSE EXCEPT EXEC FINALLY FOR FROM GLOBAL IF IMPORT IN IS LAMBDA NOT OR PASS PRINT RAISE RETURN TRY WHILE WITH YIELD) nil (goal ((NEWLINE)) @@ -364,8 +370,10 @@ (wisent-raw-tag (semantic-tag-new-include $2 nil)))) (dotted_as_name_list - ((dotted_as_name)) - ((dotted_as_name_list COMMA dotted_as_name))) + ((dotted_as_name_list COMMA dotted_as_name) + (cons $3 $1)) + ((dotted_as_name) + (list $1))) (star_or_import_as_name_list ((MULT) nil) @@ -417,6 +425,7 @@ ((while_stmt)) ((for_stmt)) ((try_stmt)) + ((with_stmt)) ((funcdef)) ((class_declaration))) (if_stmt @@ -476,10 +485,36 @@ (nil) ((test zero_or_one_comma_test) nil)) + (with_stmt + ((WITH test COLON suite) + (wisent-raw-tag + (semantic-tag-new-code $1 nil))) + ((WITH test with_var COLON suite) + (wisent-raw-tag + (semantic-tag-new-code $1 nil)))) + (with_var + ((AS expr) + nil)) + (decorator + ((AT dotted_name varargslist_opt NEWLINE) + (wisent-raw-tag + (semantic-tag-new-function $2 "decorator" $3)))) + (decorators + ((decorator) + (list $1)) + ((decorator decorators) + (cons $1 $2))) (funcdef ((DEF NAME function_parameter_list COLON suite) - (wisent-raw-tag - (semantic-tag-new-function $2 nil $3)))) + (wisent-python-reconstitute-function-tag + (wisent-raw-tag + (semantic-tag-new-function $2 nil $3)) + $5)) + ((decorators DEF NAME function_parameter_list COLON suite) + (wisent-python-reconstitute-function-tag + (wisent-raw-tag + (semantic-tag-new-function $3 nil $4 :decorators $1)) + $6))) (function_parameter_list ((PAREN_BLOCK) (let @@ -505,9 +540,10 @@ (semantic-tag-new-variable $2 nil nil)))) (class_declaration ((CLASS NAME paren_class_list_opt COLON suite) - (wisent-raw-tag - (semantic-tag-new-type $2 $1 $5 - (cons $3 nil))))) + (wisent-python-reconstitute-class-tag + (wisent-raw-tag + (semantic-tag-new-type $2 $1 $5 + (cons $3 nil)))))) (paren_class_list_opt (nil) ((paren_class_list))) @@ -726,7 +762,7 @@ ;;; Analyzers - +;; (define-lex-block-type-analyzer wisent-python-wy--<block>-block-analyzer "block analyzer for <block> tokens." "\\s(\\|\\s)" @@ -738,10 +774,23 @@ ("]" RBRACK)) ) +(define-lex-regex-type-analyzer wisent-python-wy--<symbol>-regexp-analyzer + "regexp analyzer for <symbol> tokens." + "\\(\\sw\\|\\s_\\)+" + nil + 'NAME) + +(define-lex-regex-type-analyzer wisent-python-wy--<number>-regexp-analyzer + "regexp analyzer for <number> tokens." + semantic-lex-number-expression + nil + 'NUMBER_LITERAL) + (define-lex-string-type-analyzer wisent-python-wy--<punctuation>-string-analyzer "string analyzer for <punctuation> tokens." "\\(\\s.\\|\\s$\\|\\s'\\)+" - '((BACKQUOTE . "`") + '((AT . "@") + (BACKQUOTE . "`") (ASSIGN . "=") (COMMA . ",") (SEMICOLON . ";") @@ -781,18 +830,6 @@ (LTLTEQ . "<<=")) 'punctuation) -(define-lex-regex-type-analyzer wisent-python-wy--<symbol>-regexp-analyzer - "regexp analyzer for <symbol> tokens." - "\\(\\sw\\|\\s_\\)+" - nil - 'NAME) - -(define-lex-regex-type-analyzer wisent-python-wy--<number>-regexp-analyzer - "regexp analyzer for <number> tokens." - semantic-lex-number-expression - nil - 'NUMBER_LITERAL) - (define-lex-keyword-type-analyzer wisent-python-wy--<keyword>-keyword-analyzer "keyword analyzer for <keyword> tokens." "\\(\\sw\\|\\s_\\)+") diff --git a/lisp/cedet/semantic/wisent/python.el b/lisp/cedet/semantic/wisent/python.el index fef22b16995..89c0499b7da 100644 --- a/lisp/cedet/semantic/wisent/python.el +++ b/lisp/cedet/semantic/wisent/python.el @@ -28,27 +28,81 @@ ;;; Code: +(require 'rx) + +;; Try to load python support, but fail silently since it is only used +;; for optional functionality +(require 'python nil t) + (require 'semantic/wisent) (require 'semantic/wisent/python-wy) +(require 'semantic/find) (require 'semantic/dep) (require 'semantic/ctxt) +(eval-when-compile + (require 'cl)) + +;;; 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.") ;;; Lexical analysis ;; ;; Python strings are delimited by either single quotes or double -;; quotes, e.g., "I'm a string" and 'I too am s string'. +;; 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-re - (concat (regexp-opt '("r" "u" "ur" "R" "U" "UR" "Ur" "uR") t) - "?['\"]") +(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.") @@ -60,16 +114,46 @@ curly braces." (defsubst wisent-python-forward-string () "Move point at the end of the Python string at point." - (when (looking-at wisent-python-string-re) - ;; skip the prefix - (and (match-end 1) (goto-char (match-end 1))) - ;; skip the quoted part - (cond - ((looking-at "\"\"\"[^\"]") - (search-forward "\"\"\"" nil nil 2)) - ((looking-at "'''[^']") - (search-forward "'''" nil nil 2)) - ((forward-sexp 1))))) + (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' +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. @@ -83,14 +167,14 @@ line ends at the end of the buffer, leave the point there." (progn (cond ;; Skip over python strings. - ((looking-at wisent-python-string-re) + ((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 generic lists and strings. - ((looking-at "\\(\\s(\\|\\s\"\\)") - (forward-sexp 1)) + ;; 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\\") @@ -107,8 +191,8 @@ line ends at the end of the buffer, leave the point there." (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." +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)) @@ -185,17 +269,18 @@ indentation of the current line." ;; 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)))) + ((progn + ;; 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)))) + (= last-pos (point))) ;; If pos did not change, then we must return nil so that ;; other lexical analyzers can be run. - (/= last-pos (point)))))) + nil)))) ;; All the work was done in the above analyzer matching condition. ) @@ -211,7 +296,7 @@ continuation of current line." (define-lex-regex-analyzer wisent-python-lex-string "Detect and create python string tokens." - wisent-python-string-re + wisent-python-string-start-re (semantic-lex-push-token (semantic-lex-token 'STRING_LITERAL @@ -250,9 +335,113 @@ elsewhere on a line outside a string literal." semantic-lex-ignore-comments ;; Signal error on unhandled syntax. semantic-lex-default-action) + + +;;; 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 + (first (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))) + ))) + + ;;; Overridden Semantic API. ;; + (define-mode-local-override semantic-lex python-mode (start end &optional depth length) "Lexically analyze Python code in current buffer. @@ -274,10 +463,27 @@ what remains in the `wisent-python-indent-stack'." To be implemented for Python! For now just return nil." nil) -(defcustom-mode-local-semantic-dependency-system-include-path - python-mode semantic-python-dependency-system-include-path - nil - "The system include path used by Python language.") +;; 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) ;;; Enable Semantic in `python-mode'. ;; @@ -287,13 +493,15 @@ To be implemented for Python! For now just return nil." "Setup buffer for parse." (wisent-python-wy--install-parser) (set (make-local-variable 'parse-sexp-ignore-comments) t) + ;; Give python modes the possibility to overwrite this: + (if (not comment-start-skip) + (set (make-local-variable 'comment-start-skip) "#+\\s-*")) (setq - ;; Character used to separation a parent/child relationship + ;; Character used to separation a parent/child relationship semantic-type-relation-separator-character '(".") semantic-command-separation-character ";" - ;; The following is no more necessary as semantic-lex is overridden - ;; in python-mode. - ;; semantic-lex-analyzer 'wisent-python-lexer + ;; 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 @@ -320,8 +528,56 @@ To be implemented for Python! For now just return nil." (define-child-mode python-3-mode python-mode "Python 3 mode") +;;; 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-match "\\." (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))) + + ;;; Test ;; + (defun wisent-python-lex-buffer () "Run `wisent-python-lexer' on current buffer." (interactive) |