Mercurial > emacs
changeset 104411:11f4ef827ca4
Files removed.
| author | Chong Yidong <cyd@stupidchicken.com> |
|---|---|
| date | Fri, 28 Aug 2009 14:51:35 +0000 |
| parents | 203567d53c98 |
| children | 05443eb58935 |
| files | lisp/cedet/semantic-fw.el lisp/cedet/semantic-lex.el lisp/cedet/semantic-tag.el |
| diffstat | 3 files changed, 0 insertions(+), 4188 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/cedet/semantic-fw.el Tue Aug 25 04:19:35 2009 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,530 +0,0 @@ -;;; 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
--- a/lisp/cedet/semantic-lex.el Tue Aug 25 04:19:35 2009 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,2089 +0,0 @@ -;;; 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
--- a/lisp/cedet/semantic-tag.el Tue Aug 25 04:19:35 2009 +0000 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1569 +0,0 @@ -;;; 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