Mercurial > emacs
changeset 104409:560b69982442
semantic.el, semantic-tag.el, semantic-lex.el, semantic-fw.el: Initial
version.
| author | Chong Yidong <cyd@stupidchicken.com> |
|---|---|
| date | Sun, 23 Aug 2009 03:46:01 +0000 |
| parents | e6546ef2442b |
| children | 203567d53c98 |
| files | lisp/cedet/semantic-fw.el lisp/cedet/semantic-lex.el lisp/cedet/semantic-tag.el lisp/cedet/semantic.el |
| diffstat | 4 files changed, 5033 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic-fw.el Sun Aug 23 03:46:01 2009 +0000 @@ -0,0 +1,530 @@ +;;; semantic-fw.el --- Framework for Semantic + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic has several core features shared across it's lex/parse/util +;; stages. This used to clutter semantic.el some. These routines are all +;; simple things that are not parser specific, but aid in making +;; semantic flexible and compatible amongst different Emacs platforms. + +;;; No Requirements. + +;;; Code: +;; +(require 'mode-local) +(require 'eieio) + +;;; Compatibility +;; +(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) + "Blockinig version of `popup-menu'" + (popup-menu menu) + ;; Wait... + (while (popup-up-p) (dispatch-event (next-event)))) + ) + ;; Emacs Bindings + (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) + (defun semantic-event-window (event) + "Extract the window from EVENT." + (car (car (cdr event)))) + ) + +(if (and (not (featurep 'xemacs)) + (>= emacs-major-version 21)) + (defalias 'semantic-make-local-hook 'identity) + (defalias 'semantic-make-local-hook 'make-local-hook) + ) + +(if (featurep 'xemacs) + (defalias 'semantic-mode-line-update 'redraw-modeline) + (defalias 'semantic-mode-line-update '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 useage 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))) + +(defalias 'semantic-compile-warn + (eval-when-compile + (if (fboundp 'byte-compile-warn) + 'byte-compile-warn + 'message))) + +(if (not (fboundp 'string-to-number)) + (defalias 'string-to-number 'string-to-int)) + +;;; 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 + "List of all overlays waiting to be flushed.") + +(defun semantic-cache-data-to-buffer (buffer start end value name &optional lifespan) + "In BUFFER over the region START END, remember VALUE. +NAME specifies a special name that can be searched for later to +recover the cached data with `semantic-get-cache-data'. +LIFESPAN indicates how long the data cache will be remembered. +The default LIFESPAN is 'end-of-command. +Possible Lifespans are: + 'end-of-command - Remove the cache at the end of the currently + executing command. + 'exit-cache-zone - Remove when point leaves the overlay at the + end of the currently executing command." + ;; Check if LIFESPAN is valid before to create any overlay + (or lifespan (setq lifespan 'end-of-command)) + (or (memq lifespan '(end-of-command exit-cache-zone)) + (error "semantic-cache-data-to-buffer: Unknown LIFESPAN: %s" + lifespan)) + (let ((o (semantic-make-overlay start end buffer))) + (semantic-overlay-put o 'cache-name name) + (semantic-overlay-put o 'cached-value value) + (semantic-overlay-put o 'lifespan lifespan) + (setq semantic-cache-data-overlays + (cons o semantic-cache-data-overlays)) + ;;(message "Adding to cache: %s" o) + (add-hook 'post-command-hook 'semantic-cache-data-post-command-hook) + )) + +(defun semantic-cache-data-post-command-hook () + "Flush `semantic-cache-data-overlays' based 'lifespan property. +Remove self from `post-command-hook' if it is empty." + (let ((newcache nil) + (oldcache semantic-cache-data-overlays)) + (while oldcache + (let* ((o (car oldcache)) + (life (semantic-overlay-get o 'lifespan)) + ) + (if (or (eq life 'end-of-command) + (and (eq life 'exit-cache-zone) + (not (member o (semantic-overlays-at (point)))))) + (progn + ;;(message "Removing from cache: %s" o) + (semantic-overlay-delete o) + ) + (setq newcache (cons o newcache)))) + (setq oldcache (cdr oldcache))) + (setq semantic-cache-data-overlays (nreverse newcache))) + + ;; Remove ourselves if we have removed all overlays. + (unless semantic-cache-data-overlays + (remove-hook 'post-command-hook + 'semantic-cache-data-post-command-hook))) + +(defun semantic-get-cache-data (name &optional point) + "Get cached data with NAME from optional POINT." + (save-excursion + (if point (goto-char point)) + (let ((o (semantic-overlays-at (point))) + (ans nil)) + (while (and (not ans) o) + (if (equal (semantic-overlay-get (car o) 'cache-name) name) + (setq ans (car o)) + (setq o (cdr o)))) + (when ans + (semantic-overlay-get ans 'cached-value))))) + +(defun semantic-test-data-cache () + "Test the data cache." + (interactive) + (let ((data '(a b c))) + (save-excursion + (set-buffer (get-buffer-create " *semantic-test-data-cache*")) + (erase-buffer) + (insert "The Moose is Loose") + (goto-char (point-min)) + (semantic-cache-data-to-buffer (current-buffer) (point) (+ (point) 5) + data 'moose 'exit-cache-zone) + (if (equal (semantic-get-cache-data 'moose) data) + (message "Successfully retrieved cached data.") + (error "Failed to retrieve cached data")) + ))) + +;;; Obsoleting various functions & variables +;; +(defun semantic-overload-symbol-from-function (name) + "Return the symbol for overload used by NAME, the defined symbol." + (let ((sym-name (symbol-name name))) + (if (string-match "^semantic-" sym-name) + (intern (substring sym-name (match-end 0))) + name))) + +(defun semantic-alias-obsolete (oldfnalias newfn) + "Make OLDFNALIAS an alias for NEWFN. +Mark OLDFNALIAS as obsolete, such that the byte compiler +will throw a warning when it encounters this symbol." + (defalias oldfnalias newfn) + (make-obsolete oldfnalias newfn) + (when (and (function-overload-p newfn) + (not (overload-obsoleted-by newfn)) + ;; Only throw this warning when byte compiling things. + (boundp 'byte-compile-current-file) + byte-compile-current-file + (not (string-match "cedet" byte-compile-current-file)) + ) + (make-obsolete-overload oldfnalias newfn) + (semantic-compile-warn + "%s: `%s' obsoletes overload `%s'" + byte-compile-current-file + newfn + (semantic-overload-symbol-from-function oldfnalias)) + )) + +(defun semantic-varalias-obsolete (oldvaralias newvar) + "Make OLDVARALIAS an alias for variable NEWVAR. +Mark OLDVARALIAS as obsolete, such that the byte compiler +will throw a warning when it encounters this symbol." + (make-obsolete-variable oldvaralias newvar) + (condition-case nil + (defvaralias oldvaralias newvar) + (error + ;; Only throw this warning when byte compiling things. + (when (and (boundp 'byte-compile-current-file) + byte-compile-current-file) + (semantic-compile-warn + "variable `%s' obsoletes, but isn't alias of `%s'" + newvar oldvaralias) + )))) + +;;; Help debugging +;; +(defmacro semantic-safe (format &rest body) + "Turn into a FORMAT message any error caught during eval of BODY. +Return the value of last BODY form or nil if an error occurred. +FORMAT can have a %s escape which will be replaced with the actual +error message. +If `debug-on-error' is set, errors are not caught, so that you can +debug them. +Avoid using a large BODY since it is duplicated." + ;;(declare (debug t) (indent 1)) + `(if debug-on-error + ;;(let ((inhibit-quit nil)) ,@body) + ;; Note to self: Doing the above screws up the wisent parser. + (progn ,@body) + (condition-case err + (progn ,@body) + (error + (message ,format (format "%S - %s" (current-buffer) + (error-message-string err))) + nil)))) +(put 'semantic-safe 'lisp-indent-function 1) + +;;; Misc utilities +;; +(defsubst semantic-map-buffers (function) + "Run FUNCTION for each Semantic enabled buffer found. +FUNCTION does not have arguments. When FUNCTION is entered +`current-buffer' is a selected Semantic enabled buffer." + (mode-local-map-file-buffers function #'semantic-active-p)) + +(defalias 'semantic-map-mode-buffers + 'mode-local-map-mode-buffers) + +(semantic-alias-obsolete 'semantic-fetch-overload + 'fetch-overload) + +(semantic-alias-obsolete 'define-mode-overload-implementation + 'define-mode-local-override) + +(semantic-alias-obsolete 'semantic-with-mode-bindings + 'with-mode-local) + +(semantic-alias-obsolete 'define-semantic-child-mode + 'define-child-mode) + +(defun semantic-install-function-overrides (overrides &optional transient mode) + "Install the function OVERRIDES in the specified environment. +OVERRIDES must be an alist ((OVERLOAD . FUNCTION) ...) where OVERLOAD +is a symbol identifying an overloadable entry, and FUNCTION is the +function to override it with. +If optional argument TRANSIENT is non-nil, installed overrides can in +turn be overridden by next installation. +If optional argument MODE is non-nil, it must be a major mode symbol. +OVERRIDES will be installed globally for this major mode. If MODE is +nil, OVERRIDES will be installed locally in the current buffer. This +later installation should be done in MODE hook." + (mode-local-bind + ;; Add the semantic- prefix to OVERLOAD short names. + (mapcar + #'(lambda (e) + (let ((name (symbol-name (car e)))) + (if (string-match "^semantic-" name) + e + (cons (intern (format "semantic-%s" name)) (cdr e))))) + overrides) + (list 'constant-flag (not transient) + 'override-flag t) + mode)) + +;;; User Interrupt handling +;; +(defvar semantic-current-input-throw-symbol nil + "The current throw symbol for `semantic-exit-on-input'.") + +(defmacro semantic-exit-on-input (symbol &rest forms) + "Using SYMBOL as an argument to `throw', execute FORMS. +If FORMS includes a call to `semantic-thow-on-input', then +if a user presses any key during execution, this form macro +will exit with the value passed to `semantic-throw-on-input'. +If FORMS completes, then the return value is the same as `progn'." + `(let ((semantic-current-input-throw-symbol ,symbol)) + (catch ,symbol + ,@forms))) +(put 'semantic-exit-on-input 'lisp-indent-function 1) + +(defmacro semantic-throw-on-input (from) + "Exit with `throw' when in `semantic-exit-on-input' on user input. +FROM is an indication of where this function is called from as a value +to pass to `throw'. It is recommended to use the name of the function +calling this one." + `(when (and semantic-current-input-throw-symbol + (or (input-pending-p) (accept-process-output))) + (throw semantic-current-input-throw-symbol ,from))) + +(defun semantic-test-throw-on-input () + "Test that throw on input will work." + (interactive) + (semantic-throw-on-input 'done-die) + (message "Exit Code: %s" + (semantic-exit-on-input 'testing + (let ((inhibit-quit nil) + (message-log-max nil)) + (while t + (message "Looping ... press a key to test") + (semantic-throw-on-input 'test-inner-loop)) + 'exit))) + (when (input-pending-p) + (if (fboundp 'read-event) + (read-event) + (read-char))) + ) + +;;; Special versions of Find File +;; +(defun semantic-find-file-noselect (file &optional nowarn rawfile wildcards) + "Call `find-file-noselect' with various features turned off. +Use this when referencing a file that will be soon deleted. +FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'" + (let* ((recentf-exclude '( (lambda (f) t) )) + ;; This is a brave statement. Don't waste time loading in + ;; lots of modes. Especially decoration mode can waste a lot + ;; of time for a buffer we intend to kill. + (semantic-init-hooks nil) + ;; This disables the part of EDE that asks questions + (ede-auto-add-method 'never) + ;; Ask font-lock to not colorize these buffers, nor to + ;; whine about it either. + (font-lock-maximum-size 0) + (font-lock-verbose 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))) + ;; ... or eval variables + (enable-local-eval nil) + ) + (if (featurep 'xemacs) + (find-file-noselect file nowarn rawfile) + (find-file-noselect file nowarn rawfile wildcards)) + )) + + +;;; Editor goodies ;-) +;; +(defconst semantic-fw-font-lock-keywords + (eval-when-compile + (let* ( + ;; Variable declarations + (vl nil) + (kv (if vl (regexp-opt vl t) "")) + ;; Function declarations + (vf '( + "define-lex" + "define-lex-analyzer" + "define-lex-block-analyzer" + "define-lex-regex-analyzer" + "define-lex-spp-macro-declaration-analyzer" + "define-lex-spp-macro-undeclaration-analyzer" + "define-lex-spp-include-analyzer" + "define-lex-simple-regex-analyzer" + "define-lex-keyword-type-analyzer" + "define-lex-sexp-type-analyzer" + "define-lex-regex-type-analyzer" + "define-lex-string-type-analyzer" + "define-lex-block-type-analyzer" + ;;"define-mode-overload-implementation" + ;;"define-semantic-child-mode" + "define-semantic-idle-service" + "define-semantic-decoration-style" + "define-wisent-lexer" + "semantic-alias-obsolete" + "semantic-varalias-obsolete" + "semantic-make-obsolete-overload" + "defcustom-mode-local-semantic-dependency-system-include-path" + )) + (kf (if vf (regexp-opt vf t) "")) + ;; Regexp depths + (kv-depth (if kv (regexp-opt-depth kv) nil)) + (kf-depth (if kf (regexp-opt-depth kf) nil)) + ) + `((,(concat + ;; Declarative things + "(\\(" kv "\\|" kf "\\)" + ;; Whitespaces & names + "\\>[ \t]*\\(\\sw+\\)?[ \t]*\\(\\sw+\\)?" + ) + (1 font-lock-keyword-face) + (,(+ 1 kv-depth kf-depth 1) + (cond ((match-beginning 2) + font-lock-type-face) + ((match-beginning ,(+ 1 kv-depth 1)) + font-lock-function-name-face) + ) + nil t) + (,(+ 1 kv-depth kf-depth 1 1) + (cond ((match-beginning 2) + font-lock-variable-name-face) + ) + nil t))) + )) + "Highlighted Semantic keywords.") + +;; (when (fboundp 'font-lock-add-keywords) +;; (font-lock-add-keywords 'emacs-lisp-mode +;; semantic-fw-font-lock-keywords)) + +;;; Interfacing with edebug +;; +(defun semantic-fw-add-edebug-spec () + (def-edebug-spec semantic-exit-on-input 'def-body)) + +(add-hook 'edebug-setup-hook 'semantic-fw-add-edebug-spec) + +(provide 'semantic-fw) + +;;; semantic-fw.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic-lex.el Sun Aug 23 03:46:01 2009 +0000 @@ -0,0 +1,2089 @@ +;;; semantic-lex.el --- Lexical Analyzer builder + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file handles the creation of lexical analyzers for different +;; languages in Emacs Lisp. The purpose of a lexical analyzer is to +;; convert a buffer into a list of lexical tokens. Each token +;; contains the token class (such as 'number, 'symbol, 'IF, etc) and +;; the location in the buffer it was found. Optionally, a token also +;; contains a string representing what is at the designated buffer +;; location. +;; +;; Tokens are pushed onto a token stream, which is basically a list of +;; all the lexical tokens from the analyzed region. The token stream +;; is then handed to the grammar which parsers the file. +;; +;;; How it works +;; +;; Each analyzer specifies a condition and forms. These conditions +;; and forms are assembled into a function by `define-lex' that does +;; the lexical analysis. +;; +;; In the lexical analyzer created with `define-lex', each condition +;; is tested for a given point. When the conditin is true, the forms +;; run. +;; +;; The forms can push a lexical token onto the token stream. The +;; analyzer forms also must move the current analyzer point. If the +;; analyzer point is moved without pushing a token, then tne matched +;; syntax is effectively ignored, or skipped. +;; +;; Thus, starting at the beginning of a region to be analyzed, each +;; condition is tested. One will match, and a lexical token might be +;; pushed, and the point is moved to the end of the lexical token +;; identified. At the new position, the process occurs again until +;; the end of the specified region is reached. +;; +;;; How to use semantic-lex +;; +;; To create a lexer for a language, use the `define-lex' macro. +;; +;; The `define-lex' macro accepts a list of lexical analyzers. Each +;; analyzer is created with `define-lex-analyzer', or one of the +;; derivitive macros. A single analyzer defines a regular expression +;; to match text in a buffer, and a short segment of code to create +;; one lexical token. +;; +;; Each analyzer has a NAME, DOC, a CONDITION, and possibly some +;; FORMS. The NAME is the name used in `define-lex'. The DOC +;; describes what the analyzer should do. +;; +;; The CONDITION evaluates the text at the current point in the +;; current buffer. If CONDITION is true, then the FORMS will be +;; executed. +;; +;; The purpose of the FORMS is to push new lexical tokens onto the +;; list of tokens for the current buffer, and to move point after the +;; matched text. +;; +;; Some macros for creating one analyzer are: +;; +;; define-lex-analyzer - A generic analyzer associating any style of +;; condition to forms. +;; define-lex-regex-analyzer - Matches a regular expression. +;; define-lex-simple-regex-analyzer - Matches a regular expressions, +;; and pushes the match. +;; define-lex-block-analyzer - Matches list syntax, and defines +;; handles open/close delimiters. +;; +;; These macros are used by the grammar compiler when lexical +;; information is specified in a grammar: +;; define-lex- * -type-analyzer - Matches syntax specified in +;; a grammar, and pushes one token for it. The * would +;; be `sexp' for things like lists or strings, and +;; `string' for things that need to match some special +;; string, such as "\\." where a literal match is needed. +;; +;;; Lexical Tables +;; +;; There are tables of different symbols managed in semantic-lex.el. +;; They are: +;; +;; Lexical keyword table - A Table of symbols declared in a grammar +;; file with the %keyword declaration. +;; Keywords are used by `semantic-lex-symbol-or-keyword' +;; to create lexical tokens based on the keyword. +;; +;; Lexical type table - A table of symbols declared in a grammer +;; file with the %type declaration. +;; The grammar compiler uses the type table to create new +;; lexical analyzers. These analyzers are then used to when +;; a new lexical analyzer is made for a language. +;; +;;; Lexical Types +;; +;; A lexical type defines a kind of lexical analyzer that will be +;; automatically generated from a grammar file based on some +;; predetermined attributes. For now these two attributes are +;; recognized : +;; +;; * matchdatatype : define the kind of lexical analyzer. That is : +;; +;; - regexp : define a regexp analyzer (see +;; `define-lex-regex-type-analyzer') +;; +;; - string : define a string analyzer (see +;; `define-lex-string-type-analyzer') +;; +;; - block : define a block type analyzer (see +;; `define-lex-block-type-analyzer') +;; +;; - sexp : define a sexp analyzer (see +;; `define-lex-sexp-type-analyzer') +;; +;; - keyword : define a keyword analyzer (see +;; `define-lex-keyword-type-analyzer') +;; +;; * syntax : define the syntax that matches a syntactic +;; expression. When syntax is matched the corresponding type +;; analyzer is entered and the resulting match data will be +;; interpreted based on the kind of analyzer (see matchdatatype +;; above). +;; +;; The following lexical types are predefined : +;; +;; +-------------+---------------+--------------------------------+ +;; | type | matchdatatype | syntax | +;; +-------------+---------------+--------------------------------+ +;; | punctuation | string | "\\(\\s.\\|\\s$\\|\\s'\\)+" | +;; | keyword | keyword | "\\(\\sw\\|\\s_\\)+" | +;; | symbol | regexp | "\\(\\sw\\|\\s_\\)+" | +;; | string | sexp | "\\s\"" | +;; | number | regexp | semantic-lex-number-expression | +;; | block | block | "\\s(\\|\\s)" | +;; +-------------+---------------+--------------------------------+ +;; +;; In a grammar you must use a %type expression to automatically generate +;; the corresponding analyzers of that type. +;; +;; Here is an example to auto-generate punctuation analyzers +;; with 'matchdatatype and 'syntax predefined (see table above) +;; +;; %type <punctuation> ;; will auto-generate this kind of analyzers +;; +;; It is equivalent to write : +;; +;; %type <punctuation> syntax "\\(\\s.\\|\\s$\\|\\s'\\)+" matchdatatype string +;; +;; ;; Some punctuations based on the type defines above +;; +;; %token <punctuation> NOT "!" +;; %token <punctuation> NOTEQ "!=" +;; %token <punctuation> MOD "%" +;; %token <punctuation> MODEQ "%=" +;; + +;;; On the Semantic 1.x lexer +;; +;; In semantic 1.x, the lexical analyzer was an all purpose routine. +;; To boost efficiency, the analyzer is now a series of routines that +;; are constructed at build time into a single routine. This will +;; eliminate unneeded if statements to speed the lexer. + +(require 'semantic-fw) +;;; Code: + +;;; Compatibility +;; +(eval-and-compile + (if (not (fboundp 'with-syntax-table)) + +;; Copied from Emacs 21 for compatibility with released Emacses. +(defmacro with-syntax-table (table &rest body) + "With syntax table of current buffer set to a copy of TABLE, evaluate BODY. +The syntax table of the current buffer is saved, BODY is evaluated, and the +saved table is restored, even in case of an abnormal exit. +Value is what BODY returns." + (let ((old-table (make-symbol "table")) + (old-buffer (make-symbol "buffer"))) + `(let ((,old-table (syntax-table)) + (,old-buffer (current-buffer))) + (unwind-protect + (progn + (set-syntax-table (copy-syntax-table ,table)) + ,@body) + (save-current-buffer + (set-buffer ,old-buffer) + (set-syntax-table ,old-table)))))) + +)) + +;;; Semantic 2.x lexical analysis +;; +(defun semantic-lex-map-symbols (fun table &optional property) + "Call function FUN on every symbol in TABLE. +If optional PROPERTY is non-nil, call FUN only on every symbol which +as a PROPERTY value. FUN receives a symbol as argument." + (if (arrayp table) + (mapatoms + #'(lambda (symbol) + (if (or (null property) (get symbol property)) + (funcall fun symbol))) + table))) + +;;; Lexical keyword table handling. +;; +;; These keywords are keywords defined for using in a grammar with the +;; %keyword declaration, and are not keywords used in Emacs Lisp. + +(defvar semantic-flex-keywords-obarray nil + "Buffer local keyword obarray for the lexical analyzer. +These keywords are matched explicitly, and converted into special symbols.") +(make-variable-buffer-local 'semantic-flex-keywords-obarray) + +(defmacro semantic-lex-keyword-invalid (name) + "Signal that NAME is an invalid keyword name." + `(signal 'wrong-type-argument '(semantic-lex-keyword-p ,name))) + +(defsubst semantic-lex-keyword-symbol (name) + "Return keyword symbol with NAME or nil if not found." + (and (arrayp semantic-flex-keywords-obarray) + (stringp name) + (intern-soft name semantic-flex-keywords-obarray))) + +(defsubst semantic-lex-keyword-p (name) + "Return non-nil if a keyword with NAME exists in the keyword table. +Return nil otherwise." + (and (setq name (semantic-lex-keyword-symbol name)) + (symbol-value name))) + +(defsubst semantic-lex-keyword-set (name value) + "Set value of keyword with NAME to VALUE and return VALUE." + (set (intern name semantic-flex-keywords-obarray) value)) + +(defsubst semantic-lex-keyword-value (name) + "Return value of keyword with NAME. +Signal an error if a keyword with NAME does not exist." + (let ((keyword (semantic-lex-keyword-symbol name))) + (if keyword + (symbol-value keyword) + (semantic-lex-keyword-invalid name)))) + +(defsubst semantic-lex-keyword-put (name property value) + "For keyword with NAME, set its PROPERTY to VALUE." + (let ((keyword (semantic-lex-keyword-symbol name))) + (if keyword + (put keyword property value) + (semantic-lex-keyword-invalid name)))) + +(defsubst semantic-lex-keyword-get (name property) + "For keyword with NAME, return its PROPERTY value." + (let ((keyword (semantic-lex-keyword-symbol name))) + (if keyword + (get keyword property) + (semantic-lex-keyword-invalid name)))) + +(defun semantic-lex-make-keyword-table (specs &optional propspecs) + "Convert keyword SPECS into an obarray and return it. +SPECS must be a list of (NAME . TOKSYM) elements, where: + + NAME is the name of the keyword symbol to define. + TOKSYM is the lexical token symbol of that keyword. + +If optional argument PROPSPECS is non nil, then interpret it, and +apply those properties. +PROPSPECS must be a list of (NAME PROPERTY VALUE) elements." + ;; Create the symbol hash table + (let ((semantic-flex-keywords-obarray (make-vector 13 0)) + spec) + ;; fill it with stuff + (while specs + (setq spec (car specs) + specs (cdr specs)) + (semantic-lex-keyword-set (car spec) (cdr spec))) + ;; Apply all properties + (while propspecs + (setq spec (car propspecs) + propspecs (cdr propspecs)) + (semantic-lex-keyword-put (car spec) (nth 1 spec) (nth 2 spec))) + semantic-flex-keywords-obarray)) + +(defsubst semantic-lex-map-keywords (fun &optional property) + "Call function FUN on every lexical keyword. +If optional PROPERTY is non-nil, call FUN only on every keyword which +as a PROPERTY value. FUN receives a lexical keyword as argument." + (semantic-lex-map-symbols + fun semantic-flex-keywords-obarray property)) + +(defun semantic-lex-keywords (&optional property) + "Return a list of lexical keywords. +If optional PROPERTY is non-nil, return only keywords which have a +PROPERTY set." + (let (keywords) + (semantic-lex-map-keywords + #'(lambda (symbol) (setq keywords (cons symbol keywords))) + property) + keywords)) + +;;; Type table handling. +;; +;; The lexical type table manages types that occur in a grammar file +;; with the %type declaration. Types represent different syntaxes. +;; See code for `semantic-lex-preset-default-types' for the classic +;; types of syntax. +(defvar semantic-lex-types-obarray nil + "Buffer local types obarray for the lexical analyzer.") +(make-variable-buffer-local 'semantic-lex-types-obarray) + +(defmacro semantic-lex-type-invalid (type) + "Signal that TYPE is an invalid lexical type name." + `(signal 'wrong-type-argument '(semantic-lex-type-p ,type))) + +(defsubst semantic-lex-type-symbol (type) + "Return symbol with TYPE or nil if not found." + (and (arrayp semantic-lex-types-obarray) + (stringp type) + (intern-soft type semantic-lex-types-obarray))) + +(defsubst semantic-lex-type-p (type) + "Return non-nil if a symbol with TYPE name exists." + (and (setq type (semantic-lex-type-symbol type)) + (symbol-value type))) + +(defsubst semantic-lex-type-set (type value) + "Set value of symbol with TYPE name to VALUE and return VALUE." + (set (intern type semantic-lex-types-obarray) value)) + +(defsubst semantic-lex-type-value (type &optional noerror) + "Return value of symbol with TYPE name. +If optional argument NOERROR is non-nil return nil if a symbol with +TYPE name does not exist. Otherwise signal an error." + (let ((sym (semantic-lex-type-symbol type))) + (if sym + (symbol-value sym) + (unless noerror + (semantic-lex-type-invalid type))))) + +(defsubst semantic-lex-type-put (type property value &optional add) + "For symbol with TYPE name, set its PROPERTY to VALUE. +If optional argument ADD is non-nil, create a new symbol with TYPE +name if it does not already exist. Otherwise signal an error." + (let ((sym (semantic-lex-type-symbol type))) + (unless sym + (or add (semantic-lex-type-invalid type)) + (semantic-lex-type-set type nil) + (setq sym (semantic-lex-type-symbol type))) + (put sym property value))) + +(defsubst semantic-lex-type-get (type property &optional noerror) + "For symbol with TYPE name, return its PROPERTY value. +If optional argument NOERROR is non-nil return nil if a symbol with +TYPE name does not exist. Otherwise signal an error." + (let ((sym (semantic-lex-type-symbol type))) + (if sym + (get sym property) + (unless noerror + (semantic-lex-type-invalid type))))) + +(defun semantic-lex-preset-default-types () + "Install useful default properties for well known types." + (semantic-lex-type-put "punctuation" 'matchdatatype 'string t) + (semantic-lex-type-put "punctuation" 'syntax "\\(\\s.\\|\\s$\\|\\s'\\)+") + (semantic-lex-type-put "keyword" 'matchdatatype 'keyword t) + (semantic-lex-type-put "keyword" 'syntax "\\(\\sw\\|\\s_\\)+") + (semantic-lex-type-put "symbol" 'matchdatatype 'regexp t) + (semantic-lex-type-put "symbol" 'syntax "\\(\\sw\\|\\s_\\)+") + (semantic-lex-type-put "string" 'matchdatatype 'sexp t) + (semantic-lex-type-put "string" 'syntax "\\s\"") + (semantic-lex-type-put "number" 'matchdatatype 'regexp t) + (semantic-lex-type-put "number" 'syntax 'semantic-lex-number-expression) + (semantic-lex-type-put "block" 'matchdatatype 'block t) + (semantic-lex-type-put "block" 'syntax "\\s(\\|\\s)") + ) + +(defun semantic-lex-make-type-table (specs &optional propspecs) + "Convert type SPECS into an obarray and return it. +SPECS must be a list of (TYPE . TOKENS) elements, where: + + TYPE is the name of the type symbol to define. + TOKENS is an list of (TOKSYM . MATCHER) elements, where: + + TOKSYM is any lexical token symbol. + MATCHER is a string or regexp a text must match to be a such + lexical token. + +If optional argument PROPSPECS is non nil, then interpret it, and +apply those properties. +PROPSPECS must be a list of (TYPE PROPERTY VALUE)." + ;; Create the symbol hash table + (let* ((semantic-lex-types-obarray (make-vector 13 0)) + spec type tokens token alist default) + ;; fill it with stuff + (while specs + (setq spec (car specs) + specs (cdr specs) + type (car spec) + tokens (cdr spec) + default nil + alist nil) + (while tokens + (setq token (car tokens) + tokens (cdr tokens)) + (if (cdr token) + (setq alist (cons token alist)) + (setq token (car token)) + (if default + (message + "*Warning* default value of <%s> tokens changed to %S, was %S" + type default token)) + (setq default token))) + ;; Ensure the default matching spec is the first one. + (semantic-lex-type-set type (cons default (nreverse alist)))) + ;; Install useful default types & properties + (semantic-lex-preset-default-types) + ;; Apply all properties + (while propspecs + (setq spec (car propspecs) + propspecs (cdr propspecs)) + ;; Create the type if necessary. + (semantic-lex-type-put (car spec) (nth 1 spec) (nth 2 spec) t)) + semantic-lex-types-obarray)) + +(defsubst semantic-lex-map-types (fun &optional property) + "Call function FUN on every lexical type. +If optional PROPERTY is non-nil, call FUN only on every type symbol +which as a PROPERTY value. FUN receives a type symbol as argument." + (semantic-lex-map-symbols + fun semantic-lex-types-obarray property)) + +(defun semantic-lex-types (&optional property) + "Return a list of lexical type symbols. +If optional PROPERTY is non-nil, return only type symbols which have +PROPERTY set." + (let (types) + (semantic-lex-map-types + #'(lambda (symbol) (setq types (cons symbol types))) + property) + types)) + +;;; Lexical Analyzer framework settings +;; + +(defvar semantic-lex-analyzer 'semantic-flex + "The lexical analyzer used for a given buffer. +See `semantic-lex' for documentation. +For compatibility with Semantic 1.x it defaults to `semantic-flex'.") +(make-variable-buffer-local 'semantic-lex-analyzer) + +(defvar semantic-lex-tokens + '( + (bol) + (charquote) + (close-paren) + (comment) + (newline) + (open-paren) + (punctuation) + (semantic-list) + (string) + (symbol) + (whitespace) + ) + "An alist of of semantic token types. +As of December 2001 (semantic 1.4beta13), this variable is not used in +any code. The only use is to refer to the doc-string from elsewhere. + +The key to this alist is the symbol representing token type that +\\[semantic-flex] returns. These are + + - bol: Empty string matching a beginning of line. + This token is produced with + `semantic-lex-beginning-of-line'. + + - charquote: String sequences that match `\\s\\+' regexp. + This token is produced with `semantic-lex-charquote'. + + - close-paren: Characters that match `\\s)' regexp. + These are typically `)', `}', `]', etc. + This token is produced with + `semantic-lex-close-paren'. + + - comment: A comment chunk. These token types are not + produced by default. + This token is produced with `semantic-lex-comments'. + Comments are ignored with `semantic-lex-ignore-comments'. + Comments are treated as whitespace with + `semantic-lex-comments-as-whitespace'. + + - newline Characters matching `\\s-*\\(\n\\|\\s>\\)' regexp. + This token is produced with `semantic-lex-newline'. + + - open-paren: Characters that match `\\s(' regexp. + These are typically `(', `{', `[', etc. + If `semantic-lex-paren-or-list' is used, + then `open-paren' is not usually generated unless + the `depth' argument to \\[semantic-lex] is + greater than 0. + This token is always produced if the analyzer + `semantic-lex-open-paren' is used. + + - punctuation: Characters matching `{\\(\\s.\\|\\s$\\|\\s'\\)' + regexp. + This token is produced with `semantic-lex-punctuation'. + Always specify this analyzer after the comment + analyzer. + + - semantic-list: String delimited by matching parenthesis, braces, + etc. that the lexer skipped over, because the + `depth' parameter to \\[semantic-flex] was not high + enough. + This token is produced with `semantic-lex-paren-or-list'. + + - string: Quoted strings, i.e., string sequences that start + and end with characters matching `\\s\"' + regexp. The lexer relies on @code{forward-sexp} to + find the matching end. + This token is produced with `semantic-lex-string'. + + - symbol: String sequences that match `\\(\\sw\\|\\s_\\)+' + regexp. + This token is produced with + `semantic-lex-symbol-or-keyword'. Always add this analyzer + after `semantic-lex-number', or other analyzers that + match its regular expression. + + - whitespace: Characters that match `\\s-+' regexp. + This token is produced with `semantic-lex-whitespace'.") + +(defvar semantic-lex-syntax-modifications nil + "Changes to the syntax table for this buffer. +These changes are active only while the buffer is being flexed. +This is a list where each element has the form: + (CHAR CLASS) +CHAR is the char passed to `modify-syntax-entry', +and CLASS is the string also passed to `modify-syntax-entry' to define +what syntax class CHAR has.") +(make-variable-buffer-local 'semantic-lex-syntax-modifications) + +(defvar semantic-lex-syntax-table nil + "Syntax table used by lexical analysis. +See also `semantic-lex-syntax-modifications'.") +(make-variable-buffer-local 'semantic-lex-syntax-table) + +(defvar semantic-lex-comment-regex nil + "Regular expression for identifying comment start during lexical analysis. +This may be automatically set when semantic initializes in a mode, but +may need to be overriden for some special languages.") +(make-variable-buffer-local 'semantic-lex-comment-regex) + +(defvar semantic-lex-number-expression + ;; This expression was written by David Ponce for Java, and copied + ;; here for C and any other similar language. + (eval-when-compile + (concat "\\(" + "\\<[0-9]+[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>" + "\\|" + "\\<[0-9]+[.][eE][-+]?[0-9]+[fFdD]?\\>" + "\\|" + "\\<[0-9]+[.][fFdD]\\>" + "\\|" + "\\<[0-9]+[.]" + "\\|" + "[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>" + "\\|" + "\\<[0-9]+[eE][-+]?[0-9]+[fFdD]?\\>" + "\\|" + "\\<0[xX][0-9a-fA-F]+[lL]?\\>" + "\\|" + "\\<[0-9]+[lLfFdD]?\\>" + "\\)" + )) + "Regular expression for matching a number. +If this value is nil, no number extraction is done during lex. +This expression tries to match C and Java like numbers. + +DECIMAL_LITERAL: + [1-9][0-9]* + ; +HEX_LITERAL: + 0[xX][0-9a-fA-F]+ + ; +OCTAL_LITERAL: + 0[0-7]* + ; +INTEGER_LITERAL: + <DECIMAL_LITERAL>[lL]? + | <HEX_LITERAL>[lL]? + | <OCTAL_LITERAL>[lL]? + ; +EXPONENT: + [eE][+-]?[09]+ + ; +FLOATING_POINT_LITERAL: + [0-9]+[.][0-9]*<EXPONENT>?[fFdD]? + | [.][0-9]+<EXPONENT>?[fFdD]? + | [0-9]+<EXPONENT>[fFdD]? + | [0-9]+<EXPONENT>?[fFdD] + ;") +(make-variable-buffer-local 'semantic-lex-number-expression) + +(defvar semantic-lex-depth 0 + "Default lexing depth. +This specifies how many lists to create tokens in.") +(make-variable-buffer-local 'semantic-lex-depth) + +(defvar semantic-lex-unterminated-syntax-end-function + (lambda (syntax syntax-start lex-end) lex-end) + "Function called when unterminated syntax is encountered. +This should be set to one function. That function should take three +parameters. The SYNTAX, or type of syntax which is unterminated. +SYNTAX-START where the broken syntax begins. +LEX-END is where the lexical analysis was asked to end. +This function can be used for languages that can intelligently fix up +broken syntax, or the exit lexical analysis via `throw' or `signal' +when finding unterminated syntax.") + +;;; Interactive testing commands + +(defun semantic-lex-test (arg) + "Test the semantic lexer in the current buffer. +If universal argument ARG, then try the whole buffer." + (interactive "P") + (let* ((start (current-time)) + (result (semantic-lex + (if arg (point-min) (point)) + (point-max))) + (end (current-time))) + (message "Elapsed Time: %.2f seconds." + (semantic-elapsed-time start end)) + (pop-to-buffer "*Lexer Output*") + (require 'pp) + (erase-buffer) + (insert (pp-to-string result)) + (goto-char (point-min)) + )) + +(defun semantic-lex-test-full-depth (arg) + "Test the semantic lexer in the current buffer parsing through lists. +Usually the lexer parses +If universal argument ARG, then try the whole buffer." + (interactive "P") + (let* ((start (current-time)) + (result (semantic-lex + (if arg (point-min) (point)) + (point-max) + 100)) + (end (current-time))) + (message "Elapsed Time: %.2f seconds." + (semantic-elapsed-time start end)) + (pop-to-buffer "*Lexer Output*") + (require 'pp) + (erase-buffer) + (insert (pp-to-string result)) + (goto-char (point-min)) + )) + +(defun semantic-lex-test-region (beg end) + "Test the semantic lexer in the current buffer. +Analyze the area between BEG and END." + (interactive "r") + (let ((result (semantic-lex beg end))) + (pop-to-buffer "*Lexer Output*") + (require 'pp) + (erase-buffer) + (insert (pp-to-string result)) + (goto-char (point-min)) + )) + +(defvar semantic-lex-debug nil + "When non-nil, debug the local lexical analyzer.") + +(defun semantic-lex-debug (arg) + "Debug the semantic lexer in the current buffer. +Argument ARG specifies of the analyze the whole buffer, or start at point. +While engaged, each token identified by the lexer will be highlighted +in the target buffer A description of the current token will be +displayed in the minibuffer. Press SPC to move to the next lexical token." + (interactive "P") + (require 'semantic-debug) + (let ((semantic-lex-debug t)) + (semantic-lex-test arg))) + +(defun semantic-lex-highlight-token (token) + "Highlight the lexical TOKEN. +TOKEN is a lexical token with a START And END position. +Return the overlay." + (let ((o (semantic-make-overlay (semantic-lex-token-start token) + (semantic-lex-token-end token)))) + (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. +;; +;; A lexical analyzer is created from a list of individual analyzers. +;; Each individual analyzer specifies a single match, and code that +;; goes with it. +;; +;; Creation of an analyzer assembles these analyzers into a new function +;; with the behaviors of all the individual analyzers. +;; +(defmacro semantic-lex-one-token (analyzers) + "Calculate one token from the current buffer at point. +Uses locally bound variables from `define-lex'. +Argument ANALYZERS is the list of analyzers being used." + (cons 'cond (mapcar #'symbol-value analyzers))) + +(defvar semantic-lex-end-point nil + "The end point as tracked through lexical functions.") + +(defvar semantic-lex-current-depth nil + "The current depth as tracked through lexical functions.") + +(defvar semantic-lex-maximum-depth nil + "The maximum depth of parenthisis as tracked through lexical functions.") + +(defvar semantic-lex-token-stream nil + "The current token stream we are collecting.") + +(defvar semantic-lex-analysis-bounds nil + "The bounds of the current analysis.") + +(defvar semantic-lex-block-streams nil + "Streams of tokens inside collapsed blocks. +This is an alist of (ANCHOR . STREAM) elements where ANCHOR is the +start position of the block, and STREAM is the list of tokens in that +block.") + +(defvar semantic-lex-reset-hooks nil + "List of hooks major-modes use to reset lexical analyzers. +Hooks are called with START and END values for the current lexical pass. +Should be set with `add-hook'specifying a LOCAL option.") + +;; Stack of nested blocks. +(defvar semantic-lex-block-stack nil) +;;(defvar semantic-lex-timeout 5 +;; "*Number of sections of lexing before giving up.") + +(defmacro define-lex (name doc &rest analyzers) + "Create a new lexical analyzer with NAME. +DOC is a documentation string describing this analyzer. +ANALYZERS are small code snippets of analyzers to use when +building the new NAMED analyzer. Only use analyzers which +are written to be used in `define-lex'. +Each analyzer should be an analyzer created with `define-lex-analyzer'. +Note: The order in which analyzers are listed is important. +If two analyzers can match the same text, it is important to order the +analyzers so that the one you want to match first occurs first. For +example, it is good to put a numbe analyzer in front of a symbol +analyzer which might mistake a number for as a symbol." + `(defun ,name (start end &optional depth length) + ,(concat doc "\nSee `semantic-lex' for more information.") + ;; Make sure the state of block parsing starts over. + (setq semantic-lex-block-streams nil) + ;; Allow specialty reset items. + (run-hook-with-args 'semantic-lex-reset-hooks start end) + ;; Lexing state. + (let* (;(starttime (current-time)) + (starting-position (point)) + (semantic-lex-token-stream nil) + (semantic-lex-block-stack nil) + (tmp-start start) + (semantic-lex-end-point start) + (semantic-lex-current-depth 0) + ;; Use the default depth when not specified. + (semantic-lex-maximum-depth + (or depth semantic-lex-depth)) + ;; Bounds needed for unterminated syntax + (semantic-lex-analysis-bounds (cons start end)) + ;; This entry prevents text properties from + ;; confusing our lexical analysis. See Emacs 22 (CVS) + ;; version of C++ mode with template hack text properties. + (parse-sexp-lookup-properties nil) + ) + ;; Maybe REMOVE THIS LATER. + ;; Trying to find incremental parser bug. + (when (> end (point-max)) + (error ,(format "%s: end (%%d) > point-max (%%d)" name) + end (point-max))) + (with-syntax-table semantic-lex-syntax-table + (goto-char start) + (while (and (< (point) end) + (or (not length) + (<= (length semantic-lex-token-stream) length))) + (semantic-lex-one-token ,analyzers) + (when (eq semantic-lex-end-point tmp-start) + (error ,(format "%s: endless loop at %%d, after %%S" name) + tmp-start (car semantic-lex-token-stream))) + (setq tmp-start semantic-lex-end-point) + (goto-char semantic-lex-end-point) + ;;(when (> (semantic-elapsed-time starttime (current-time)) + ;; semantic-lex-timeout) + ;; (error "Timeout during lex at char %d" (point))) + (semantic-throw-on-input 'lex) + (semantic-lex-debug-break (car semantic-lex-token-stream)) + )) + ;; Check that there is no unterminated block. + (when semantic-lex-block-stack + (let* ((last (pop semantic-lex-block-stack)) + (blk last)) + (while blk + (message + ,(format "%s: `%%s' block from %%S is unterminated" name) + (car blk) (cadr blk)) + (setq blk (pop semantic-lex-block-stack))) + (semantic-lex-unterminated-syntax-detected (car last)))) + ;; Return to where we started. + ;; Do not wrap in protective stuff so that if there is an error + ;; thrown, the user knows where. + (goto-char starting-position) + ;; Return the token stream + (nreverse semantic-lex-token-stream)))) + +;;; Collapsed block tokens delimited by any tokens. +;; +(defun semantic-lex-start-block (syntax) + "Mark the last read token as the beginning of a SYNTAX block." + (if (or (not semantic-lex-maximum-depth) + (< semantic-lex-current-depth semantic-lex-maximum-depth)) + (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)) + (push (list syntax (car semantic-lex-token-stream)) + semantic-lex-block-stack))) + +(defun semantic-lex-end-block (syntax) + "Process the end of a previously marked SYNTAX block. +That is, collapse the tokens inside that block, including the +beginning and end of block tokens, into a high level block token of +class SYNTAX. +The token at beginning of block is the one marked by a previous call +to `semantic-lex-start-block'. The current token is the end of block. +The collapsed tokens are saved in `semantic-lex-block-streams'." + (if (null semantic-lex-block-stack) + (setq semantic-lex-current-depth (1- semantic-lex-current-depth)) + (let* ((stream semantic-lex-token-stream) + (blk (pop semantic-lex-block-stack)) + (bstream (cdr blk)) + (first (car bstream)) + (last (pop stream)) ;; The current token mark the EOBLK + tok) + (if (not (eq (car blk) syntax)) + ;; SYNTAX doesn't match the syntax of the current block in + ;; the stack. So we encountered the end of the SYNTAX block + ;; before the end of the current one in the stack which is + ;; signaled unterminated. + (semantic-lex-unterminated-syntax-detected (car blk)) + ;; Move tokens found inside the block from the main stream + ;; into a separate block stream. + (while (and stream (not (eq (setq tok (pop stream)) first))) + (push tok bstream)) + ;; The token marked as beginning of block was not encountered. + ;; This should not happen! + (or (eq tok first) + (error "Token %S not found at beginning of block `%s'" + first syntax)) + ;; Save the block stream for future reuse, to avoid to redo + ;; the lexical analysis of the block content! + ;; Anchor the block stream with its start position, so we can + ;; use: (cdr (assq start semantic-lex-block-streams)) to + ;; quickly retrieve the lexical stream associated to a block. + (setcar blk (semantic-lex-token-start first)) + (setcdr blk (nreverse bstream)) + (push blk semantic-lex-block-streams) + ;; In the main stream, replace the tokens inside the block by + ;; a high level block token of class SYNTAX. + (setq semantic-lex-token-stream stream) + (semantic-lex-push-token + (semantic-lex-token + syntax (car blk) (semantic-lex-token-end last))) + )))) + +;;; Lexical token API +;; +;; Functions for accessing parts of a token. Use these functions +;; instead of accessing the list structure directly because the +;; contents of the lexical may change. +;; +(defmacro semantic-lex-token (symbol start end &optional str) + "Create a lexical token. +SYMBOL is a symbol representing the class of syntax found. +START and END define the bounds of the token in the current buffer. +Optional STR is the string for the token iff the the bounds +in the buffer do not cover the string they represent. (As from +macro expansion.)" + ;; This if statement checks the existance of a STR argument at + ;; compile time, where STR is some symbol or constant. If the + ;; variable STr (runtime) is nil, this will make an incorrect decision. + ;; + ;; It is like this to maintain the original speed of the compiled + ;; code. + (if str + `(cons ,symbol (cons ,str (cons ,start ,end))) + `(cons ,symbol (cons ,start ,end)))) + +(defun semantic-lex-token-p (thing) + "Return non-nil if THING is a semantic lex token. +This is an exhaustively robust check." + (and (consp thing) + (symbolp (car thing)) + (or (and (numberp (nth 1 thing)) + (numberp (nthcdr 2 thing))) + (and (stringp (nth 1 thing)) + (numberp (nth 2 thing)) + (numberp (nthcdr 3 thing))) + )) + ) + +(defun semantic-lex-token-with-text-p (thing) + "Return non-nil if THING is a semantic lex token. +This is an exhaustively robust check." + (and (consp thing) + (symbolp (car thing)) + (= (length thing) 4) + (stringp (nth 1 thing)) + (numberp (nth 2 thing)) + (numberp (nth 3 thing))) + ) + +(defun semantic-lex-token-without-text-p (thing) + "Return non-nil if THING is a semantic lex token. +This is an exhaustively robust check." + (and (consp thing) + (symbolp (car thing)) + (= (length thing) 3) + (numberp (nth 1 thing)) + (numberp (nth 2 thing))) + ) + +(defun semantic-lex-expand-block-specs (specs) + "Expand block specifications SPECS into a Lisp form. +SPECS is a list of (BLOCK BEGIN END) elements where BLOCK, BEGIN, and +END are token class symbols that indicate to produce one collapsed +BLOCK token from tokens found between BEGIN and END ones. +BLOCK must be a non-nil symbol, and at least one of the BEGIN or END +symbols must be non-nil too. +When BEGIN is non-nil, generate a call to `semantic-lex-start-block' +when a BEGIN token class is encountered. +When END is non-nil, generate a call to `semantic-lex-end-block' when +an END token class is encountered." + (let ((class (make-symbol "class")) + (form nil)) + (dolist (spec specs) + (when (car spec) + (when (nth 1 spec) + (push `((eq ',(nth 1 spec) ,class) + (semantic-lex-start-block ',(car spec))) + form)) + (when (nth 2 spec) + (push `((eq ',(nth 2 spec) ,class) + (semantic-lex-end-block ',(car spec))) + form)))) + (when form + `((let ((,class (semantic-lex-token-class + (car semantic-lex-token-stream)))) + (cond ,@(nreverse form)))) + ))) + +(defmacro semantic-lex-push-token (token &rest blockspecs) + "Push TOKEN in the lexical analyzer token stream. +Return the lexical analysis current end point. +If optional arguments BLOCKSPECS is non-nil, it specifies to process +collapsed block tokens. See `semantic-lex-expand-block-specs' for +more details. +This macro should only be called within the bounds of +`define-lex-analyzer'. It changes the values of the lexical analyzer +variables `token-stream' and `semantic-lex-end-point'. If you need to +move `semantic-lex-end-point' somewhere else, just modify this +variable after calling `semantic-lex-push-token'." + `(progn + (push ,token semantic-lex-token-stream) + ,@(semantic-lex-expand-block-specs blockspecs) + (setq semantic-lex-end-point + (semantic-lex-token-end (car semantic-lex-token-stream))) + )) + +(defsubst semantic-lex-token-class (token) + "Fetch the class of the lexical token TOKEN. +See also the function `semantic-lex-token'." + (car token)) + +(defsubst semantic-lex-token-bounds (token) + "Fetch the start and end locations of the lexical token TOKEN. +Return a pair (START . END)." + (if (not (numberp (car (cdr token)))) + (cdr (cdr token)) + (cdr token))) + +(defsubst semantic-lex-token-start (token) + "Fetch the start position of the lexical token TOKEN. +See also the function `semantic-lex-token'." + (car (semantic-lex-token-bounds token))) + +(defsubst semantic-lex-token-end (token) + "Fetch the end position of the lexical token TOKEN. +See also the function `semantic-lex-token'." + (cdr (semantic-lex-token-bounds token))) + +(defsubst semantic-lex-token-text (token) + "Fetch the text associated with the lexical token TOKEN. +See also the function `semantic-lex-token'." + (if (stringp (car (cdr token))) + (car (cdr token)) + (buffer-substring-no-properties + (semantic-lex-token-start token) + (semantic-lex-token-end token)))) + +(defun semantic-lex-init () + "Initialize any lexical state for this buffer." + (unless semantic-lex-comment-regex + (setq semantic-lex-comment-regex + (if comment-start-skip + (concat "\\(\\s<\\|" comment-start-skip "\\)") + "\\(\\s<\\)"))) + ;; Setup the lexer syntax-table + (setq semantic-lex-syntax-table (copy-syntax-table (syntax-table))) + (dolist (mod semantic-lex-syntax-modifications) + (modify-syntax-entry + (car mod) (nth 1 mod) semantic-lex-syntax-table))) + +(define-overloadable-function semantic-lex (start end &optional depth length) + "Lexically analyze text in the current buffer between START and END. +Optional argument DEPTH indicates at what level to scan over entire +lists. The last argument, LENGTH specifies that `semantic-lex' +should only return LENGTH tokens. The return value is a token stream. +Each element is a list, such of the form + (symbol start-expression . end-expression) +where SYMBOL denotes the token type. +See `semantic-lex-tokens' variable for details on token types. END +does not mark the end of the text scanned, only the end of the +beginning of text scanned. Thus, if a string extends past END, the +end of the return token will be larger than END. To truly restrict +scanning, use `narrow-to-region'." + (funcall semantic-lex-analyzer start end depth length)) + +(defsubst semantic-lex-buffer (&optional depth) + "Lex the current buffer. +Optional argument DEPTH is the depth to scan into lists." + (semantic-lex (point-min) (point-max) depth)) + +(defsubst semantic-lex-list (semlist depth) + "Lex the body of SEMLIST to DEPTH." + (semantic-lex (semantic-lex-token-start semlist) + (semantic-lex-token-end semlist) + depth)) + +;;; Analyzer creation macros +;; +;; An individual analyzer is a condition and code that goes with it. +;; +;; Created analyzers become variables with the code associated with them +;; as the symbol value. These analyzers are assembled into a lexer +;; to create new lexical analyzers. +;; +(defsubst semantic-lex-unterminated-syntax-detected (syntax) + "Inside a lexical analyzer, use this when unterminated syntax was found. +Argument SYNTAX indicates the type of syntax that is unterminated. +The job of this function is to move (point) to a new logical location +so that analysis can continue, if possible." + (goto-char + (funcall semantic-lex-unterminated-syntax-end-function + syntax + (car semantic-lex-analysis-bounds) + (cdr semantic-lex-analysis-bounds) + )) + (setq semantic-lex-end-point (point))) + +(defcustom semantic-lex-debug-analyzers nil + "Non nil means to debug analyzers with syntax protection. +Only in effect if `debug-on-error' is also non-nil." + :group 'semantic + :type 'boolean) + +(defmacro semantic-lex-unterminated-syntax-protection (syntax &rest forms) + "For SYNTAX, execute FORMS with protection for unterminated syntax. +If FORMS throws an error, treat this as a syntax problem, and +execute the unterminated syntax code. FORMS should return a position. +Irreguardless of an error, the cursor should be moved to the end of +the desired syntax, and a position returned. +If `debug-on-error' is set, errors are not caught, so that you can +debug them. +Avoid using a large FORMS since it is duplicated." + `(if (and debug-on-error semantic-lex-debug-analyzers) + (progn ,@forms) + (condition-case nil + (progn ,@forms) + (error + (semantic-lex-unterminated-syntax-detected ,syntax))))) +(put 'semantic-lex-unterminated-syntax-protection + 'lisp-indent-function 1) + +(defmacro define-lex-analyzer (name doc condition &rest forms) + "Create a single lexical analyzer NAME with DOC. +When an analyzer is called, the current buffer and point are +positioned in a buffer at the location to be analyzed. +CONDITION is an expression which returns t if FORMS should be run. +Within the bounds of CONDITION and FORMS, the use of backquote +can be used to evaluate expressions at compile time. +While forms are running, the following variables will be locally bound: + `semantic-lex-analysis-bounds' - The bounds of the current analysis. + of the form (START . END) + `semantic-lex-maximum-depth' - The maximum depth of semantic-list + for the current analysis. + `semantic-lex-current-depth' - The current depth of `semantic-list' that has + been decended. + `semantic-lex-end-point' - End Point after match. + Analyzers should set this to a buffer location if their + match string does not represent the end of the matched text. + `semantic-lex-token-stream' - The token list being collected. + Add new lexical tokens to this list. +Proper action in FORMS is to move the value of `semantic-lex-end-point' to +after the location of the analyzed entry, and to add any discovered tokens +at the beginning of `semantic-lex-token-stream'. +This can be done by using `semantic-lex-push-token'." + `(eval-and-compile + (defvar ,name nil ,doc) + (defun ,name nil) + ;; Do this part separately so that re-evaluation rebuilds this code. + (setq ,name '(,condition ,@forms)) + ;; Build a single lexical analyzer function, so the doc for + ;; function help is automatically provided, and perhaps the + ;; function could be useful for testing and debugging one + ;; analyzer. + (fset ',name (lambda () ,doc + (let ((semantic-lex-token-stream nil) + (semantic-lex-end-point (point)) + (semantic-lex-analysis-bounds + (cons (point) (point-max))) + (semantic-lex-current-depth 0) + (semantic-lex-maximum-depth + semantic-lex-depth) + ) + (when ,condition ,@forms) + semantic-lex-token-stream))) + )) + +(defmacro define-lex-regex-analyzer (name doc regexp &rest forms) + "Create a lexical analyzer with NAME and DOC that will match REGEXP. +FORMS are evaluated upon a successful match. +See `define-lex-analyzer' for more about analyzers." + `(define-lex-analyzer ,name + ,doc + (looking-at ,regexp) + ,@forms + )) + +(defmacro define-lex-simple-regex-analyzer (name doc regexp toksym + &optional index + &rest forms) + "Create a lexical analyzer with NAME and DOC that match REGEXP. +TOKSYM is the symbol to use when creating a semantic lexical token. +INDEX is the index into the match that defines the bounds of the token. +Index should be a plain integer, and not specified in the macro as an +expression. +FORMS are evaluated upon a successful match BEFORE the new token is +created. It is valid to ignore FORMS. +See `define-lex-analyzer' for more about analyzers." + `(define-lex-analyzer ,name + ,doc + (looking-at ,regexp) + ,@forms + (semantic-lex-push-token + (semantic-lex-token ,toksym + (match-beginning ,(or index 0)) + (match-end ,(or index 0)))) + )) + +(defmacro define-lex-block-analyzer (name doc spec1 &rest specs) + "Create a lexical analyzer NAME for paired delimiters blocks. +It detects a paired delimiters block or the corresponding open or +close delimiter depending on the value of the variable +`semantic-lex-current-depth'. DOC is the documentation string of the lexical +analyzer. SPEC1 and SPECS specify the token symbols and open, close +delimiters used. Each SPEC has the form: + +\(BLOCK-SYM (OPEN-DELIM OPEN-SYM) (CLOSE-DELIM CLOSE-SYM)) + +where BLOCK-SYM is the symbol returned in a block token. OPEN-DELIM +and CLOSE-DELIM are respectively the open and close delimiters +identifying a block. OPEN-SYM and CLOSE-SYM are respectively the +symbols returned in open and close tokens." + (let ((specs (cons spec1 specs)) + spec open olist clist) + (while specs + (setq spec (car specs) + specs (cdr specs) + open (nth 1 spec) + ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...) + olist (cons (list (car open) (cadr open) (car spec)) olist) + ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...) + clist (cons (nth 2 spec) clist))) + `(define-lex-analyzer ,name + ,doc + (and + (looking-at "\\(\\s(\\|\\s)\\)") + (let ((text (match-string 0)) match) + (cond + ((setq match (assoc text ',olist)) + (if (or (not semantic-lex-maximum-depth) + (< semantic-lex-current-depth semantic-lex-maximum-depth)) + (progn + (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)) + (semantic-lex-push-token + (semantic-lex-token + (nth 1 match) + (match-beginning 0) (match-end 0)))) + (semantic-lex-push-token + (semantic-lex-token + (nth 2 match) + (match-beginning 0) + (save-excursion + (semantic-lex-unterminated-syntax-protection (nth 2 match) + (forward-list 1) + (point))) + )) + )) + ((setq match (assoc text ',clist)) + (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 +;; +;; Pre-defined common analyzers. +;; +(define-lex-analyzer semantic-lex-default-action + "The default action when no other lexical actions match text. +This action will just throw an error." + t + (error "Unmatched Text during Lexical Analysis")) + +(define-lex-analyzer semantic-lex-beginning-of-line + "Detect and create a beginning of line token (BOL)." + (and (bolp) + ;; Just insert a (bol N . N) token in the token stream, + ;; without moving the point. N is the point at the + ;; beginning of line. + (semantic-lex-push-token (semantic-lex-token 'bol (point) (point))) + nil) ;; CONTINUE + ;; We identify and add the BOL token onto the stream, but since + ;; semantic-lex-end-point doesn't move, we always fail CONDITION, and have no + ;; FORMS body. + nil) + +(define-lex-simple-regex-analyzer semantic-lex-newline + "Detect and create newline tokens." + "\\s-*\\(\n\\|\\s>\\)" 'newline 1) + +(define-lex-regex-analyzer semantic-lex-newline-as-whitespace + "Detect and create newline tokens. +Use this ONLY if newlines are not whitespace characters (such as when +they are comment end characters) AND when you want whitespace tokens." + "\\s-*\\(\n\\|\\s>\\)" + ;; Language wants whitespaces. Create a token for it. + (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) + 'whitespace) + ;; Merge whitespace tokens together if they are adjacent. Two + ;; whitespace tokens may be sperated by a comment which is not in + ;; the token stream. + (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream)) + (match-end 0)) + (semantic-lex-push-token + (semantic-lex-token + 'whitespace (match-beginning 0) (match-end 0))))) + +(define-lex-regex-analyzer semantic-lex-ignore-newline + "Detect and ignore newline tokens. +Use this ONLY if newlines are not whitespace characters (such as when +they are comment end characters)." + "\\s-*\\(\n\\|\\s>\\)" + (setq semantic-lex-end-point (match-end 0))) + +(define-lex-regex-analyzer semantic-lex-whitespace + "Detect and create whitespace tokens." + ;; catch whitespace when needed + "\\s-+" + ;; Language wants whitespaces. Create a token for it. + (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) + 'whitespace) + ;; Merge whitespace tokens together if they are adjacent. Two + ;; whitespace tokens may be sperated by a comment which is not in + ;; the token stream. + (progn + (setq semantic-lex-end-point (match-end 0)) + (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream)) + semantic-lex-end-point)) + (semantic-lex-push-token + (semantic-lex-token + 'whitespace (match-beginning 0) (match-end 0))))) + +(define-lex-regex-analyzer semantic-lex-ignore-whitespace + "Detect and skip over whitespace tokens." + ;; catch whitespace when needed + "\\s-+" + ;; Skip over the detected whitespace, do not create a token for it. + (setq semantic-lex-end-point (match-end 0))) + +(define-lex-simple-regex-analyzer semantic-lex-number + "Detect and create number tokens. +See `semantic-lex-number-expression' for details on matching numbers, +and number formats." + semantic-lex-number-expression 'number) + +(define-lex-regex-analyzer semantic-lex-symbol-or-keyword + "Detect and create symbol and keyword tokens." + "\\(\\sw\\|\\s_\\)+" + (semantic-lex-push-token + (semantic-lex-token + (or (semantic-lex-keyword-p (match-string 0)) 'symbol) + (match-beginning 0) (match-end 0)))) + +(define-lex-simple-regex-analyzer semantic-lex-charquote + "Detect and create charquote tokens." + ;; Character quoting characters (ie, \n as newline) + "\\s\\+" 'charquote) + +(define-lex-simple-regex-analyzer semantic-lex-punctuation + "Detect and create punctuation tokens." + "\\(\\s.\\|\\s$\\|\\s'\\)" 'punctuation) + +(define-lex-analyzer semantic-lex-punctuation-type + "Detect and create a punctuation type token. +Recognized punctuations are defined in the current table of lexical +types, as the value of the `punctuation' token type." + (and (looking-at "\\(\\s.\\|\\s$\\|\\s'\\)+") + (let* ((key (match-string 0)) + (pos (match-beginning 0)) + (end (match-end 0)) + (len (- end pos)) + (lst (semantic-lex-type-value "punctuation" t)) + (def (car lst)) ;; default lexical symbol or nil + (lst (cdr lst)) ;; alist of (LEX-SYM . PUNCT-STRING) + (elt nil)) + (if lst + ;; Starting with the longest one, search if the + ;; punctuation string is defined for this language. + (while (and (> len 0) (not (setq elt (rassoc key lst)))) + (setq len (1- len) + key (substring key 0 len)))) + (if elt ;; Return the punctuation token found + (semantic-lex-push-token + (semantic-lex-token (car elt) pos (+ pos len))) + (if def ;; Return a default generic token + (semantic-lex-push-token + (semantic-lex-token def pos end)) + ;; Nothing match + ))))) + +(define-lex-regex-analyzer semantic-lex-paren-or-list + "Detect open parenthesis. +Return either a paren token or a semantic list token depending on +`semantic-lex-current-depth'." + "\\s(" + (if (or (not semantic-lex-maximum-depth) + (< semantic-lex-current-depth semantic-lex-maximum-depth)) + (progn + (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)) + (semantic-lex-push-token + (semantic-lex-token + 'open-paren (match-beginning 0) (match-end 0)))) + (semantic-lex-push-token + (semantic-lex-token + 'semantic-list (match-beginning 0) + (save-excursion + (semantic-lex-unterminated-syntax-protection 'semantic-list + (forward-list 1) + (point)) + ))) + )) + +(define-lex-simple-regex-analyzer semantic-lex-open-paren + "Detect and create an open parenthisis token." + "\\s(" 'open-paren 0 (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))) + +(define-lex-simple-regex-analyzer semantic-lex-close-paren + "Detect and create a close paren token." + "\\s)" 'close-paren 0 (setq semantic-lex-current-depth (1- semantic-lex-current-depth))) + +(define-lex-regex-analyzer semantic-lex-string + "Detect and create a string token." + "\\s\"" + ;; Zing to the end of this string. + (semantic-lex-push-token + (semantic-lex-token + 'string (point) + (save-excursion + (semantic-lex-unterminated-syntax-protection 'string + (forward-sexp 1) + (point)) + )))) + +(define-lex-regex-analyzer semantic-lex-comments + "Detect and create a comment token." + semantic-lex-comment-regex + (save-excursion + (forward-comment 1) + ;; Generate newline token if enabled + (if (bolp) (backward-char 1)) + (setq semantic-lex-end-point (point)) + ;; Language wants comments or want them as whitespaces, + ;; link them together. + (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) 'comment) + (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream)) + semantic-lex-end-point) + (semantic-lex-push-token + (semantic-lex-token + 'comment (match-beginning 0) semantic-lex-end-point))))) + +(define-lex-regex-analyzer semantic-lex-comments-as-whitespace + "Detect comments and create a whitespace token." + semantic-lex-comment-regex + (save-excursion + (forward-comment 1) + ;; Generate newline token if enabled + (if (bolp) (backward-char 1)) + (setq semantic-lex-end-point (point)) + ;; Language wants comments or want them as whitespaces, + ;; link them together. + (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) 'whitespace) + (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream)) + semantic-lex-end-point) + (semantic-lex-push-token + (semantic-lex-token + 'whitespace (match-beginning 0) semantic-lex-end-point))))) + +(define-lex-regex-analyzer semantic-lex-ignore-comments + "Detect and create a comment token." + semantic-lex-comment-regex + (let ((comment-start-point (point))) + (forward-comment 1) + (if (eq (point) comment-start-point) + ;; In this case our start-skip string failed + ;; to work properly. Lets try and move over + ;; whatever white space we matched to begin + ;; with. + (skip-syntax-forward "-.'" + (save-excursion + (end-of-line) + (point))) + ;; We may need to back up so newlines or whitespace is generated. + (if (bolp) + (backward-char 1))) + (if (eq (point) comment-start-point) + (error "Strange comment syntax prevents lexical analysis")) + (setq semantic-lex-end-point (point)))) + +;;; Comment lexer +;; +;; Predefined lexers that could be used instead of creating new +;; analyers. + +(define-lex semantic-comment-lexer + "A simple lexical analyzer that handles comments. +This lexer will only return comment tokens. It is the default lexer +used by `semantic-find-doc-snarf-comment' to snarf up the comment at +point." + semantic-lex-ignore-whitespace + semantic-lex-ignore-newline + semantic-lex-comments + semantic-lex-default-action) + +;;; Test Lexer +;; +(define-lex semantic-simple-lexer + "A simple lexical analyzer that handles simple buffers. +This lexer ignores comments and whitespace, and will return +syntax as specified by the syntax table." + semantic-lex-ignore-whitespace + semantic-lex-ignore-newline + semantic-lex-number + semantic-lex-symbol-or-keyword + semantic-lex-charquote + semantic-lex-paren-or-list + semantic-lex-close-paren + semantic-lex-string + semantic-lex-ignore-comments + semantic-lex-punctuation + semantic-lex-default-action) + +;;; Analyzers generated from grammar. +;; +;; Some analyzers are hand written. Analyzers created with these +;; functions are generated from the grammar files. + +(defmacro define-lex-keyword-type-analyzer (name doc syntax) + "Define a keyword type analyzer NAME with DOC string. +SYNTAX is the regexp that matches a keyword syntactic expression." + (let ((key (make-symbol "key"))) + `(define-lex-analyzer ,name + ,doc + (and (looking-at ,syntax) + (let ((,key (semantic-lex-keyword-p (match-string 0)))) + (when ,key + (semantic-lex-push-token + (semantic-lex-token + ,key (match-beginning 0) (match-end 0))))))) + )) + +(defmacro define-lex-sexp-type-analyzer (name doc syntax token) + "Define a sexp type analyzer NAME with DOC string. +SYNTAX is the regexp that matches the beginning of the s-expression. +TOKEN is the lexical token returned when SYNTAX matches." + `(define-lex-regex-analyzer ,name + ,doc + ,syntax + (semantic-lex-push-token + (semantic-lex-token + ,token (point) + (save-excursion + (semantic-lex-unterminated-syntax-protection ,token + (forward-sexp 1) + (point)))))) + ) + +(defmacro define-lex-regex-type-analyzer (name doc syntax matches default) + "Define a regexp type analyzer NAME with DOC string. +SYNTAX is the regexp that matches a syntactic expression. +MATCHES is an alist of lexical elements used to refine the syntactic +expression. +DEFAULT is the default lexical token returned when no MATCHES." + (if matches + (let* ((val (make-symbol "val")) + (lst (make-symbol "lst")) + (elt (make-symbol "elt")) + (pos (make-symbol "pos")) + (end (make-symbol "end"))) + `(define-lex-analyzer ,name + ,doc + (and (looking-at ,syntax) + (let* ((,val (match-string 0)) + (,pos (match-beginning 0)) + (,end (match-end 0)) + (,lst ,matches) + ,elt) + (while (and ,lst (not ,elt)) + (if (string-match (cdar ,lst) ,val) + (setq ,elt (caar ,lst)) + (setq ,lst (cdr ,lst)))) + (semantic-lex-push-token + (semantic-lex-token (or ,elt ,default) ,pos ,end)))) + )) + `(define-lex-simple-regex-analyzer ,name + ,doc + ,syntax ,default) + )) + +(defmacro define-lex-string-type-analyzer (name doc syntax matches default) + "Define a string type analyzer NAME with DOC string. +SYNTAX is the regexp that matches a syntactic expression. +MATCHES is an alist of lexical elements used to refine the syntactic +expression. +DEFAULT is the default lexical token returned when no MATCHES." + (if matches + (let* ((val (make-symbol "val")) + (lst (make-symbol "lst")) + (elt (make-symbol "elt")) + (pos (make-symbol "pos")) + (end (make-symbol "end")) + (len (make-symbol "len"))) + `(define-lex-analyzer ,name + ,doc + (and (looking-at ,syntax) + (let* ((,val (match-string 0)) + (,pos (match-beginning 0)) + (,end (match-end 0)) + (,len (- ,end ,pos)) + (,lst ,matches) + ,elt) + ;; Starting with the longest one, search if a lexical + ;; value match a token defined for this language. + (while (and (> ,len 0) (not (setq ,elt (rassoc ,val ,lst)))) + (setq ,len (1- ,len) + ,val (substring ,val 0 ,len))) + (when ,elt ;; Adjust token end position. + (setq ,elt (car ,elt) + ,end (+ ,pos ,len))) + (semantic-lex-push-token + (semantic-lex-token (or ,elt ,default) ,pos ,end)))) + )) + `(define-lex-simple-regex-analyzer ,name + ,doc + ,syntax ,default) + )) + +(defmacro define-lex-block-type-analyzer (name doc syntax matches) + "Define a block type analyzer NAME with DOC string. + +SYNTAX is the regexp that matches block delimiters, typically the +open (`\\\\s(') and close (`\\\\s)') parenthesis syntax classes. + +MATCHES is a pair (OPEN-SPECS . CLOSE-SPECS) that defines blocks. + + OPEN-SPECS is a list of (OPEN-DELIM OPEN-TOKEN BLOCK-TOKEN) elements + where: + + OPEN-DELIM is a string: the block open delimiter character. + + OPEN-TOKEN is the lexical token class associated to the OPEN-DELIM + delimiter. + + BLOCK-TOKEN is the lexical token class associated to the block + that starts at the OPEN-DELIM delimiter. + + CLOSE-SPECS is a list of (CLOSE-DELIM CLOSE-TOKEN) elements where: + + CLOSE-DELIM is a string: the block end delimiter character. + + CLOSE-TOKEN is the lexical token class associated to the + CLOSE-DELIM delimiter. + +Each element in OPEN-SPECS must have a corresponding element in +CLOSE-SPECS. + +The lexer will return a BLOCK-TOKEN token when the value of +`semantic-lex-current-depth' is greater than or equal to the maximum +depth of parenthesis tracking (see also the function `semantic-lex'). +Otherwise it will return OPEN-TOKEN and CLOSE-TOKEN tokens. + +TO DO: Put the following in the developer's guide and just put a +reference here. + +In the grammar: + +The value of a block token must be a string that contains a readable +sexp of the form: + + \"(OPEN-TOKEN CLOSE-TOKEN)\" + +OPEN-TOKEN and CLOSE-TOKEN represent the block delimiters, and must be +lexical tokens of respectively `open-paren' and `close-paren' types. +Their value is the corresponding delimiter character as a string. + +Here is a small example to analyze a parenthesis block: + + %token <block> PAREN_BLOCK \"(LPAREN RPAREN)\" + %token <open-paren> LPAREN \"(\" + %token <close-paren> RPAREN \")\" + +When the lexer encounters the open-paren delimiter \"(\": + + - If the maximum depth of parenthesis tracking is not reached (that + is, current depth < max depth), it returns a (LPAREN start . end) + token, then continue analysis inside the block. Later, when the + corresponding close-paren delimiter \")\" will be encountered, it + will return a (RPAREN start . end) token. + + - If the maximum depth of parenthesis tracking is reached (current + depth >= max depth), it returns the whole parenthesis block as + a (PAREN_BLOCK start . end) token." + (let* ((val (make-symbol "val")) + (lst (make-symbol "lst")) + (elt (make-symbol "elt"))) + `(define-lex-analyzer ,name + ,doc + (and + (looking-at ,syntax) ;; "\\(\\s(\\|\\s)\\)" + (let ((,val (match-string 0)) + (,lst ,matches) + ,elt) + (cond + ((setq ,elt (assoc ,val (car ,lst))) + (if (or (not semantic-lex-maximum-depth) + (< semantic-lex-current-depth semantic-lex-maximum-depth)) + (progn + (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)) + (semantic-lex-push-token + (semantic-lex-token + (nth 1 ,elt) + (match-beginning 0) (match-end 0)))) + (semantic-lex-push-token + (semantic-lex-token + (nth 2 ,elt) + (match-beginning 0) + (save-excursion + (semantic-lex-unterminated-syntax-protection (nth 2 ,elt) + (forward-list 1) + (point))))))) + ((setq ,elt (assoc ,val (cdr ,lst))) + (setq semantic-lex-current-depth (1- semantic-lex-current-depth)) + (semantic-lex-push-token + (semantic-lex-token + (nth 1 ,elt) + (match-beginning 0) (match-end 0)))) + )))) + )) + +;;; Lexical Safety +;; +;; The semantic lexers, unlike other lexers, can throw errors on +;; unbalanced syntax. Since editing is all about changeging test +;; we need to provide a convenient way to protect against syntactic +;; inequalities. + +(defmacro semantic-lex-catch-errors (symbol &rest forms) + "Using SYMBOL, execute FORMS catching lexical errors. +If FORMS results in a call to the parser that throws a lexical error, +the error will be caught here without the buffer's cache being thrown +out of date. +If there is an error, the syntax that failed is returned. +If there is no error, then the last value of FORMS is returned." + (let ((ret (make-symbol "ret")) + (syntax (make-symbol "syntax")) + (start (make-symbol "start")) + (end (make-symbol "end"))) + `(let* ((semantic-lex-unterminated-syntax-end-function + (lambda (,syntax ,start ,end) + (throw ',symbol ,syntax))) + ;; Delete the below when semantic-flex is fully retired. + (semantic-flex-unterminated-syntax-end-function + semantic-lex-unterminated-syntax-end-function) + (,ret (catch ',symbol + (save-excursion + ,@forms + nil)))) + ;; Great Sadness. Assume that FORMS execute within the + ;; confines of the current buffer only! Mark this thing + ;; unparseable iff the special symbol was thrown. This + ;; will prevent future calls from parsing, but will allow + ;; then to still return the cache. + (when ,ret + ;; Leave this message off. If an APP using this fcn wants + ;; a message, they can do it themselves. This cleans up + ;; problems with the idle scheduler obscuring useful data. + ;;(message "Buffer not currently parsable (%S)." ,ret) + (semantic-parse-tree-unparseable)) + ,ret))) +(put 'semantic-lex-catch-errors 'lisp-indent-function 1) + + +;;; Interfacing with edebug +;; +(add-hook + 'edebug-setup-hook + #'(lambda () + + (def-edebug-spec define-lex + (&define name stringp (&rest symbolp)) + ) + (def-edebug-spec define-lex-analyzer + (&define name stringp form def-body) + ) + (def-edebug-spec define-lex-regex-analyzer + (&define name stringp form def-body) + ) + (def-edebug-spec define-lex-simple-regex-analyzer + (&define name stringp form symbolp [ &optional form ] def-body) + ) + (def-edebug-spec define-lex-block-analyzer + (&define name stringp form (&rest form)) + ) + (def-edebug-spec semantic-lex-catch-errors + (symbolp def-body) + ) + + )) + +;;; Compatibility with Semantic 1.x lexical analysis +;; +;; NOTE: DELETE THIS SOMEDAY SOON + +(semantic-alias-obsolete 'semantic-flex-start 'semantic-lex-token-start) +(semantic-alias-obsolete 'semantic-flex-end 'semantic-lex-token-end) +(semantic-alias-obsolete 'semantic-flex-text 'semantic-lex-token-text) +(semantic-alias-obsolete 'semantic-flex-make-keyword-table 'semantic-lex-make-keyword-table) +(semantic-alias-obsolete 'semantic-flex-keyword-p 'semantic-lex-keyword-p) +(semantic-alias-obsolete 'semantic-flex-keyword-put 'semantic-lex-keyword-put) +(semantic-alias-obsolete 'semantic-flex-keyword-get 'semantic-lex-keyword-get) +(semantic-alias-obsolete 'semantic-flex-map-keywords 'semantic-lex-map-keywords) +(semantic-alias-obsolete 'semantic-flex-keywords 'semantic-lex-keywords) +(semantic-alias-obsolete 'semantic-flex-buffer 'semantic-lex-buffer) +(semantic-alias-obsolete 'semantic-flex-list 'semantic-lex-list) + +;; This simple scanner uses the syntax table to generate a stream of +;; simple tokens of the form: +;; +;; (SYMBOL START . END) +;; +;; Where symbol is the type of thing it is. START and END mark that +;; objects boundary. + +(defvar semantic-flex-tokens semantic-lex-tokens + "An alist of of semantic token types. +See variable `semantic-lex-tokens'.") + +(defvar semantic-flex-unterminated-syntax-end-function + (lambda (syntax syntax-start flex-end) flex-end) + "Function called when unterminated syntax is encountered. +This should be set to one function. That function should take three +parameters. The SYNTAX, or type of syntax which is unterminated. +SYNTAX-START where the broken syntax begins. +FLEX-END is where the lexical analysis was asked to end. +This function can be used for languages that can intelligently fix up +broken syntax, or the exit lexical analysis via `throw' or `signal' +when finding unterminated syntax.") + +(defvar semantic-flex-extensions nil + "Buffer local extensions to the lexical analyzer. +This should contain an alist with a key of a regex and a data element of +a function. The function should both move point, and return a lexical +token of the form: + ( TYPE START . END) +nil is also a valid return value. +TYPE can be any type of symbol, as long as it doesn't occur as a +nonterminal in the language definition.") +(make-variable-buffer-local 'semantic-flex-extensions) + +(defvar semantic-flex-syntax-modifications nil + "Changes to the syntax table for this buffer. +These changes are active only while the buffer is being flexed. +This is a list where each element has the form: + (CHAR CLASS) +CHAR is the char passed to `modify-syntax-entry', +and CLASS is the string also passed to `modify-syntax-entry' to define +what syntax class CHAR has.") +(make-variable-buffer-local 'semantic-flex-syntax-modifications) + +(defvar semantic-ignore-comments t + "Default comment handling. +t means to strip comments when flexing. Nil means to keep comments +as part of the token stream.") +(make-variable-buffer-local 'semantic-ignore-comments) + +(defvar semantic-flex-enable-newlines nil + "When flexing, report 'newlines as syntactic elements. +Useful for languages where the newline is a special case terminator. +Only set this on a per mode basis, not globally.") +(make-variable-buffer-local 'semantic-flex-enable-newlines) + +(defvar semantic-flex-enable-whitespace nil + "When flexing, report 'whitespace as syntactic elements. +Useful for languages where the syntax is whitespace dependent. +Only set this on a per mode basis, not globally.") +(make-variable-buffer-local 'semantic-flex-enable-whitespace) + +(defvar semantic-flex-enable-bol nil + "When flexing, report beginning of lines as syntactic elements. +Useful for languages like python which are indentation sensitive. +Only set this on a per mode basis, not globally.") +(make-variable-buffer-local 'semantic-flex-enable-bol) + +(defvar semantic-number-expression semantic-lex-number-expression + "See variable `semantic-lex-number-expression'.") +(make-variable-buffer-local 'semantic-number-expression) + +(defvar semantic-flex-depth 0 + "Default flexing depth. +This specifies how many lists to create tokens in.") +(make-variable-buffer-local 'semantic-flex-depth) + +(defun semantic-flex (start end &optional depth length) + "Using the syntax table, do something roughly equivalent to flex. +Semantically check between START and END. Optional argument DEPTH +indicates at what level to scan over entire lists. +The return value is a token stream. Each element is a list, such of +the form (symbol start-expression . end-expression) where SYMBOL +denotes the token type. +See `semantic-flex-tokens' variable for details on token types. +END does not mark the end of the text scanned, only the end of the +beginning of text scanned. Thus, if a string extends past END, the +end of the return token will be larger than END. To truly restrict +scanning, use `narrow-to-region'. +The last argument, LENGTH specifies that `semantic-flex' should only +return LENGTH tokens." + (message "`semantic-flex' is an obsolete function. Use `define-lex' to create lexers.") + (if (not semantic-flex-keywords-obarray) + (setq semantic-flex-keywords-obarray [ nil ])) + (let ((ts nil) + (pos (point)) + (ep nil) + (curdepth 0) + (cs (if comment-start-skip + (concat "\\(\\s<\\|" comment-start-skip "\\)") + (concat "\\(\\s<\\)"))) + (newsyntax (copy-syntax-table (syntax-table))) + (mods semantic-flex-syntax-modifications) + ;; Use the default depth if it is not specified. + (depth (or depth semantic-flex-depth))) + ;; Update the syntax table + (while mods + (modify-syntax-entry (car (car mods)) (car (cdr (car mods))) newsyntax) + (setq mods (cdr mods))) + (with-syntax-table newsyntax + (goto-char start) + (while (and (< (point) end) (or (not length) (<= (length ts) length))) + (cond + ;; catch beginning of lines when needed. + ;; Must be done before catching any other tokens! + ((and semantic-flex-enable-bol + (bolp) + ;; Just insert a (bol N . N) token in the token stream, + ;; without moving the point. N is the point at the + ;; beginning of line. + (setq ts (cons (cons 'bol (cons (point) (point))) ts)) + nil)) ;; CONTINUE + ;; special extensions, includes whitespace, nl, etc. + ((and semantic-flex-extensions + (let ((fe semantic-flex-extensions) + (r nil)) + (while fe + (if (looking-at (car (car fe))) + (setq ts (cons (funcall (cdr (car fe))) ts) + r t + fe nil + ep (point))) + (setq fe (cdr fe))) + (if (and r (not (car ts))) (setq ts (cdr ts))) + r))) + ;; catch newlines when needed + ((looking-at "\\s-*\\(\n\\|\\s>\\)") + (if semantic-flex-enable-newlines + (setq ep (match-end 1) + ts (cons (cons 'newline + (cons (match-beginning 1) ep)) + ts)))) + ;; catch whitespace when needed + ((looking-at "\\s-+") + (if semantic-flex-enable-whitespace + ;; Language wants whitespaces, link them together. + (if (eq (car (car ts)) 'whitespace) + (setcdr (cdr (car ts)) (match-end 0)) + (setq ts (cons (cons 'whitespace + (cons (match-beginning 0) + (match-end 0))) + ts))))) + ;; numbers + ((and semantic-number-expression + (looking-at semantic-number-expression)) + (setq ts (cons (cons 'number + (cons (match-beginning 0) + (match-end 0))) + ts))) + ;; symbols + ((looking-at "\\(\\sw\\|\\s_\\)+") + (setq ts (cons (cons + ;; Get info on if this is a keyword or not + (or (semantic-flex-keyword-p (match-string 0)) + 'symbol) + (cons (match-beginning 0) (match-end 0))) + ts))) + ;; Character quoting characters (ie, \n as newline) + ((looking-at "\\s\\+") + (setq ts (cons (cons 'charquote + (cons (match-beginning 0) (match-end 0))) + ts))) + ;; Open parens, or semantic-lists. + ((looking-at "\\s(") + (if (or (not depth) (< curdepth depth)) + (progn + (setq curdepth (1+ curdepth)) + (setq ts (cons (cons 'open-paren + (cons (match-beginning 0) (match-end 0))) + ts))) + (setq ts (cons + (cons 'semantic-list + (cons (match-beginning 0) + (save-excursion + (condition-case nil + (forward-list 1) + ;; This case makes flex robust + ;; to broken lists. + (error + (goto-char + (funcall + semantic-flex-unterminated-syntax-end-function + 'semantic-list + start end)))) + (setq ep (point))))) + ts)))) + ;; Close parens + ((looking-at "\\s)") + (setq ts (cons (cons 'close-paren + (cons (match-beginning 0) (match-end 0))) + ts)) + (setq curdepth (1- curdepth))) + ;; String initiators + ((looking-at "\\s\"") + ;; Zing to the end of this string. + (setq ts (cons (cons 'string + (cons (match-beginning 0) + (save-excursion + (condition-case nil + (forward-sexp 1) + ;; This case makes flex + ;; robust to broken strings. + (error + (goto-char + (funcall + semantic-flex-unterminated-syntax-end-function + 'string + start end)))) + (setq ep (point))))) + ts))) + ;; comments + ((looking-at cs) + (if (and semantic-ignore-comments + (not semantic-flex-enable-whitespace)) + ;; If the language doesn't deal with comments nor + ;; whitespaces, ignore them here. + (let ((comment-start-point (point))) + (forward-comment 1) + (if (eq (point) comment-start-point) + ;; In this case our start-skip string failed + ;; to work properly. Lets try and move over + ;; whatever white space we matched to begin + ;; with. + (skip-syntax-forward "-.'" + (save-excursion + (end-of-line) + (point))) + ;;(forward-comment 1) + ;; Generate newline token if enabled + (if (and semantic-flex-enable-newlines + (bolp)) + (backward-char 1))) + (if (eq (point) comment-start-point) + (error "Strange comment syntax prevents lexical analysis")) + (setq ep (point))) + (let ((tk (if semantic-ignore-comments 'whitespace 'comment))) + (save-excursion + (forward-comment 1) + ;; Generate newline token if enabled + (if (and semantic-flex-enable-newlines + (bolp)) + (backward-char 1)) + (setq ep (point))) + ;; Language wants comments or want them as whitespaces, + ;; link them together. + (if (eq (car (car ts)) tk) + (setcdr (cdr (car ts)) ep) + (setq ts (cons (cons tk (cons (match-beginning 0) ep)) + ts)))))) + ;; punctuation + ((looking-at "\\(\\s.\\|\\s$\\|\\s'\\)") + (setq ts (cons (cons 'punctuation + (cons (match-beginning 0) (match-end 0))) + ts))) + ;; unknown token + (t + (error "What is that?"))) + (goto-char (or ep (match-end 0))) + (setq ep nil))) + ;; maybe catch the last beginning of line when needed + (and semantic-flex-enable-bol + (= (point) end) + (bolp) + (setq ts (cons (cons 'bol (cons (point) (point))) ts))) + (goto-char pos) + ;;(message "Flexing muscles...done") + (nreverse ts))) + +(provide 'semantic-lex) + +;;; semantic-lex.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic-tag.el Sun Aug 23 03:46:01 2009 +0000 @@ -0,0 +1,1569 @@ +;;; semantic-tag.el --- tag creation and access + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; I. The core production of semantic is the list of tags produced by the +;; different parsers. This file provides 3 APIs related to tag access: +;; +;; 1) Primitive Tag Access +;; There is a set of common features to all tags. These access +;; functions can get these values. +;; 2) Standard Tag Access +;; A Standard Tag should be produced by most traditional languages +;; with standard styles common to typed object oriented languages. +;; These functions can access these data elements from a tag. +;; 3) Generic Tag Access +;; Access to tag structure in a more direct way. +;; ** May not be forward compatible. +;; +;; II. There is also an API for tag creation. Use `semantic-tag' to create +;; a new tag. +;; +;; III. Tag Comparison. Allows explicit or comparitive tests to see +;; if two tags are the same. + +;;; History: +;; + +;;; Code: +;; + +;; Keep this only so long as we have obsolete fcns. +(require 'semantic-fw) + +(defconst semantic-tag-version semantic-version + "Version string of semantic tags made with this code.") + +(defconst semantic-tag-incompatible-version "1.0" + "Version string of semantic tags which are not currently compatible. +These old style tags may be loaded from a file with semantic db. +In this case, we must flush the old tags and start over.") + +;;; Primitive Tag access system: +;; +;; Raw tags in semantic are lists of 5 elements: +;; +;; (NAME CLASS ATTRIBUTES PROPERTIES OVERLAY) +;; +;; Where: +;; +;; - NAME is a string that represents the tag name. +;; +;; - CLASS is a symbol that represent the class of the tag (for +;; example, usual classes are `type', `function', `variable', +;; `include', `package', `code'). +;; +;; - ATTRIBUTES is a public list of attributes that describes +;; language data represented by the tag (for example, a variable +;; can have a `:constant-flag' attribute, a function an `:arguments' +;; attribute, etc.). +;; +;; - PROPERTIES is a private list of properties used internally. +;; +;; - OVERLAY represent the location of data described by the tag. +;; + +(defsubst semantic-tag-name (tag) + "Return the name of TAG. +For functions, variables, classes, typedefs, etc., this is the identifier +that is being defined. For tags without an obvious associated name, this +may be the statement type, e.g., this may return @code{print} for python's +print statement." + (car tag)) + +(defsubst semantic-tag-class (tag) + "Return the class of TAG. +That is, the symbol 'variable, 'function, 'type, or other. +There is no limit to the symbols that may represent the class of a tag. +Each parser generates tags with classes defined by it. + +For functional languages, typical tag classes are: + +@table @code +@item type +Data types, named map for a memory block. +@item function +A function or method, or named execution location. +@item variable +A variable, or named storage for data. +@item include +Statement that represents a file from which more tags can be found. +@item package +Statement that declairs this file's package name. +@item code +Code that has not name or binding to any other symbol, such as in a script. +@end table +" + (nth 1 tag)) + +(defsubst semantic-tag-attributes (tag) + "Return the list of public attributes of TAG. +That is a property list: (ATTRIBUTE-1 VALUE-1 ATTRIBUTE-2 VALUE-2...)." + (nth 2 tag)) + +(defsubst semantic-tag-properties (tag) + "Return the list of private properties of TAG. +That is a property list: (PROPERTY-1 VALUE-1 PROPERTY-2 VALUE-2...)." + (nth 3 tag)) + +(defsubst semantic-tag-overlay (tag) + "Return the OVERLAY part of TAG. +That is, an overlay or an unloaded buffer representation. +This function can also return an array of the form [ START END ]. +This occurs for tags that are not currently linked into a buffer." + (nth 4 tag)) + +(defsubst semantic--tag-overlay-cdr (tag) + "Return the cons cell whose car is the OVERLAY part of TAG. +That function is for internal use only." + (nthcdr 4 tag)) + +(defsubst semantic--tag-set-overlay (tag overlay) + "Set the overlay part of TAG with OVERLAY. +That function is for internal use only." + (setcar (semantic--tag-overlay-cdr tag) overlay)) + +(defsubst semantic-tag-start (tag) + "Return the start location of TAG." + (let ((o (semantic-tag-overlay tag))) + (if (semantic-overlay-p o) + (semantic-overlay-start o) + (aref o 0)))) + +(defsubst semantic-tag-end (tag) + "Return the end location of TAG." + (let ((o (semantic-tag-overlay tag))) + (if (semantic-overlay-p o) + (semantic-overlay-end o) + (aref o 1)))) + +(defsubst semantic-tag-bounds (tag) + "Return the location (START END) of data TAG describes." + (list (semantic-tag-start tag) + (semantic-tag-end tag))) + +(defun semantic-tag-set-bounds (tag start end) + "In TAG, set the START and END location of data it describes." + (let ((o (semantic-tag-overlay tag))) + (if (semantic-overlay-p o) + (semantic-overlay-move o start end) + (semantic--tag-set-overlay tag (vector start end))))) + +(defun semantic-tag-in-buffer-p (tag) + "Return the buffer TAG resides in IFF tag is already in a buffer. +If a tag is not in a buffer, return nil." + (let ((o (semantic-tag-overlay tag))) + ;; TAG is currently linked to a buffer, return it. + (when (and (semantic-overlay-p o) + (semantic-overlay-live-p o)) + (semantic-overlay-buffer o)))) + +(defsubst semantic--tag-get-property (tag property) + "From TAG, extract the value of PROPERTY. +Return the value found, or nil if PROPERTY is not one of the +properties of TAG. +That function is for internal use only." + (plist-get (semantic-tag-properties tag) property)) + +(defun semantic-tag-buffer (tag) + "Return the buffer TAG resides in. +If TAG has an originating file, read that file into a (maybe new) +buffer, and return it. +Return nil if there is no buffer for this tag." + (let ((buff (semantic-tag-in-buffer-p tag))) + (if buff + buff + ;; TAG has an originating file, read that file into a buffer, and + ;; return it. + (if (semantic--tag-get-property tag :filename) + (find-file-noselect (semantic--tag-get-property tag :filename)) + ;; TAG is not in Emacs right now, no buffer is available. + )))) + +(defun semantic-tag-mode (&optional tag) + "Return the major mode active for TAG. +TAG defaults to the tag at point in current buffer. +If TAG has a :mode property return it. +If point is inside TAG bounds, return the major mode active at point. +Return the major mode active at beginning of TAG otherwise. +See also the function `semantic-ctxt-current-mode'." + (or tag (setq tag (semantic-current-tag))) + (or (semantic--tag-get-property tag :mode) + (let ((buffer (semantic-tag-buffer tag)) + (start (semantic-tag-start tag)) + (end (semantic-tag-end tag))) + (save-excursion + (and buffer (set-buffer buffer)) + ;; Unless point is inside TAG bounds, move it to the + ;; beginning of TAG. + (or (and (>= (point) start) (< (point) end)) + (goto-char start)) + (require 'semantic-ctxt) + (semantic-ctxt-current-mode))))) + +(defsubst semantic--tag-attributes-cdr (tag) + "Return the cons cell whose car is the ATTRIBUTES part of TAG. +That function is for internal use only." + (nthcdr 2 tag)) + +(defsubst semantic-tag-put-attribute (tag attribute value) + "Change value in TAG of ATTRIBUTE to VALUE. +If ATTRIBUTE already exists, its value is set to VALUE, otherwise the +new ATTRIBUTE VALUE pair is added. +Return TAG. +Use this function in a parser when not all attributes are known at the +same time." + (let* ((plist-cdr (semantic--tag-attributes-cdr tag))) + (when (consp plist-cdr) + (setcar plist-cdr + (semantic-tag-make-plist + (plist-put (car plist-cdr) attribute value)))) + tag)) + +(defun semantic-tag-put-attribute-no-side-effect (tag attribute value) + "Change value in TAG of ATTRIBUTE to VALUE without side effects. +All cons cells in the attribute list are replicated so that there +are no side effects if TAG is in shared lists. +If ATTRIBUTE already exists, its value is set to VALUE, otherwise the +new ATTRIBUTE VALUE pair is added. +Return TAG." + (let* ((plist-cdr (semantic--tag-attributes-cdr tag))) + (when (consp plist-cdr) + (setcar plist-cdr + (semantic-tag-make-plist + (plist-put (copy-sequence (car plist-cdr)) + attribute value)))) + tag)) + +(defsubst semantic-tag-get-attribute (tag attribute) + "From TAG, return the value of ATTRIBUTE. +ATTRIBUTE is a symbol whose specification value to get. +Return the value found, or nil if ATTRIBUTE is not one of the +attributes of TAG." + (plist-get (semantic-tag-attributes tag) attribute)) + +;; These functions are for internal use only! +(defsubst semantic--tag-properties-cdr (tag) + "Return the cons cell whose car is the PROPERTIES part of TAG. +That function is for internal use only." + (nthcdr 3 tag)) + +(defun semantic--tag-put-property (tag property value) + "Change value in TAG of PROPERTY to VALUE. +If PROPERTY already exists, its value is set to VALUE, otherwise the +new PROPERTY VALUE pair is added. +Return TAG. +That function is for internal use only." + (let* ((plist-cdr (semantic--tag-properties-cdr tag))) + (when (consp plist-cdr) + (setcar plist-cdr + (semantic-tag-make-plist + (plist-put (car plist-cdr) property value)))) + tag)) + +(defun semantic--tag-put-property-no-side-effect (tag property value) + "Change value in TAG of PROPERTY to VALUE without side effects. +All cons cells in the property list are replicated so that there +are no side effects if TAG is in shared lists. +If PROPERTY already exists, its value is set to VALUE, otherwise the +new PROPERTY VALUE pair is added. +Return TAG. +That function is for internal use only." + (let* ((plist-cdr (semantic--tag-properties-cdr tag))) + (when (consp plist-cdr) + (setcar plist-cdr + (semantic-tag-make-plist + (plist-put (copy-sequence (car plist-cdr)) + property value)))) + tag)) + +(defun semantic-tag-file-name (tag) + "Return the name of the file from which TAG originated. +Return nil if that information can't be obtained. +If TAG is from a loaded buffer, then that buffer's filename is used. +If TAG is unlinked, but has a :filename property, then that is used." + (let ((buffer (semantic-tag-in-buffer-p tag))) + (if buffer + (buffer-file-name buffer) + (semantic--tag-get-property tag :filename)))) + +;;; Tag tests and comparisons. +;; +;;;###autoload +(defsubst semantic-tag-p (tag) + "Return non-nil if TAG is most likely a semantic tag." + (condition-case nil + (and (consp tag) + (stringp (car tag)) ; NAME + (symbolp (nth 1 tag)) (nth 1 tag) ; TAG-CLASS + (listp (nth 2 tag)) ; ATTRIBUTES + (listp (nth 3 tag)) ; PROPERTIES + ) + ;; If an error occurs, then it most certainly is not a tag. + (error nil))) + +(defsubst semantic-tag-of-class-p (tag class) + "Return non-nil if class of TAG is CLASS." + (eq (semantic-tag-class tag) class)) + +(defsubst semantic-tag-type-members (tag) + "Return the members of the type that TAG describes. +That is the value of the `:members' attribute." + (semantic-tag-get-attribute tag :members)) + +(defun semantic-tag-with-position-p (tag) + "Return non-nil if TAG has positional information." + (and (semantic-tag-p tag) + (let ((o (semantic-tag-overlay tag))) + (or (and (semantic-overlay-p o) + (semantic-overlay-live-p o)) + (arrayp o))))) + +(defun semantic-equivalent-tag-p (tag1 tag2) + "Compare TAG1 and TAG2 and return non-nil if they are equivalent. +Use `equal' on elements the name, class, and position. +Use this function if tags are being copied and regrouped to test +for if two tags represent the same thing, but may be constructed +of different cons cells." + (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2)) + (semantic-tag-of-class-p tag1 (semantic-tag-class tag2)) + (or (and (not (semantic-tag-overlay tag1)) + (not (semantic-tag-overlay tag2))) + (and (semantic-tag-overlay tag1) + (semantic-tag-overlay tag2) + (equal (semantic-tag-bounds tag1) + (semantic-tag-bounds tag2)))))) + +(defsubst semantic-tag-type (tag) + "Return the value of the `:type' attribute of TAG. +For a function it would be the data type of the return value. +For a variable, it is the storage type of that variable. +For a data type, the type is the style of datatype, such as +struct or union." + (semantic-tag-get-attribute tag :type)) + +(defun semantic-tag-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. +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) ))) + + +(defun semantic-tag-of-type-p (tag type) + "Compare TAG's type against TYPE. Non nil if equivalent. +TYPE can be a string, or a tag of class 'type. +This can be complex since some tags might have a :type that is a tag, +while other tags might just have a string. This function will also be +return true of TAG's type is compared directly to the declaration of a +data type." + (let* ((tagtype (semantic-tag-type tag)) + (tagtypestring (cond ((stringp tagtype) + tagtype) + ((and (semantic-tag-p tagtype) + (semantic-tag-of-class-p tagtype 'type)) + (semantic-tag-name tagtype)) + (t ""))) + (typestring (cond ((stringp type) + type) + ((and (semantic-tag-p type) + (semantic-tag-of-class-p type 'type)) + (semantic-tag-name type)) + (t ""))) + ) + (and + tagtypestring + (or + ;; Matching strings (input type is string) + (and (stringp type) + (string= tagtypestring type)) + ;; Matching strings (tag type is string) + (and (stringp tagtype) + (string= tagtype typestring)) + ;; Matching tokens, and the type of the type is the same. + (and (string= tagtypestring typestring) + (if (and (semantic-tag-type tagtype) (semantic-tag-type type)) + (equal (semantic-tag-type tagtype) (semantic-tag-type type)) + t)) + )) + )) + +(defun semantic-tag-type-compound-p (tag) + "Return non-nil the type of TAG is compound. +Compound implies a structure or similar data type. +Returns the list of tag members if it is compound." + (let* ((tagtype (semantic-tag-type tag)) + ) + (when (and (semantic-tag-p tagtype) + (semantic-tag-of-class-p tagtype 'type)) + ;; We have the potential of this being a nifty compound type. + (semantic-tag-type-members tagtype) + ))) + +(defun semantic-tag-faux-p (tag) + "Return non-nil if TAG is a FAUX tag. +FAUX tags are created to represent a construct that is +not known to exist in the code. + +Example: When the class browser sees methods to a class, but +cannot find the class, it will create a faux tag to represent the +class to store those methods." + (semantic--tag-get-property tag :faux-flag)) + +;;; Tag creation +;; + +;; Is this function still necessary? +(defun semantic-tag-make-plist (args) + "Create a property list with ARGS. +Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN). +Where KEY is a symbol, and VALUE is the value for that symbol. +The return value will be a new property list, with these KEY/VALUE +pairs eliminated: + + - KEY associated to nil VALUE. + - KEY associated to an empty string VALUE. + - KEY associated to a zero VALUE." + (let (plist key val) + (while args + (setq key (car args) + val (nth 1 args) + args (nthcdr 2 args)) + (or (member val '("" nil)) + (and (numberp val) (zerop val)) + (setq plist (cons key (cons val plist))))) + ;; It is not useful to reverse the new plist. + plist)) + +(defsubst semantic-tag (name class &rest attributes) + "Create a generic semantic tag. +NAME is a string representing the name of this tag. +CLASS is the symbol that represents the class of tag this is, +such as 'variable, or 'function. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (list name class (semantic-tag-make-plist attributes) nil nil)) + +(defsubst semantic-tag-new-variable (name type &optional default-value &rest attributes) + "Create a semantic tag of class 'variable. +NAME is the name of this variable. +TYPE is a string or semantic tag representing the type of this variable. +Optional DEFAULT-VALUE is a string representing the default value of this variable. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'variable + :type type + :default-value default-value + attributes)) + +(defsubst semantic-tag-new-function (name type arg-list &rest attributes) + "Create a semantic tag of class 'function. +NAME is the name of this function. +TYPE is a string or semantic tag representing the type of this function. +ARG-LIST is a list of strings or semantic tags representing the +arguments of this function. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'function + :type type + :arguments arg-list + attributes)) + +(defsubst semantic-tag-new-type (name type members parents &rest attributes) + "Create a semantic tag of class 'type. +NAME is the name of this type. +TYPE is a string or semantic tag representing the type of this type. +MEMBERS is a list of strings or semantic tags representing the +elements that make up this type if it is a composite type. +PARENTS is a cons cell. (EXPLICIT-PARENTS . INTERFACE-PARENTS) +EXPLICIT-PARENTS can be a single string (Just one parent) or a +list of parents (in a multiple inheritance situation). It can also +be nil. +INTERFACE-PARENTS is a list of strings representing the names of +all INTERFACES, or abstract classes inherited from. It can also be +nil. +This slot can be interesting because the form: + ( nil \"string\") +is a valid parent where there is no explicit parent, and only an +interface. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'type + :type type + :members members + :superclasses (car parents) + :interfaces (cdr parents) + attributes)) + +(defsubst semantic-tag-new-include (name system-flag &rest attributes) + "Create a semantic tag of class 'include. +NAME is the name of this include. +SYSTEM-FLAG represents that we were able to identify this include as belonging +to the system, as opposed to belonging to the local project. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'include + :system-flag system-flag + attributes)) + +(defsubst semantic-tag-new-package (name detail &rest attributes) + "Create a semantic tag of class 'package. +NAME is the name of this package. +DETAIL is extra information about this package, such as a location where +it can be found. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'package + :detail detail + attributes)) + +(defsubst semantic-tag-new-code (name detail &rest attributes) + "Create a semantic tag of class 'code. +NAME is a name for this code. +DETAIL is extra information about the code. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'code + :detail detail + attributes)) + +(defsubst semantic-tag-set-faux (tag) + "Set TAG to be a new FAUX tag. +FAUX tags represent constructs not found in the source code. +You can identify a faux tag with `semantic-tag-faux-p'" + (semantic--tag-put-property tag :faux-flag t)) + +(defsubst semantic-tag-set-name (tag name) + "Set TAG name to NAME." + (setcar tag name)) + +;;; Copying and cloning tags. +;; +(defsubst semantic-tag-clone (tag &optional name) + "Clone TAG, creating a new TAG. +If optional argument NAME is not nil it specifies a new name for the +cloned tag." + ;; Right now, TAG is a list. + (list (or name (semantic-tag-name tag)) + (semantic-tag-class tag) + (copy-sequence (semantic-tag-attributes tag)) + (copy-sequence (semantic-tag-properties tag)) + (semantic-tag-overlay tag))) + +(defun semantic-tag-copy (tag &optional name keep-file) + "Return a copy of TAG unlinked from the originating buffer. +If optional argument NAME is non-nil it specifies a new name for the +copied tag. +If optional argument KEEP-FILE is non-nil, and TAG was linked to a +buffer, the originating buffer file name is kept in the `:filename' +property of the copied tag. +If KEEP-FILE is a string, and the orginating buffer is NOT available, +then KEEP-FILE is stored on the `:filename' property. +This runs the tag hook `unlink-copy-hook`." + ;; Right now, TAG is a list. + (let ((copy (semantic-tag-clone tag name))) + + ;; Keep the filename if needed. + (when keep-file + (semantic--tag-put-property + copy :filename (or (semantic-tag-file-name copy) + (and (stringp keep-file) + keep-file) + ))) + + (when (semantic-tag-with-position-p tag) + ;; Convert the overlay to a vector, effectively 'unlinking' the tag. + (semantic--tag-set-overlay + copy (vector (semantic-tag-start copy) (semantic-tag-end copy))) + + ;; Force the children to be copied also. + ;;(let ((chil (semantic--tag-copy-list + ;; (semantic-tag-components-with-overlays tag) + ;; keep-file))) + ;;;; Put the list into TAG. + ;;) + + ;; Call the unlink-copy hook. This should tell tools that + ;; this tag is not part of any buffer. + (when (semantic-overlay-p (semantic-tag-overlay tag)) + (semantic--tag-run-hooks copy 'unlink-copy-hook)) + ) + copy)) + +;;(defun semantic--tag-copy-list (tags &optional keep-file) +;; "Make copies of TAGS and return the list of TAGS." +;; (let ((out nil)) +;; (dolist (tag tags out) +;; (setq out (cons (semantic-tag-copy tag nil keep-file) +;; out)) +;; ))) + +(defun semantic--tag-copy-properties (tag1 tag2) + "Copy private properties from TAG1 to TAG2. +Return TAG2. +This function is for internal use only." + (let ((plist (semantic-tag-properties tag1))) + (while plist + (semantic--tag-put-property tag2 (car plist) (nth 1 plist)) + (setq plist (nthcdr 2 plist))) + tag2)) + +;;; DEEP COPIES +;; +(defun semantic-tag-deep-copy-one-tag (tag &optional filter) + "Make a deep copy of TAG, applying FILTER to each child-tag. +Properties and overlay info are not copied. +FILTER takes TAG as an argument, and should returns a semantic-tag. +It is safe for FILTER to modify the input tag and return it." + (when (not filter) (setq filter 'identity)) + (when (not (semantic-tag-p tag)) + (signal 'wrong-type-argument (list tag 'semantic-tag-p))) + (funcall filter (list (semantic-tag-name tag) + (semantic-tag-class tag) + (semantic--tag-deep-copy-attributes + (semantic-tag-attributes tag) filter) + nil + nil))) + +(defun semantic--tag-deep-copy-attributes (attrs &optional filter) + "Make a deep copy of ATTRS, applying FILTER to each child-tag. + +It is safe to modify ATTR, and return a permutaion of that list. + +FILTER takes TAG as an argument, and should returns a semantic-tag. +It is safe for FILTER to modify the input tag and return it." + (when (car attrs) + (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag")) + (cons (car attrs) + (cons (semantic--tag-deep-copy-value (nth 1 attrs) filter) + (semantic--tag-deep-copy-attributes (nthcdr 2 attrs) filter))))) + +(defun semantic--tag-deep-copy-value (value &optional filter) + "Make a deep copy of VALUE, applying FILTER to each child-tag. + +It is safe to modify VALUE, and return a permutaion of that list. + +FILTER takes TAG as an argument, and should returns a semantic-tag. +It is safe for FILTER to modify the input tag and return it." + (cond + ;; Another tag. + ((semantic-tag-p value) + (semantic-tag-deep-copy-one-tag value filter)) + + ;; A list of more tags + ((and (listp value) (semantic-tag-p (car value))) + (semantic--tag-deep-copy-tag-list value filter)) + + ;; Some arbitrary data. + (t value))) + +(defun semantic--tag-deep-copy-tag-list (tags &optional filter) + "Make a deep copy of TAGS, applying FILTER to each child-tag. + +It is safe to modify the TAGS list, and return a permutaion of that list. + +FILTER takes TAG as an argument, and should returns a semantic-tag. +It is safe for FILTER to modify the input tag and return it." + (when (car tags) + (if (semantic-tag-p (car tags)) + (cons (semantic-tag-deep-copy-one-tag (car tags) filter) + (semantic--tag-deep-copy-tag-list (cdr tags) filter)) + (cons (car tags) (semantic--tag-deep-copy-tag-list (cdr tags) filter))))) + + +;;; Standard Tag Access +;; + +;;; Common +;; + +(defsubst semantic-tag-modifiers (tag) + "Return the value of the `:typemodifiers' attribute of TAG." + (semantic-tag-get-attribute tag :typemodifiers)) + +(defun semantic-tag-docstring (tag &optional buffer) + "Return the documentation of TAG. +That is the value defined by the `:documentation' attribute. +Optional argument BUFFER indicates where to get the text from. +If not provided, then only the POSITION can be provided. + +If you want to get documentation for languages that do not store +the documentation string in the tag itself, use +`semantic-documentation-for-tag' instead." + (let ((p (semantic-tag-get-attribute tag :documentation))) + (cond + ((stringp p) p) ;; it is the doc string. + + ((semantic-lex-token-with-text-p p) + (semantic-lex-token-text p)) + + ((and (semantic-lex-token-without-text-p p) + buffer) + (with-current-buffer buffer + (semantic-lex-token-text (car (semantic-lex p (1+ p)))))) + + (t nil)))) + +;;; Generic attributes for tags of any class. +;; +(defsubst semantic-tag-named-parent (tag) + "Return the parent of TAG. +That is the value of the `:parent' attribute. +If a definition can occur outside an actual parent structure, but +refers to that parent by name, then the :parent attribute should be used." + (semantic-tag-get-attribute tag :parent)) + +;;; Tags of class `type' + +(defun semantic-tag-type-superclasses (tag) + "Return the list of superclass names of the type that TAG describes." + (let ((supers (semantic-tag-get-attribute tag :superclasses))) + (cond ((stringp supers) + ;; If we have a string, make it a list. + (list supers)) + ((semantic-tag-p supers) + ;; If we have one tag, return just the name. + (list (semantic-tag-name supers))) + ((and (consp supers) (semantic-tag-p (car supers))) + ;; If we have a tag list, then return the names. + (mapcar (lambda (s) (semantic-tag-name s)) + supers)) + ((consp supers) + ;; A list of something, return it. + supers)))) + +(defun semantic--tag-find-parent-by-name (name supers) + "Find the superclass NAME in the list of SUPERS. +If a simple search doesn't do it, try splitting up the names +in SUPERS." + (let ((stag nil)) + (setq stag (semantic-find-first-tag-by-name name supers)) + + (when (not stag) + (dolist (S supers) + (let* ((sname (semantic-tag-name S)) + (splitparts (semantic-analyze-split-name sname)) + (parts (if (stringp splitparts) + (list splitparts) + (nreverse splitparts)))) + (when (string= name (car parts)) + (setq stag S)) + ))) + + stag)) + +(defun semantic-tag-type-superclass-protection (tag parentstring) + "Return the inheritance protection in TAG from PARENTSTRING. +PARENTSTRING is the name of the parent being inherited. +The return protection is a symbol, 'public, 'protection, and 'private." + (let ((supers (semantic-tag-get-attribute tag :superclasses))) + (cond ((stringp supers) + 'public) + ((semantic-tag-p supers) + (let ((prot (semantic-tag-get-attribute supers :protection))) + (or (cdr (assoc prot '(("public" . public) + ("protected" . protected) + ("private" . private)))) + 'public))) + ((and (consp supers) (stringp (car supers))) + 'public) + ((and (consp supers) (semantic-tag-p (car supers))) + (let* ((stag (semantic--tag-find-parent-by-name parentstring supers)) + (prot (when stag + (semantic-tag-get-attribute stag :protection)))) + (or (cdr (assoc prot '(("public" . public) + ("protected" . protected) + ("private" . private)))) + (when (equal prot "unspecified") + (if (semantic-tag-of-type-p tag "class") + 'private + 'public)) + 'public)))) + )) + +(defsubst semantic-tag-type-interfaces (tag) + "Return the list of interfaces of the type that TAG describes." + ;; @todo - make this as robust as the above. + (semantic-tag-get-attribute tag :interfaces)) + +;;; Tags of class `function' +;; +(defsubst semantic-tag-function-arguments (tag) + "Return the arguments of the function that TAG describes. +That is the value of the `:arguments' attribute." + (semantic-tag-get-attribute tag :arguments)) + +(defsubst semantic-tag-function-throws (tag) + "Return the exceptions the function that TAG describes can throw. +That is the value of the `:throws' attribute." + (semantic-tag-get-attribute tag :throws)) + +(defsubst semantic-tag-function-parent (tag) + "Return the parent of the function that TAG describes. +That is the value of the `:parent' attribute. +A function has a parent if it is a method of a class, and if the +function does not appear in body of it's parent class." + (semantic-tag-named-parent tag)) + +(defsubst semantic-tag-function-destructor-p (tag) + "Return non-nil if TAG describes a destructor function. +That is the value of the `:destructor-flag' attribute." + (semantic-tag-get-attribute tag :destructor-flag)) + +(defsubst semantic-tag-function-constructor-p (tag) + "Return non-nil if TAG describes a constructor function. +That is the value of the `:constructor-flag' attribute." + (semantic-tag-get-attribute tag :constructor-flag)) + +;;; Tags of class `variable' +;; +(defsubst semantic-tag-variable-default (tag) + "Return the default value of the variable that TAG describes. +That is the value of the attribute `:default-value'." + (semantic-tag-get-attribute tag :default-value)) + +(defsubst semantic-tag-variable-constant-p (tag) + "Return non-nil if the variable that TAG describes is a constant. +That is the value of the attribute `:constant-flag'." + (semantic-tag-get-attribute tag :constant-flag)) + +;;; Tags of class `include' +;; +(defsubst semantic-tag-include-system-p (tag) + "Return non-nil if the include that TAG describes is a system include. +That is the value of the attribute `:system-flag'." + (semantic-tag-get-attribute tag :system-flag)) + +(define-overloadable-function semantic-tag-include-filename (tag) + "Return a filename representation of TAG. +The default action is to return the `semantic-tag-name'. +Some languages do not use full filenames in their include statements. +Override this method to translate the code represenation +into a filename. (A relative filename if necessary.) + +See `semantic-dependency-tag-file' to expand an include +tag to a full file name.") + +(defun semantic-tag-include-filename-default (tag) + "Return a filename representation of TAG. +Returns `semantic-tag-name'." + (semantic-tag-name tag)) + +;;; Tags of class `code' +;; +(defsubst semantic-tag-code-detail (tag) + "Return detail information from code that TAG describes. +That is the value of the attribute `:detail'." + (semantic-tag-get-attribute tag :detail)) + +;;; Tags of class `alias' +;; +(defsubst semantic-tag-new-alias (name meta-tag-class value &rest attributes) + "Create a semantic tag of class alias. +NAME is a name for this alias. +META-TAG-CLASS is the class of the tag this tag is an alias. +VALUE is the aliased definition. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'alias + :aliasclass meta-tag-class + :definition value + attributes)) + +(defsubst semantic-tag-alias-class (tag) + "Return the class of tag TAG is an alias." + (semantic-tag-get-attribute tag :aliasclass)) + +;;;###autoload +(define-overloadable-function semantic-tag-alias-definition (tag) + "Return the definition TAG is an alias. +The returned value is a tag of the class that +`semantic-tag-alias-class' returns for TAG. +The default is to return the value of the :definition attribute. +Return nil if TAG is not of class 'alias." + (when (semantic-tag-of-class-p tag 'alias) + (:override + (semantic-tag-get-attribute tag :definition)))) + +;;; Language Specific Tag access via overload +;; +;;;###autoload +(define-overloadable-function semantic-tag-components (tag) + "Return a list of components for TAG. +A Component is a part of TAG which itself may be a TAG. +Examples include the elements of a structure in a +tag of class `type, or the list of arguments to a +tag of class 'function." + ) + +(defun semantic-tag-components-default (tag) + "Return a list of components for TAG. +Perform the described task in `semantic-tag-components'." + (cond ((semantic-tag-of-class-p tag 'type) + (semantic-tag-type-members tag)) + ((semantic-tag-of-class-p tag 'function) + (semantic-tag-function-arguments tag)) + (t nil))) + +;;;###autoload +(define-overloadable-function semantic-tag-components-with-overlays (tag) + "Return the list of top level components belonging to TAG. +Children are any sub-tags which contain overlays. + +Default behavior is to get `semantic-tag-components' in addition +to the components of an anonymous types (if applicable.) + +Note for language authors: + If a mode defines a language tag that has tags in it with overlays +you should still return them with this function. +Ignoring this step will prevent several features from working correctly." + ) + +(defun semantic-tag-components-with-overlays-default (tag) + "Return the list of top level components belonging to TAG. +Children are any sub-tags which contain overlays. +The default action collects regular components of TAG, in addition +to any components beloning to an anonymous type." + (let ((explicit-children (semantic-tag-components tag)) + (type (semantic-tag-type tag)) + (anon-type-children nil) + (all-children nil)) + ;; Identify if this tag has an anonymous structure as + ;; its type. This implies it may have children with overlays. + (when (and type (semantic-tag-p type)) + (setq anon-type-children (semantic-tag-components type)) + ;; Add anonymous children + (while anon-type-children + (when (semantic-tag-with-position-p (car anon-type-children)) + (setq all-children (cons (car anon-type-children) all-children))) + (setq anon-type-children (cdr anon-type-children)))) + ;; Add explicit children + (while explicit-children + (when (semantic-tag-with-position-p (car explicit-children)) + (setq all-children (cons (car explicit-children) all-children))) + (setq explicit-children (cdr explicit-children))) + ;; Return + (nreverse all-children))) + +(defun semantic-tag-children-compatibility (tag &optional positiononly) + "Return children of TAG. +If POSITIONONLY is nil, use `semantic-tag-components'. +If POSITIONONLY is non-nil, use `semantic-tag-components-with-overlays'. +DO NOT use this fcn in new code. Use one of the above instead." + (if positiononly + (semantic-tag-components-with-overlays tag) + (semantic-tag-components tag))) + +;;; Tag Region +;; +;; A Tag represents a region in a buffer. You can narrow to that tag. +;; +(defun semantic-narrow-to-tag (&optional tag) + "Narrow to the region specified by the bounds of TAG. +See `semantic-tag-bounds'." + (interactive) + (if (not tag) (setq tag (semantic-current-tag))) + (narrow-to-region (semantic-tag-start tag) + (semantic-tag-end tag))) + +(defmacro semantic-with-buffer-narrowed-to-current-tag (&rest body) + "Execute BODY with the buffer narrowed to the current tag." + `(save-restriction + (semantic-narrow-to-tag (semantic-current-tag)) + ,@body)) +(put 'semantic-with-buffer-narrowed-to-current-tag 'lisp-indent-function 0) +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec semantic-with-buffer-narrowed-to-current-tag + (def-body)))) + +(defmacro semantic-with-buffer-narrowed-to-tag (tag &rest body) + "Narrow to TAG, and execute BODY." + `(save-restriction + (semantic-narrow-to-tag ,tag) + ,@body)) +(put 'semantic-with-buffer-narrowed-to-tag 'lisp-indent-function 1) +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec semantic-with-buffer-narrowed-to-tag + (def-body)))) + +;;; Tag Hooks +;; +;; Semantic may want to provide special hooks when specific operations +;; are about to happen on a given tag. These routines allow for hook +;; maintenance on a tag. + +;; Internal global variable used to manage tag hooks. For example, +;; some implementation of `remove-hook' checks that the hook variable +;; is `default-boundp'. +(defvar semantic--tag-hook-value) + +(defun semantic-tag-add-hook (tag hook function &optional append) + "Onto TAG, add to the value of HOOK the function FUNCTION. +FUNCTION is added (if necessary) at the beginning of the hook list +unless the optional argument APPEND is non-nil, in which case +FUNCTION is added at the end. +HOOK should be a symbol, and FUNCTION may be any valid function. +See also the function `add-hook'." + (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))) + (add-hook 'semantic--tag-hook-value function append) + (semantic--tag-put-property tag hook semantic--tag-hook-value) + semantic--tag-hook-value)) + +(defun semantic-tag-remove-hook (tag hook function) + "Onto TAG, remove from the value of HOOK the function FUNCTION. +HOOK should be a symbol, and FUNCTION may be any valid function. If +FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in +the list of hooks to run in HOOK, then nothing is done. +See also the function `remove-hook'." + (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))) + (remove-hook 'semantic--tag-hook-value function) + (semantic--tag-put-property tag hook semantic--tag-hook-value) + semantic--tag-hook-value)) + +(defun semantic--tag-run-hooks (tag hook &rest args) + "Run for TAG all expressions saved on the property HOOK. +Each hook expression must take at least one argument, the TAG. +For any given situation, additional ARGS may be passed." + (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)) + (arglist (cons tag args))) + (condition-case err + ;; If a hook bombs, ignore it! Usually this is tied into + ;; some sort of critical system. + (apply 'run-hook-with-args 'semantic--tag-hook-value arglist) + (error (message "Error: %S" err))))) + +;;; Tags and Overlays +;; +;; Overlays are used so that we can quickly identify tags from +;; buffer positions and regions using built in Emacs commands. +;; + +(defsubst semantic--tag-unlink-list-from-buffer (tags) + "Convert TAGS from using an overlay to using an overlay proxy. +This function is for internal use only." + (mapcar 'semantic--tag-unlink-from-buffer tags)) + +(defun semantic--tag-unlink-from-buffer (tag) + "Convert TAG from using an overlay to using an overlay proxy. +This function is for internal use only." + (when (semantic-tag-p tag) + (let ((o (semantic-tag-overlay tag))) + (when (semantic-overlay-p o) + (semantic--tag-set-overlay + tag (vector (semantic-overlay-start o) + (semantic-overlay-end o))) + (semantic-overlay-delete o)) + ;; Look for a link hook on TAG. + (semantic--tag-run-hooks tag 'unlink-hook) + ;; Fix the sub-tags which contain overlays. + (semantic--tag-unlink-list-from-buffer + (semantic-tag-components-with-overlays tag))))) + +(defsubst semantic--tag-link-list-to-buffer (tags) + "Convert TAGS from using an overlay proxy to using an overlay. +This function is for internal use only." + (mapcar 'semantic--tag-link-to-buffer tags)) + +(defun semantic--tag-link-to-buffer (tag) + "Convert TAG from using an overlay proxy to using an overlay. +This function is for internal use only." + (when (semantic-tag-p tag) + (let ((o (semantic-tag-overlay tag))) + (when (and (vectorp o) (= (length o) 2)) + (setq o (semantic-make-overlay (aref o 0) (aref o 1) + (current-buffer))) + (semantic--tag-set-overlay tag o) + (semantic-overlay-put o 'semantic tag) + ;; Clear the :filename property + (semantic--tag-put-property tag :filename nil)) + ;; Look for a link hook on TAG. + (semantic--tag-run-hooks tag 'link-hook) + ;; Fix the sub-tags which contain overlays. + (semantic--tag-link-list-to-buffer + (semantic-tag-components-with-overlays tag))))) + +(defun semantic--tag-unlink-cache-from-buffer () + "Convert all tags in the current cache to use overlay proxys. +This function is for internal use only." + (semantic--tag-unlink-list-from-buffer + ;; @todo- use fetch-tags-fast? + (semantic-fetch-tags))) + +(defvar semantic--buffer-cache) + +(defun semantic--tag-link-cache-to-buffer () + "Convert all tags in the current cache to use overlays. +This function is for internal use only." + (condition-case nil + ;; In this unique case, we cannot call the usual toplevel fn. + ;; because we don't want a reparse, we want the old overlays. + (semantic--tag-link-list-to-buffer + semantic--buffer-cache) + ;; Recover when there is an error restoring the cache. + (error (message "Error recovering tag list") + (semantic-clear-toplevel-cache) + nil))) + +;;; Tag Cooking +;; +;; Raw tags from a parser follow a different positional format than +;; those used in the buffer cache. Raw tags need to be cooked into +;; semantic cache friendly tags for use by the masses. +;; +(defsubst semantic--tag-expanded-p (tag) + "Return non-nil if TAG is expanded. +This function is for internal use only. +See also the function `semantic--expand-tag'." + ;; In fact a cooked tag is actually a list of cooked tags + ;; because a raw tag can be expanded in several cooked ones! + (when (consp tag) + (while (and (semantic-tag-p (car tag)) + (vectorp (semantic-tag-overlay (car tag)))) + (setq tag (cdr tag))) + (null tag))) + +(defvar semantic-tag-expand-function nil + "Function used to expand a tag. +It is passed each tag production, and must return a list of tags +derived from it, or nil if it does not need to be expanded. + +Languages with compound definitions should use this function to expand +from one compound symbol into several. For example, in C or Java the +following definition is easily parsed into one tag: + + int a, b; + +This function should take this compound tag and turn it into two tags, +one for A, and the other for B.") +(make-variable-buffer-local 'semantic-tag-expand-function) + +(defun semantic--tag-expand (tag) + "Convert TAG from a raw state to a cooked state, and expand it. +Returns a list of cooked tags. + + The parser returns raw tags with positional data START END at the +end of the tag data structure (a list for now). We convert it from +that to a cooked state that uses an overlay proxy, that is, a vector +\[START END]. + + The raw tag is changed with side effects and maybe expanded in +several derived tags when the variable `semantic-tag-expand-function' +is set. + +This function is for internal use only." + (if (semantic--tag-expanded-p tag) + ;; Just return TAG if it is already expanded (by a grammar + ;; semantic action), or if it isn't recognized as a valid + ;; semantic tag. + tag + + ;; Try to cook the tag. This code will be removed when tag will + ;; be directly created with the right format. + (condition-case nil + (let ((ocdr (semantic--tag-overlay-cdr tag))) + ;; OCDR contains the sub-list of TAG whose car is the + ;; OVERLAY part of TAG. That is, a list (OVERLAY START END). + ;; Convert it into an overlay proxy ([START END]). + (semantic--tag-set-overlay + tag (vector (nth 1 ocdr) (nth 2 ocdr))) + ;; Remove START END positions at end of tag. + (setcdr ocdr nil) + ;; At this point (length TAG) must be 5! + ;;(unless (= (length tag) 5) + ;; (error "Tag expansion failed")) + ) + (error + (message "A Rule must return a single tag-line list!") + (debug tag) + nil)) + +;; @todo - I think we've waited long enough. Lets find out. +;; +;; ;; Compatibility code to be removed in future versions. +;; (unless semantic-tag-expand-function +;; ;; This line throws a byte compiler warning. +;; (setq semantic-tag-expand-function semantic-expand-nonterminal) +;; ) + + ;; Expand based on local configuration + (if semantic-tag-expand-function + (or (funcall semantic-tag-expand-function tag) + (list tag)) + (list tag)))) + +;; Foreign tags +;; +(defmacro semantic-foreign-tag-invalid (tag) + "Signal that TAG is an invalid foreign tag." + `(signal 'wrong-type-argument '(semantic-foreign-tag-p ,tag))) + +(defsubst semantic-foreign-tag-p (tag) + "Return non-nil if TAG is a foreign tag. +That is, a tag unlinked from the originating buffer, which carries the +originating buffer file name, and major mode." + (and (semantic-tag-p tag) + (semantic--tag-get-property tag :foreign-flag))) + +(defsubst semantic-foreign-tag-check (tag) + "Check that TAG is a valid foreign tag. +Signal an error if not." + (or (semantic-foreign-tag-p tag) + (semantic-foreign-tag-invalid tag))) + +(defun semantic-foreign-tag (&optional tag) + "Return a copy of TAG as a foreign tag, or nil if it can't be done. +TAG defaults to the tag at point in current buffer. +See also `semantic-foreign-tag-p'." + (or tag (setq tag (semantic-current-tag))) + (when (semantic-tag-p tag) + (let ((ftag (semantic-tag-copy tag nil t)) + ;; Do extra work for the doc strings, since this is a + ;; common use case. + (doc (condition-case nil + (semantic-documentation-for-tag tag) + (error nil)))) + ;; A foreign tag must carry its originating buffer file name! + (when (semantic--tag-get-property ftag :filename) + (semantic--tag-put-property ftag :mode (semantic-tag-mode tag)) + (semantic--tag-put-property ftag :documentation doc) + (semantic--tag-put-property ftag :foreign-flag t) + ftag)))) + +;; High level obtain/insert foreign tag overloads +;; +;;;###autoload +(define-overloadable-function semantic-obtain-foreign-tag (&optional tag) + "Obtain a foreign tag from TAG. +TAG defaults to the tag at point in current buffer. +Return the obtained foreign tag or nil if failed." + (semantic-foreign-tag tag)) + +(defun semantic-insert-foreign-tag-default (foreign-tag) + "Insert FOREIGN-TAG into the current buffer. +The default behavior assumes the current buffer is a language file, +and attempts to insert a prototype/function call." + ;; Long term goal: Have a mechanism for a tempo-like template insert + ;; for the given tag. + (insert (semantic-format-tag-prototype foreign-tag))) + +;;;###autoload +(define-overloadable-function semantic-insert-foreign-tag (foreign-tag) + "Insert FOREIGN-TAG into the current buffer. +Signal an error if FOREIGN-TAG is not a valid foreign tag. +This function is overridable with the symbol `insert-foreign-tag'." + (semantic-foreign-tag-check foreign-tag) + (:override) + (message (semantic-format-tag-summarize foreign-tag))) + +;;; Support log modes here +(define-mode-local-override semantic-insert-foreign-tag + log-edit-mode (foreign-tag) + "Insert foreign tags into log-edit mode." + (insert (concat "(" (semantic-format-tag-name foreign-tag) "): "))) + +(define-mode-local-override semantic-insert-foreign-tag + change-log-mode (foreign-tag) + "Insert foreign tags into log-edit mode." + (insert (concat "(" (semantic-format-tag-name foreign-tag) "): "))) + + +;;; EDEBUG display support +;; +(eval-after-load "cedet-edebug" + '(progn + (cedet-edebug-add-print-override + '(semantic-tag-p object) + '(concat "#<TAG " (semantic-format-tag-name object) ">")) + (cedet-edebug-add-print-override + '(and (listp object) (semantic-tag-p (car object))) + '(cedet-edebug-prin1-recurse object)) + )) + +;;; Compatibility +;; +(defconst semantic-token-version + semantic-tag-version) +(defconst semantic-token-incompatible-version + semantic-tag-incompatible-version) + +(semantic-alias-obsolete 'semantic-token-name + 'semantic-tag-name) + +(semantic-alias-obsolete 'semantic-token-token + 'semantic-tag-class) + +(semantic-alias-obsolete 'semantic-token-extra-specs + 'semantic-tag-attributes) + +(semantic-alias-obsolete 'semantic-token-properties + 'semantic-tag-properties) + +(semantic-alias-obsolete 'semantic-token-properties-cdr + 'semantic--tag-properties-cdr) + +(semantic-alias-obsolete 'semantic-token-overlay + 'semantic-tag-overlay) + +(semantic-alias-obsolete 'semantic-token-overlay-cdr + 'semantic--tag-overlay-cdr) + +(semantic-alias-obsolete 'semantic-token-start + 'semantic-tag-start) + +(semantic-alias-obsolete 'semantic-token-end + 'semantic-tag-end) + +(semantic-alias-obsolete 'semantic-token-extent + 'semantic-tag-bounds) + +(semantic-alias-obsolete 'semantic-token-buffer + 'semantic-tag-buffer) + +(semantic-alias-obsolete 'semantic-token-put + 'semantic--tag-put-property) + +(semantic-alias-obsolete 'semantic-token-put-no-side-effect + 'semantic--tag-put-property-no-side-effect) + +(semantic-alias-obsolete 'semantic-token-get + 'semantic--tag-get-property) + +(semantic-alias-obsolete 'semantic-token-add-extra-spec + 'semantic-tag-put-attribute) + +(semantic-alias-obsolete 'semantic-token-extra-spec + 'semantic-tag-get-attribute) + +(semantic-alias-obsolete 'semantic-token-type + 'semantic-tag-type) + +(semantic-alias-obsolete 'semantic-token-modifiers + 'semantic-tag-modifiers) + +(semantic-alias-obsolete 'semantic-token-docstring + 'semantic-tag-docstring) + +(semantic-alias-obsolete 'semantic-token-type-parts + 'semantic-tag-type-members) + +(defsubst semantic-token-type-parent (tag) + "Return the parent of the type that TAG describes. +The return value is a list. A value of nil means no parents. +The `car' of the list is either the parent class, or a list +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' \ +and `semantic-tag-type-interfaces' instead") + +(semantic-alias-obsolete 'semantic-token-type-parent-superclass + 'semantic-tag-type-superclasses) + +(semantic-alias-obsolete 'semantic-token-type-parent-implement + 'semantic-tag-type-interfaces) + +(semantic-alias-obsolete 'semantic-token-type-extra-specs + 'semantic-tag-attributes) + +(semantic-alias-obsolete 'semantic-token-type-extra-spec + 'semantic-tag-get-attribute) + +(semantic-alias-obsolete 'semantic-token-type-modifiers + 'semantic-tag-modifiers) + +(semantic-alias-obsolete 'semantic-token-function-args + 'semantic-tag-function-arguments) + +(semantic-alias-obsolete 'semantic-token-function-extra-specs + 'semantic-tag-attributes) + +(semantic-alias-obsolete 'semantic-token-function-extra-spec + 'semantic-tag-get-attribute) + +(semantic-alias-obsolete 'semantic-token-function-modifiers + 'semantic-tag-modifiers) + +(semantic-alias-obsolete 'semantic-token-function-throws + 'semantic-tag-function-throws) + +(semantic-alias-obsolete 'semantic-token-function-parent + 'semantic-tag-function-parent) + +(semantic-alias-obsolete 'semantic-token-function-destructor + 'semantic-tag-function-destructor-p) + +(semantic-alias-obsolete 'semantic-token-variable-default + 'semantic-tag-variable-default) + +(semantic-alias-obsolete 'semantic-token-variable-extra-specs + 'semantic-tag-attributes) + +(semantic-alias-obsolete 'semantic-token-variable-extra-spec + 'semantic-tag-get-attribute) + +(semantic-alias-obsolete 'semantic-token-variable-modifiers + 'semantic-tag-modifiers) + +(semantic-alias-obsolete 'semantic-token-variable-const + 'semantic-tag-variable-constant-p) + +(semantic-alias-obsolete 'semantic-token-variable-optsuffix + 'semantic-tag-variable-optsuffix) + +(semantic-alias-obsolete 'semantic-token-include-system + 'semantic-tag-include-system-p) + +(semantic-alias-obsolete 'semantic-token-p + 'semantic-tag-p) + +(semantic-alias-obsolete 'semantic-token-with-position-p + 'semantic-tag-with-position-p) + +(semantic-alias-obsolete 'semantic-tag-make-assoc-list + 'semantic-tag-make-plist) + +(semantic-alias-obsolete 'semantic-nonterminal-children + 'semantic-tag-children-compatibility) + +(semantic-alias-obsolete 'semantic-narrow-to-token + 'semantic-narrow-to-tag) + +(semantic-alias-obsolete 'semantic-with-buffer-narrowed-to-current-token + 'semantic-with-buffer-narrowed-to-current-tag) + +(semantic-alias-obsolete 'semantic-with-buffer-narrowed-to-token + 'semantic-with-buffer-narrowed-to-tag) + +(semantic-alias-obsolete 'semantic-deoverlay-token + 'semantic--tag-unlink-from-buffer) + +(semantic-alias-obsolete 'semantic-overlay-token + 'semantic--tag-link-to-buffer) + +(semantic-alias-obsolete 'semantic-deoverlay-list + 'semantic--tag-unlink-list-from-buffer) + +(semantic-alias-obsolete 'semantic-overlay-list + 'semantic--tag-link-list-to-buffer) + +(semantic-alias-obsolete 'semantic-deoverlay-cache + 'semantic--tag-unlink-cache-from-buffer) + +(semantic-alias-obsolete 'semantic-overlay-cache + 'semantic--tag-link-cache-to-buffer) + +(semantic-alias-obsolete 'semantic-cooked-token-p + 'semantic--tag-expanded-p) + +(semantic-varalias-obsolete 'semantic-expand-nonterminal + 'semantic-tag-expand-function) + +(semantic-alias-obsolete 'semantic-raw-to-cooked-token + 'semantic--tag-expand) + +;; Lets test this out during this short transition. +(semantic-alias-obsolete 'semantic-clone-tag + 'semantic-tag-clone) + +(semantic-alias-obsolete 'semantic-token + 'semantic-tag) + +(semantic-alias-obsolete 'semantic-token-new-variable + 'semantic-tag-new-variable) + +(semantic-alias-obsolete 'semantic-token-new-function + 'semantic-tag-new-function) + +(semantic-alias-obsolete 'semantic-token-new-type + 'semantic-tag-new-type) + +(semantic-alias-obsolete 'semantic-token-new-include + 'semantic-tag-new-include) + +(semantic-alias-obsolete 'semantic-token-new-package + 'semantic-tag-new-package) + +(semantic-alias-obsolete 'semantic-equivalent-tokens-p + 'semantic-equivalent-tag-p) + +(provide 'semantic-tag) + +;;; semantic-tag.el ends here
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic.el Sun Aug 23 03:46:01 2009 +0000 @@ -0,0 +1,845 @@ +;;; semantic.el --- Semantic buffer evaluator. + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; API for providing the semantic content of a buffer. +;; +;; The semantic API provides an interface to a series of different parser +;; implementations. Each parser outputs a parse tree in a similar format +;; designed to handle typical functional and object oriented languages. + +(eval-and-compile + ;; Other package depend on this value at compile time via inversion. + (defvar semantic-version "2.0pre7" + "Current version of Semantic.")) + +;; (require 'working) +(require 'assoc) +(require 'semantic-tag) +(require 'semantic-lex) + +(declare-function inversion-test "inversion") + +(defun semantic-require-version (major minor &optional beta) + "Non-nil if this version of semantic does not satisfy a specific version. +Arguments can be: + + (MAJOR MINOR &optional BETA) + + Values MAJOR and MINOR must be integers. BETA can be an integer, or +excluded if a released version is required. + +It is assumed that if the current version is newer than that specified, +everything passes. Exceptions occur when known incompatibilities are +introduced." + (require 'inversion) + (inversion-test 'semantic + (concat major "." minor + (when beta (concat "beta" beta))))) + +(defgroup semantic nil + "Parser Generator and parser framework." + :group 'lisp) + +(defgroup semantic-faces nil + "Faces used for Semantic enabled tools." + :group 'semantic) + +(require 'semantic-fw) + +;;; Code: +;; + +;;; Variables and Configuration +;; +(defvar semantic--parse-table nil + "Variable that defines how to parse top level items in a buffer. +This variable is for internal use only, and its content depends on the +external parser used.") +(make-variable-buffer-local 'semantic--parse-table) +(semantic-varalias-obsolete 'semantic-toplevel-bovine-table + 'semantic--parse-table) + +(defvar semantic-symbol->name-assoc-list + '((type . "Types") + (variable . "Variables") + (function . "Functions") + (include . "Dependencies") + (package . "Provides")) + "Association between symbols returned, and a string. +The string is used to represent a group of objects of the given type. +It is sometimes useful for a language to use a different string +in place of the default, even though that language will still +return a symbol. For example, Java return's includes, but the +string can be replaced with `Imports'.") +(make-variable-buffer-local 'semantic-symbol->name-assoc-list) + +(defvar semantic-symbol->name-assoc-list-for-type-parts nil + "Like `semantic-symbol->name-assoc-list' for type parts. +Some tags that have children (see `semantic-tag-children-compatibility') +will want to define the names of classes of tags differently than at +the top level. For example, in C++, a Function may be called a +Method. In addition, there may be new types of tags that exist only +in classes, such as protection labels.") +(make-variable-buffer-local 'semantic-symbol->name-assoc-list-for-type-parts) + +(defvar semantic-case-fold nil + "Value for `case-fold-search' when parsing.") +(make-variable-buffer-local 'semantic-case-fold) + +(defvar semantic-expand-nonterminal nil + "Function to call for each nonterminal production. +Return a list of non-terminals derived from the first argument, or nil +if it does not need to be expanded. +Languages with compound definitions should use this function to expand +from one compound symbol into several. For example, in C the definition + int a, b; +is easily parsed into one tag. This function should take this +compound tag and turn it into two tags, one for A, and the other for B.") +(make-variable-buffer-local 'semantic-expand-nonterminal) + +(defvar semantic--buffer-cache nil + "A cache of the fully parsed buffer. +If no significant changes have been made (based on the state) then +this is returned instead of re-parsing the buffer. + + DO NOT USE THIS VARIABLE IN PROGRAMS. + +If you need a tag list, use `semantic-fetch-tags'. If you need the +cached values for some reason, chances are you can, add a hook to +`semantic-after-toplevel-cache-change-hook'.") +(make-variable-buffer-local 'semantic--buffer-cache) +(semantic-varalias-obsolete 'semantic-toplevel-bovine-cache + 'semantic--buffer-cache) + +(defvar semantic-unmatched-syntax-cache nil + "A cached copy of unmatched syntax tokens.") +(make-variable-buffer-local 'semantic-unmatched-syntax-cache) + +(defvar semantic-unmatched-syntax-cache-check nil + "Non nil if the unmatched syntax cache is out of date. +This is tracked with `semantic-change-function'.") +(make-variable-buffer-local 'semantic-unmatched-syntax-cache-check) + +(defvar semantic-edits-are-safe nil + "When non-nil, modifications do not require a reparse. +This prevents tags from being marked dirty, and it prevents top level +edits from causing a cache check. +Use this when writing programs that could cause a full reparse, but +will not change the tag structure, such as adding or updating +`top-level' comments.") + +(defvar semantic-unmatched-syntax-hook nil + "Hooks run when semantic detects syntax not matched in a grammar. +Each individual piece of syntax (such as a symbol or punctuation +character) is called with this hook when it doesn't match in the +grammar, and multiple unmatched syntax elements are not grouped +together. Each hook is called with one argument, which is a list of +syntax tokens created by the semantic lexer. Use the functions +`semantic-lex-token-start', `semantic-lex-token-end' and +`semantic-lex-token-text' to get information about these tokens. The +current buffer is the buffer these tokens are derived from.") + +(defvar semantic--before-fetch-tags-hook nil + "Hooks run before a buffer is parses for tags. +It is called before any request for tags is made via the function +`semantic-fetch-tags' by an application. +If any hook returns a nil value, the cached value is returned +immediately, even if it is empty.") +(semantic-varalias-obsolete 'semantic-before-toplevel-bovination-hook + 'semantic--before-fetch-tags-hook) + +(defvar semantic-after-toplevel-bovinate-hook nil + "Hooks run after a toplevel parse. +It is not run if the toplevel parse command is called, and buffer does +not need to be fully reparsed. +For language specific hooks, make sure you define this as a local hook. + +This hook should not be used any more. +Use `semantic-after-toplevel-cache-change-hook' instead.") +(make-obsolete-variable 'semantic-after-toplevel-bovinate-hook nil) + +(defvar semantic-after-toplevel-cache-change-hook nil + "Hooks run after the buffer tag list has changed. +This list will change when a buffer is reparsed, or when the tag list +in a buffer is cleared. It is *NOT* called if the current tag list is +partially reparsed. + +Hook functions must take one argument, which is the new list of tags +associated with this buffer. + +For language specific hooks, make sure you define this as a local hook.") + +(defvar semantic-before-toplevel-cache-flush-hook nil + "Hooks run before the toplevel tag cache is flushed. +For language specific hooks, make sure you define this as a local +hook. This hook is called before a corresponding +`semantic-after-toplevel-cache-change-hook' which is also called +during a flush when the cache is given a new value of nil.") + +(defcustom semantic-dump-parse nil + "When non-nil, dump parsing information." + :group 'semantic + :type 'boolean) + +(defvar semantic-parser-name "LL" + "Optional name of the parser used to parse input stream.") +(make-variable-buffer-local 'semantic-parser-name) + +;;; Parse tree state management API +;; +(defvar semantic-parse-tree-state 'needs-rebuild + "State of the current parse tree.") +(make-variable-buffer-local 'semantic-parse-tree-state) + +(defmacro semantic-parse-tree-unparseable () + "Indicate that the current buffer is unparseable. +It is also true that the parse tree will need either updating or +a rebuild. This state will be changed when the user edits the buffer." + `(setq semantic-parse-tree-state 'unparseable)) + +(defmacro semantic-parse-tree-unparseable-p () + "Return non-nil if the current buffer has been marked unparseable." + `(eq semantic-parse-tree-state 'unparseable)) + +(defmacro semantic-parse-tree-set-needs-update () + "Indicate that the current parse tree needs to be updated. +The parse tree can be updated by `semantic-parse-changes'." + `(setq semantic-parse-tree-state 'needs-update)) + +(defmacro semantic-parse-tree-needs-update-p () + "Return non-nil if the current parse tree needs to be updated." + `(eq semantic-parse-tree-state 'needs-update)) + +(defmacro semantic-parse-tree-set-needs-rebuild () + "Indicate that the current parse tree needs to be rebuilt. +The parse tree must be rebuilt by `semantic-parse-region'." + `(setq semantic-parse-tree-state 'needs-rebuild)) + +(defmacro semantic-parse-tree-needs-rebuild-p () + "Return non-nil if the current parse tree needs to be rebuilt." + `(eq semantic-parse-tree-state 'needs-rebuild)) + +(defmacro semantic-parse-tree-set-up-to-date () + "Indicate that the current parse tree is up to date." + `(setq semantic-parse-tree-state nil)) + +(defmacro semantic-parse-tree-up-to-date-p () + "Return non-nil if the current parse tree is up to date." + `(null semantic-parse-tree-state)) + +;;; Interfacing with the system +;; +(defcustom semantic-inhibit-functions nil + "List of functions to call with no arguments before Semantic is setup. +If any of these functions returns non-nil, the current buffer is not +setup to use Semantic." + :group 'semantic + :type 'hook) + +(defvar semantic-init-hooks nil + "*Hooks run when a buffer is initialized with a parsing table.") + +(defvar semantic-init-mode-hooks nil + "*Hooks run when a buffer of a particular mode is initialized.") +(make-variable-buffer-local 'semantic-init-mode-hooks) + +(defvar semantic-init-db-hooks nil + "Hooks run when a buffer is initialized with a parsing table for DBs. +This hook is for database functions which intend to swap in a tag table. +This guarantees that the DB will go before other modes that require +a parse of the buffer.") + +(defvar semantic-new-buffer-fcn-was-run nil + "Non nil after `semantic-new-buffer-fcn' has been executed.") +(make-variable-buffer-local 'semantic-new-buffer-fcn-was-run) + +(defsubst semantic-active-p () + "Return non-nil if the current buffer was set up for parsing." + semantic-new-buffer-fcn-was-run) + +(defsubst semantic--umatched-syntax-needs-refresh-p () + "Return non-nil if the unmatched syntax cache needs a refresh. +That is if it is dirty or if the current parse tree isn't up to date." + (or semantic-unmatched-syntax-cache-check + (not (semantic-parse-tree-up-to-date-p)))) + +(defun semantic-new-buffer-fcn () + "Setup the current buffer to use Semantic. +If the major mode is ready for Semantic, and no +`semantic-inhibit-functions' disabled it, the current buffer is setup +to use Semantic, and `semantic-init-hook' is run." + ;; Do stuff if semantic was activated by a mode hook in this buffer, + ;; and not afterwards disabled. + (when (and semantic--parse-table + (not (semantic-active-p)) + (not (run-hook-with-args-until-success + 'semantic-inhibit-functions))) + ;; Make sure that if this buffer is cloned, our tags and overlays + ;; don't go along for the ride. + (add-hook 'clone-indirect-buffer-hook 'semantic-clear-toplevel-cache + nil t) + ;; Specify that this function has done it's work. At this point + ;; we can consider that semantic is active in this buffer. + (setq semantic-new-buffer-fcn-was-run t) + ;; Here are some buffer local variables we can initialize ourselves + ;; of a mode does not choose to do so. + (semantic-lex-init) + ;; Force this buffer to have its cache refreshed. + (semantic-clear-toplevel-cache) + ;; Call DB hooks before regular init hooks + (run-hooks 'semantic-init-db-hooks) + ;; Set up semantic modes + (run-hooks 'semantic-init-hooks) + ;; Set up major-mode specific semantic modes + (run-hooks 'semantic-init-mode-hooks) + )) + +(add-hook 'mode-local-init-hook 'semantic-new-buffer-fcn) + +;; Test the above hook. +;;(add-hook 'semantic-init-hooks (lambda () (message "init for semantic"))) + +(defun semantic-fetch-tags-fast () + "For use in a hook. When only a partial reparse is needed, reparse." + (condition-case nil + (if (semantic-parse-tree-needs-update-p) + (semantic-fetch-tags)) + (error nil)) + semantic--buffer-cache) + +(if (boundp 'eval-defun-hooks) + (add-hook 'eval-defun-hooks 'semantic-fetch-tags-fast)) + +;;; Parsing Commands +;; +(eval-when-compile + (condition-case nil (require 'pp) (error nil))) + +(defvar semantic-edebug nil + "When non-nil, activate the interactive parsing debugger. +Do not set this yourself. Call `semantic-debug'.") + +(defun semantic-elapsed-time (start end) + "Copied from elp.el. Was elp-elapsed-time. +Argument START and END bound the time being calculated." + (+ (* (- (car end) (car start)) 65536.0) + (- (car (cdr end)) (car (cdr start))) + (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0))) + +(defun bovinate (&optional clear) + "Parse the current buffer. Show output in a temp buffer. +Optional argument CLEAR will clear the cache before parsing. +If CLEAR is negative, it will do a full reparse, and also not display +the output buffer." + (interactive "P") + (if clear (semantic-clear-toplevel-cache)) + (if (eq clear '-) (setq clear -1)) + (let* ((start (current-time)) + (out (semantic-fetch-tags)) + (end (current-time))) + (message "Retrieving tags took %.2f seconds." + (semantic-elapsed-time start end)) + (when (or (null clear) (not (listp clear))) + (pop-to-buffer "*Parser Output*") + (require 'pp) + (erase-buffer) + (insert (pp-to-string out)) + (goto-char (point-min))))) + +;;; Functions of the parser plug-in API +;; +;; Overload these functions to create new types of parsers. +;; +(define-overloadable-function semantic-parse-stream (stream nonterminal) + "Parse STREAM, starting at the first NONTERMINAL rule. +For bovine and wisent based parsers, STREAM is from the output of +`semantic-lex', and NONTERMINAL is a rule in the apropriate language +specific rules file. +The default parser table used for bovine or wisent based parsers is +`semantic--parse-table'. + +Must return a list: (STREAM TAGS) where STREAM is the unused elements +from STREAM, and TAGS is the list of semantic tags found, usually only +one tag is returned with the exception of compound statements") + +(define-overloadable-function semantic-parse-changes () + "Reparse changes in the current buffer. +The list of changes are tracked as a series of overlays in the buffer. +When overloading this function, use `semantic-changes-in-region' to +analyze.") + +(define-overloadable-function semantic-parse-region + (start end &optional nonterminal depth returnonerror) + "Parse the area between START and END, and return any tags found. +If END needs to be extended due to a lexical token being too large, it +will be silently ignored. + +Optional arguments: +NONTERMINAL is the rule to start parsing at. +DEPTH specifies the lexical depth to decend for parser that use +lexical analysis as their first step. +RETURNONERROR specifies that parsing should stop on the first +unmatched syntax encountered. When nil, parsing skips the syntax, +adding it to the unmatched syntax cache. + +Must return a list of semantic tags wich have been cooked +\(repositioned properly) but which DO NOT HAVE OVERLAYS associated +with them. When overloading this function, use `semantic--tag-expand' +to cook raw tags.") + +(defun semantic-parse-region-default + (start end &optional nonterminal depth returnonerror) + "Parse the area between START and END, and return any tags found. +If END needs to be extended due to a lexical token being too large, it +will be silently ignored. +Optional arguments: +NONTERMINAL is the rule to start parsing at if it is known. +DEPTH specifies the lexical depth to scan. +RETURNONERROR specifies that parsing should end when encountering +unterminated syntax." + (when (or (null semantic--parse-table) (eq semantic--parse-table t)) + ;; If there is no table, or it was set to t, then we are here by + ;; some other mistake. Do not throw an error deep in the parser. + (error "No support found to parse buffer %S" (buffer-name))) + (save-restriction + (widen) + (when (or (< end start) (> end (point-max))) + (error "Invalid parse region bounds %S, %S" start end)) + (nreverse + (semantic-repeat-parse-whole-stream + (or (cdr (assq start semantic-lex-block-streams)) + (semantic-lex start end depth)) + nonterminal returnonerror)))) + +;;; Parsing functions +;; +(defun semantic-set-unmatched-syntax-cache (unmatched-syntax) + "Set the unmatched syntax cache. +Argument UNMATCHED-SYNTAX is the syntax to set into the cache." + ;; This function is not actually called by the main parse loop. + ;; This is intended for use by semanticdb. + (setq semantic-unmatched-syntax-cache unmatched-syntax + semantic-unmatched-syntax-cache-check nil) + ;; Refresh the display of unmatched syntax tokens if enabled + (run-hook-with-args 'semantic-unmatched-syntax-hook + semantic-unmatched-syntax-cache)) + +(defun semantic-clear-unmatched-syntax-cache () + "Clear the cache of unmatched syntax tokens." + (setq semantic-unmatched-syntax-cache nil + semantic-unmatched-syntax-cache-check t)) + +(defun semantic-unmatched-syntax-tokens () + "Return the list of unmatched syntax tokens." + ;; If the cache need refresh then do a full re-parse. + (if (semantic--umatched-syntax-needs-refresh-p) + ;; To avoid a recursive call, temporarily disable + ;; `semantic-unmatched-syntax-hook'. + (let (semantic-unmatched-syntax-hook) + (condition-case nil + (progn + (semantic-clear-toplevel-cache) + (semantic-fetch-tags)) + (quit + (message "semantic-unmatched-syntax-tokens:\ + parsing of buffer canceled")) + ))) + semantic-unmatched-syntax-cache) + +(defun semantic-clear-toplevel-cache () + "Clear the toplevel tag cache for the current buffer. +Clearing the cache will force a complete reparse next time a tag list +is requested." + (interactive) + (run-hooks 'semantic-before-toplevel-cache-flush-hook) + (setq semantic--buffer-cache nil) + (semantic-clear-unmatched-syntax-cache) + (semantic-clear-parser-warnings) + ;; Nuke all semantic overlays. This is faster than deleting based + ;; on our data structure. + (let ((l (semantic-overlay-lists))) + (mapc 'semantic-delete-overlay-maybe (car l)) + (mapc 'semantic-delete-overlay-maybe (cdr l)) + ) + (semantic-parse-tree-set-needs-rebuild) + ;; Remove this hook which tracks if a buffer is up to date or not. + (remove-hook 'after-change-functions 'semantic-change-function t) + ;; Old model. Delete someday. + ;;(run-hooks 'semantic-after-toplevel-bovinate-hook) + + (run-hook-with-args 'semantic-after-toplevel-cache-change-hook + semantic--buffer-cache) + ) + +(defvar semantic-bovinate-nonterminal-check-obarray) + +(defun semantic--set-buffer-cache (tagtable) + "Set the toplevel cache cache to TAGTABLE." + (setq semantic--buffer-cache tagtable + semantic-unmatched-syntax-cache-check nil + ;; This is specific to the bovine parser. + semantic-bovinate-nonterminal-check-obarray nil) + (semantic-parse-tree-set-up-to-date) + (semantic-make-local-hook 'after-change-functions) + (add-hook 'after-change-functions 'semantic-change-function nil t) + (run-hook-with-args 'semantic-after-toplevel-cache-change-hook + semantic--buffer-cache) + ;; Refresh the display of unmatched syntax tokens if enabled + (run-hook-with-args 'semantic-unmatched-syntax-hook + semantic-unmatched-syntax-cache) + ;; Old Semantic 1.3 hook API. Maybe useful forever? + (run-hooks 'semantic-after-toplevel-bovinate-hook) + ) + +(defvar semantic-working-type 'percent + "*The type of working message to use when parsing. +'percent means we are doing a linear parse through the buffer. +'dynamic means we are reparsing specific tags.") +(semantic-varalias-obsolete 'semantic-bovination-working-type + 'semantic-working-type) + +(defvar semantic-minimum-working-buffer-size (* 1024 5) + "*The minimum size of a buffer before working messages are displayed. +Buffers smaller than will parse silently. +Bufferse larger than this will display the working progress bar.") + +(defsubst semantic-parser-working-message (&optional arg) + "Return the message string displayed while parsing. +If optional argument ARG is non-nil it is appended to the message +string." + (if semantic-parser-name + (format "%s/%s" semantic-parser-name (or arg "")) + (format "%s" (or arg "")))) + +;;; Application Parser Entry Points +;; +;; The best way to call the parser from programs is via +;; `semantic-fetch-tags'. This, in turn, uses other internal +;; API functions which plug-in parsers can take advantage of. + +(defun semantic-fetch-tags () + "Fetch semantic tags from the current buffer. +If the buffer cache is up to date, return that. +If the buffer cache is out of date, attempt an incremental reparse. +If the buffer has not been parsed before, or if the incremental reparse +fails, then parse the entire buffer. +If a lexcial error had been previously discovered and the buffer +was marked unparseable, then do nothing, and return the cache." + (and + ;; Is this a semantic enabled buffer? + (semantic-active-p) + ;; Application hooks say the buffer is safe for parsing + (run-hook-with-args-until-failure + 'semantic-before-toplevel-bovination-hook) + (run-hook-with-args-until-failure + 'semantic--before-fetch-tags-hook) + ;; If the buffer was previously marked unparseable, + ;; then don't waste our time. + (not (semantic-parse-tree-unparseable-p)) + ;; The parse tree actually needs to be refreshed + (not (semantic-parse-tree-up-to-date-p)) + ;; So do it! + (let* ((gc-cons-threshold (max gc-cons-threshold 10000000)) + (semantic-lex-block-streams nil) + (res nil)) + (garbage-collect) + (cond + +;;;; Try the incremental parser to do a fast update. + ((semantic-parse-tree-needs-update-p) + (setq res (semantic-parse-changes)) + (if (semantic-parse-tree-needs-rebuild-p) + ;; If the partial reparse fails, jump to a full reparse. + (semantic-fetch-tags) + ;; Clear the cache of unmatched syntax tokens + ;; + ;; NOTE TO SELF: + ;; + ;; Move this into the incremental parser. This is a bug. + ;; + (semantic-clear-unmatched-syntax-cache) + (run-hook-with-args ;; Let hooks know the updated tags + 'semantic-after-partial-cache-change-hook res)) + ) + +;;;; Parse the whole system. + ((semantic-parse-tree-needs-rebuild-p) + ;; (let ((working-status-dynamic-type + ;; (if (< (point-max) semantic-minimum-working-buffer-size) + ;; nil + ;; working-status-dynamic-type)) + ;; (working-status-percentage-type + ;; (if (< (point-max) semantic-minimum-working-buffer-size) + ;; nil + ;; working-status-percentage-type))) + ;; (working-status-forms + ;; (semantic-parser-working-message (buffer-name)) "done" + ;; (setq res (semantic-parse-region (point-min) (point-max))) + ;; (working-status t))) + + ;; Use Emacs' built-in progress-reporter + (let ((semantic--progress-reporter + (and (>= (point-max) semantic-minimum-working-buffer-size) + (eq semantic-working-type 'percent) + (make-progress-reporter + (semantic-parser-working-message (buffer-name)) + 0 100)))) + (setq res (semantic-parse-region (point-min) (point-max))) + (progress-reporter-done semantic--progress-reporter)) + + ;; Clear the caches when we see there were no errors. + ;; But preserve the unmatched syntax cache and warnings! + (let (semantic-unmatched-syntax-cache + semantic-unmatched-syntax-cache-check + semantic-parser-warnings) + (semantic-clear-toplevel-cache)) + ;; Set up the new overlays + (semantic--tag-link-list-to-buffer res) + ;; Set up the cache with the new results + (semantic--set-buffer-cache res) + )))) + + ;; Always return the current parse tree. + semantic--buffer-cache) + +(defun semantic-refresh-tags-safe () + "Refreshes the current buffer's tags safely. + +Return non-nil if the refresh was successful. +Return nil if there is some sort of syntax error preventing a reparse. + +Does nothing if the current buffer doesn't need reparsing." + + ;; These checks actually occur in `semantic-fetch-tags', but if we + ;; do them here, then all the bovination hooks are not run, and + ;; we save lots of time. + (cond + ;; If the buffer was previously marked unparseable, + ;; then don't waste our time. + ((semantic-parse-tree-unparseable-p) + nil) + ;; The parse tree is already ok. + ((semantic-parse-tree-up-to-date-p) + t) + (t + (let* ((inhibit-quit nil) + (lexically-safe t) + ) + + (unwind-protect + ;; Perform the parsing. + (progn + (when (semantic-lex-catch-errors safe-refresh + (save-excursion (semantic-fetch-tags)) + nil) + ;; If we are here, it is because the lexical step failed, + ;; proably due to unterminated lists or something like that. + + ;; We do nothing, and just wait for the next idle timer + ;; to go off. In the meantime, remember this, and make sure + ;; no other idle services can get executed. + (setq lexically-safe nil)) + ) + ) + ;; Return if we are lexically safe + lexically-safe)))) + +(defun semantic-bovinate-toplevel (&optional ignored) + "Backward Compatibility Function." + (semantic-fetch-tags)) +(make-obsolete 'semantic-bovinate-toplevel 'semantic-fetch-tags) + +;; Another approach is to let Emacs call the parser on idle time, when +;; needed, use `semantic-fetch-available-tags' to only retrieve +;; available tags, and setup the `semantic-after-*-hook' hooks to +;; synchronize with new tags when they become available. + +(defsubst semantic-fetch-available-tags () + "Fetch available semantic tags from the current buffer. +That is, return tags currently in the cache without parsing the +current buffer. +Parse operations happen asynchronously when needed on Emacs idle time. +Use the `semantic-after-toplevel-cache-change-hook' and +`semantic-after-partial-cache-change-hook' hooks to synchronize with +new tags when they become available." + semantic--buffer-cache) + +;;; Iterative parser helper function +;; +;; Iterative parsers are better than rule-based iterative functions +;; in that they can handle obscure errors more cleanly. +;; +;; `semantic-repeat-parse-whole-stream' abstracts this action for +;; other parser centric routines. +;; +(defun semantic-repeat-parse-whole-stream + (stream nonterm &optional returnonerror) + "Iteratively parse the entire stream STREAM starting with NONTERM. +Optional argument RETURNONERROR indicates that the parser should exit +with the current results on a parse error. +This function returns semantic tags without overlays." + (let ((result nil) + (case-fold-search semantic-case-fold) + nontermsym tag) + (while stream + (setq nontermsym (semantic-parse-stream stream nonterm) + tag (car (cdr nontermsym))) + (if (not nontermsym) + (error "Parse error @ %d" (car (cdr (car stream))))) + (if (eq (car nontermsym) stream) + (error "Parser error: Infinite loop?")) + (if tag + (if (car tag) + (setq tag (mapcar + #'(lambda (tag) + ;; Set the 'reparse-symbol property to + ;; NONTERM unless it was already setup + ;; by a tag expander + (or (semantic--tag-get-property + tag 'reparse-symbol) + (semantic--tag-put-property + tag 'reparse-symbol nonterm)) + tag) + (semantic--tag-expand tag)) + result (append tag result)) + ;; No error in this case, a purposeful nil means don't + ;; store anything. + ) + (if returnonerror + (setq stream nil) + ;; The current item in the stream didn't match, so add it to + ;; the list of syntax items which didn't match. + (setq semantic-unmatched-syntax-cache + (cons (car stream) semantic-unmatched-syntax-cache)) + )) + ;; Designated to ignore. + (setq stream (car nontermsym)) + (if stream + ;; (if (eq semantic-working-type 'percent) + ;; (working-status + ;; (/ (* 100 (semantic-lex-token-start (car stream))) + ;; (point-max))) + ;; (working-dynamic-status)) + + ;; Use Emacs' built-in progress reporter: + (and (boundp 'semantic--progress-reporter) + semantic--progress-reporter + (progress-reporter-update + semantic--progress-reporter + (/ (* 100 (semantic-lex-token-start (car stream))) + (point-max)))))) + result)) + +;;; Parsing Warnings: +;; +;; Parsing a buffer may result in non-critical things that we should +;; alert the user to without interrupting the normal flow. +;; +;; Any parser can use this API to provide a list of warnings during a +;; parse which a user may want to investigate. +(defvar semantic-parser-warnings nil + "A list of parser warnings since the last full reparse.") +(make-variable-buffer-local 'semantic-parser-warnings) + +(defun semantic-clear-parser-warnings () + "Clear the current list of parser warnings for this buffer." + (setq semantic-parser-warnings nil)) + +(defun semantic-push-parser-warning (warning start end) + "Add a parser WARNING that covers text from START to END." + (setq semantic-parser-warnings + (cons (cons warning (cons start end)) + semantic-parser-warnings))) + +(defun semantic-dump-parser-warnings () + "Dump any parser warnings." + (interactive) + (if semantic-parser-warnings + (let ((pw semantic-parser-warnings)) + (pop-to-buffer "*Parser Warnings*") + (require 'pp) + (erase-buffer) + (insert (pp-to-string pw)) + (goto-char (point-min))) + (message "No parser warnings."))) + + + +;;; Compatibility: +;; +;; Semantic 1.x parser action helper functions, used by some parsers. +;; Please move away from these functions, and try using semantic 2.x +;; interfaces instead. +;; +(defsubst semantic-bovinate-region-until-error + (start end nonterm &optional depth) + "NOTE: Use `semantic-parse-region' instead. + +Bovinate between START and END starting with NONTERM. +Optional DEPTH specifies how many levels of parenthesis to enter. +This command will parse until an error is encountered, and return +the list of everything found until that moment. +This is meant for finding variable definitions at the beginning of +code blocks in methods. If `bovine-inner-scope' can also support +commands, use `semantic-bovinate-from-nonterminal-full'." + (semantic-parse-region start end nonterm depth t)) +(make-obsolete 'semantic-bovinate-region-until-error + 'semantic-parse-region) + +(defsubst semantic-bovinate-from-nonterminal + (start end nonterm &optional depth length) + "Bovinate from within a nonterminal lambda from START to END. +Argument NONTERM is the nonterminal symbol to start with. +Optional argument DEPTH is the depth of lists to dive into. When used +in a `lambda' of a MATCH-LIST, there is no need to include a START and +END part. +Optional argument LENGTH specifies we are only interested in LENGTH +tokens." + (car-safe (cdr (semantic-parse-stream + (semantic-lex start end (or depth 1) length) + nonterm)))) + +(defsubst semantic-bovinate-from-nonterminal-full + (start end nonterm &optional depth) + "NOTE: Use `semantic-parse-region' instead. + +Bovinate from within a nonterminal lambda from START to END. +Iterates until all the space between START and END is exhausted. +Argument NONTERM is the nonterminal symbol to start with. +If NONTERM is nil, use `bovine-block-toplevel'. +Optional argument DEPTH is the depth of lists to dive into. +When used in a `lambda' of a MATCH-LIST, there is no need to include +a START and END part." + (semantic-parse-region start end nonterm (or depth 1))) +(make-obsolete 'semantic-bovinate-from-nonterminal-full + 'semantic-parse-region) + +(provide 'semantic) + +;;; semantic.el ends here + +;; Semantic-util is a part of the semantic API. Include it last +;; because it depends on semantic. +(require 'semantic-util)