cedet/semantic/lex-spp.el, cedet/semantic/util-modes.el: New files.
--- /dev/null
+;;; semanticdb.el --- Semantic tag database manager
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+;;; 2008, 2009 Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: tags
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Maintain a database of tags for a group of files and enable
+;; queries into the database.
+;;
+;; By default, assume one database per directory.
+;;
+
+(require 'eieio)
+;; (require 'inversion)
+;; (eval-and-compile
+;; (inversion-require 'eieio "1.0"))
+(require 'eieio-base)
+(require 'semantic)
+(eval-when-compile
+ (require 'semantic/lex-spp))
+
+;;; Variables:
+(defgroup semanticdb nil
+ "Parser Generator Persistent Database interface."
+ :group 'semantic
+ )
+;;; Code:
+(defvar semanticdb-database-list nil
+ "List of all active databases.")
+
+(defvar semanticdb-new-database-class 'semanticdb-project-database-file
+ "The default type of database created for new files.
+This can be changed on a per file basis, so that some directories
+are saved using one mechanism, and some directories via a different
+mechanism.")
+(make-variable-buffer-local 'semanticdb-new-database-class)
+
+(defvar semanticdb-default-find-index-class 'semanticdb-find-search-index
+ "The default type of search index to use for a `semanticdb-table's.
+This can be changed to try out new types of search indicies.")
+(make-variable-buffer-local 'semanticdb-default-find=index-class)
+
+
+;;; ABSTRACT CLASSES
+;;
+(defclass semanticdb-abstract-table ()
+ ((parent-db ;; :initarg :parent-db
+ ;; Do not set an initarg, or you get circular writes to disk.
+ :documentation "Database Object containing this table.")
+ (major-mode :initarg :major-mode
+ :initform nil
+ :documentation "Major mode this table belongs to.
+Sometimes it is important for a program to know if a given table has the
+same major mode as the current buffer.")
+ (tags :initarg :tags
+ :accessor semanticdb-get-tags
+ :printer semantic-tag-write-list-slot-value
+ :documentation "The tags belonging to this table.")
+ (index :type semanticdb-abstract-search-index
+ :documentation "The search index.
+Used by semanticdb-find to store additional information about
+this table for searching purposes.
+
+Note: This index will not be saved in a persistent file.")
+ (cache :type list
+ :initform nil
+ :documentation "List of cache information for tools.
+Any particular tool can cache data to a database at runtime
+with `semanticdb-cache-get'.
+
+Using a semanticdb cache does not save any information to a file,
+so your cache will need to be recalculated at runtime. Caches can be
+referenced even when the file is not in a buffer.
+
+Note: This index will not be saved in a persistent file.")
+ )
+ "A simple table for semantic tags.
+This table is the root of tables, and contains the minimum needed
+for a new table not associated with a buffer."
+ :abstract t)
+
+(defmethod semanticdb-in-buffer-p ((obj semanticdb-abstract-table))
+ "Return a nil, meaning abstract table OBJ is not in a buffer."
+ nil)
+
+(defmethod semanticdb-get-buffer ((obj semanticdb-abstract-table))
+ "Return a buffer associated with OBJ.
+If the buffer is not in memory, load it with `find-file-noselect'."
+ nil)
+
+(defmethod semanticdb-full-filename ((obj semanticdb-abstract-table))
+ "Fetch the full filename that OBJ refers to.
+Abstract tables do not have file names associated with them."
+ nil)
+
+(defmethod semanticdb-dirty-p ((obj semanticdb-abstract-table))
+ "Return non-nil if OBJ is 'dirty'."
+ nil)
+
+(defmethod semanticdb-set-dirty ((obj semanticdb-abstract-table))
+ "Mark the abstract table OBJ dirty.
+Abstract tables can not be marked dirty, as there is nothing
+for them to synchronize against."
+ ;; The abstract table can not be dirty.
+ nil)
+
+(defmethod semanticdb-normalize-tags ((obj semanticdb-abstract-table) tags)
+ "For the table OBJ, convert a list of TAGS, into standardized form.
+The default is to return TAGS.
+Some databases may default to searching and providing simplified tags
+based on whichever technique used. This method provides a hook for
+them to convert TAG into a more complete form."
+ tags)
+
+(defmethod semanticdb-normalize-one-tag ((obj semanticdb-abstract-table) tag)
+ "For the table OBJ, convert a TAG, into standardized form.
+This method returns a list of the form (DATABASE . NEWTAG).
+
+The default is to just return (OBJ TAG).
+
+Some databases may default to searching and providing simplified tags
+based on whichever technique used. This method provides a hook for
+them to convert TAG into a more complete form."
+ (cons obj tag))
+
+(defmethod object-print ((obj semanticdb-abstract-table) &rest strings)
+ "Pretty printer extension for `semanticdb-table'.
+Adds the number of tags in this file to the object print name."
+ (apply 'call-next-method obj
+ (cons (format " (%d tags)"
+ (length (semanticdb-get-tags obj))
+ )
+ strings)))
+
+;;; Index Cache
+;;
+(defclass semanticdb-abstract-search-index ()
+ ((table :initarg :table
+ :type semanticdb-abstract-table
+ :documentation "XRef to the table this belongs to.")
+ )
+ "A place where semanticdb-find can store search index information.
+The search index will store data about which other tables might be
+needed, or perhaps create hash or index tables for the current buffer."
+ :abstract t)
+
+(defmethod semanticdb-get-table-index ((obj semanticdb-abstract-table))
+ "Return the search index for the table OBJ.
+If one doesn't exist, create it."
+ (if (slot-boundp obj 'index)
+ (oref obj index)
+ (let ((idx nil))
+ (setq idx (funcall semanticdb-default-find-index-class
+ (concat (object-name obj) " index")
+ ;; Fill in the defaults
+ :table obj
+ ))
+ (oset obj index idx)
+ idx)))
+
+(defmethod semanticdb-synchronize ((idx semanticdb-abstract-search-index)
+ new-tags)
+ "Synchronize the search index IDX with some NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+(defmethod semanticdb-partial-synchronize ((idx semanticdb-abstract-search-index)
+ new-tags)
+ "Synchronize the search index IDX with some changed NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+
+;;; CONCRETE TABLE CLASSES
+;;
+(defclass semanticdb-table (semanticdb-abstract-table)
+ ((file :initarg :file
+ :documentation "File name relative to the parent database.
+This is for the file whose tags are stored in this TABLE object.")
+ (buffer :initform nil
+ :documentation "The buffer associated with this table.
+If nil, the table's buffer is no in Emacs. If it has a value, then
+it is in Emacs.")
+ (dirty :initform nil
+ :documentation
+ "Non nil if this table needs to be `Saved'.")
+ (db-refs :initform nil
+ :documentation
+ "List of `semanticdb-table' objects refering to this one.
+These aren't saved, but are instead recalculated after load.
+See the file semanticdb-ref.el for how this slot is used.")
+ (pointmax :initarg :pointmax
+ :initform nil
+ :documentation "Size of buffer when written to disk.
+Checked on retrieval to make sure the file is the same.")
+ (fsize :initarg :fsize
+ :initform nil
+ :documentation "Size of the file when it was last referenced.
+Checked when deciding if a loaded table needs updating from changes
+outside of Semantic's control.")
+ (lastmodtime :initarg :lastmodtime
+ :initform nil
+ :documentation "Last modification time of the file referenced.
+Checked when deciding if a loaded table needs updating from changes outside of
+Semantic's control.")
+ ;; @todo - need to add `last parsed time', so we can also have
+ ;; refresh checks if spp tables or the parser gets rebuilt.
+ (unmatched-syntax :initarg :unmatched-syntax
+ :documentation
+ "List of vectors specifying unmatched syntax.")
+
+ (lexical-table :initarg :lexical-table
+ :initform nil
+ :printer semantic-lex-spp-table-write-slot-value
+ :documentation
+ "Table that might be needed by the lexical analyzer.
+For C/C++, the C preprocessor macros can be saved here.")
+ )
+ "A single table of tags derived from file.")
+
+(defmethod semanticdb-in-buffer-p ((obj semanticdb-table))
+ "Return a buffer associated with OBJ.
+If the buffer is in memory, return that buffer."
+ (let ((buff (oref obj buffer)))
+ (if (buffer-live-p buff)
+ buff
+ (oset obj buffer nil))))
+
+(defmethod semanticdb-get-buffer ((obj semanticdb-table))
+ "Return a buffer associated with OBJ.
+If the buffer is in memory, return that buffer.
+If the buffer is not in memory, load it with `find-file-noselect'."
+ (or (semanticdb-in-buffer-p obj)
+ (find-file-noselect (semanticdb-full-filename obj) t)))
+
+(defmethod semanticdb-set-buffer ((obj semanticdb-table))
+ "Set the current buffer to be a buffer owned by OBJ.
+If OBJ's file is not loaded, read it in first."
+ (set-buffer (semanticdb-get-buffer obj)))
+
+(defmethod semanticdb-full-filename ((obj semanticdb-table))
+ "Fetch the full filename that OBJ refers to."
+ (expand-file-name (oref obj file)
+ (oref (oref obj parent-db) reference-directory)))
+
+(defmethod semanticdb-dirty-p ((obj semanticdb-table))
+ "Return non-nil if OBJ is 'dirty'."
+ (oref obj dirty))
+
+(defmethod semanticdb-set-dirty ((obj semanticdb-table))
+ "Mark the abstract table OBJ dirty."
+ (oset obj dirty t)
+ )
+
+(defmethod object-print ((obj semanticdb-table) &rest strings)
+ "Pretty printer extension for `semanticdb-table'.
+Adds the number of tags in this file to the object print name."
+ (apply 'call-next-method obj
+ (cons (if (oref obj dirty) ", DIRTY" "") strings)))
+
+;;; DATABASE BASE CLASS
+;;
+(defclass semanticdb-project-database (eieio-instance-tracker)
+ ((tracking-symbol :initform semanticdb-database-list)
+ (reference-directory :type string
+ :documentation "Directory this database refers to.
+When a cache directory is specified, then this refers to the directory
+this database contains symbols for.")
+ (new-table-class :initform semanticdb-table
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ (cache :type list
+ :initform nil
+ :documentation "List of cache information for tools.
+Any particular tool can cache data to a database at runtime
+with `semanticdb-cache-get'.
+
+Using a semanticdb cache does not save any information to a file,
+so your cache will need to be recalculated at runtime.
+
+Note: This index will not be saved in a persistent file.")
+ (tables :initarg :tables
+ :type list
+ ;; Need this protection so apps don't try to access
+ ;; the tables without using the accessor.
+ :accessor semanticdb-get-database-tables
+ :protection :protected
+ :documentation "List of `semantic-db-table' objects."))
+ "Database of file tables.")
+
+(defmethod semanticdb-full-filename ((obj semanticdb-project-database))
+ "Fetch the full filename that OBJ refers to.
+Abstract tables do not have file names associated with them."
+ nil)
+
+(defmethod semanticdb-dirty-p ((DB semanticdb-project-database))
+ "Return non-nil if DB is 'dirty'.
+A database is dirty if the state of the database changed in a way
+where it may need to resynchronize with some persistent storage."
+ (let ((dirty nil)
+ (tabs (oref DB tables)))
+ (while (and (not dirty) tabs)
+ (setq dirty (semanticdb-dirty-p (car tabs)))
+ (setq tabs (cdr tabs)))
+ dirty))
+
+(defmethod object-print ((obj semanticdb-project-database) &rest strings)
+ "Pretty printer extension for `semanticdb-project-database'.
+Adds the number of tables in this file to the object print name."
+ (apply 'call-next-method obj
+ (cons (format " (%d tables%s)"
+ (length (semanticdb-get-database-tables obj))
+ (if (semanticdb-dirty-p obj)
+ " DIRTY" "")
+ )
+ strings)))
+
+(defmethod semanticdb-create-database :STATIC ((dbc semanticdb-project-database) directory)
+ "Create a new semantic database of class DBC for DIRECTORY and return it.
+If a database for DIRECTORY has already been created, return it.
+If DIRECTORY doesn't exist, create a new one."
+ (let ((db (semanticdb-directory-loaded-p directory)))
+ (unless db
+ (setq db (semanticdb-project-database
+ (file-name-nondirectory directory)
+ :tables nil))
+ ;; Set this up here. We can't put it in the constructor because it
+ ;; would be saved, and we want DB files to be portable.
+ (oset db reference-directory (file-truename directory)))
+ db))
+
+(defmethod semanticdb-flush-database-tables ((db semanticdb-project-database))
+ "Reset the tables in DB to be empty."
+ (oset db tables nil))
+
+(defmethod semanticdb-create-table ((db semanticdb-project-database) file)
+ "Create a new table in DB for FILE and return it.
+The class of DB contains the class name for the type of table to create.
+If the table for FILE exists, return it.
+If the table for FILE does not exist, create one."
+ (let ((newtab (semanticdb-file-table db file)))
+ (unless newtab
+ ;; This implementation will satisfy autoloaded classes
+ ;; for tables.
+ (setq newtab (funcall (oref db new-table-class)
+ (file-name-nondirectory file)
+ :file (file-name-nondirectory file)
+ ))
+ (oset newtab parent-db db)
+ (object-add-to-list db 'tables newtab t))
+ newtab))
+
+(defmethod semanticdb-file-table ((obj semanticdb-project-database) filename)
+ "From OBJ, return FILENAME's associated table object."
+ (object-assoc (file-relative-name (file-truename filename)
+ (oref obj reference-directory))
+ 'file (oref obj tables)))
+
+;; DATABASE FUNCTIONS
+(defun semanticdb-get-database (filename)
+ "Get a database for FILENAME.
+If one isn't found, create one."
+ (semanticdb-create-database semanticdb-new-database-class (file-truename filename)))
+
+(defun semanticdb-directory-loaded-p (path)
+ "Return the project belonging to PATH if it was already loaded."
+ (eieio-instance-tracker-find path 'reference-directory 'semanticdb-database-list))
+
+(defun semanticdb-create-table-for-file (filename)
+ "Initialize a database table for FILENAME, and return it.
+If FILENAME exists in the database already, return that.
+If there is no database for the table to live in, create one."
+ (let ((cdb nil)
+ (tbl nil)
+ (dd (file-name-directory filename))
+ )
+ ;; Allow a database override function
+ (setq cdb (semanticdb-create-database semanticdb-new-database-class
+ dd))
+ ;; Get a table for this file.
+ (setq tbl (semanticdb-create-table cdb filename))
+
+ ;; Return the pair.
+ (cons cdb tbl)
+ ))
+
+;;; Cache Cache.
+;;
+(defclass semanticdb-abstract-cache ()
+ ((table :initarg :table
+ :type semanticdb-abstract-table
+ :documentation
+ "Cross reference to the table this belongs to.")
+ )
+ "Abstract baseclass for tools to use to cache information in semanticdb.
+Tools needing a per-file cache must subclass this, and then get one as
+needed. Cache objects are identified in semanticdb by subclass.
+In order to keep your cache up to date, be sure to implement
+`semanticdb-synchronize', and `semanticdb-partial-synchronize'.
+See the file semantic-scope.el for an example."
+ :abstract t)
+
+(defmethod semanticdb-cache-get ((table semanticdb-abstract-table)
+ desired-class)
+ "Get a cache object on TABLE of class DESIRED-CLASS.
+This method will create one if none exists with no init arguments
+other than :table."
+ (assert (child-of-class-p desired-class 'semanticdb-abstract-cache))
+ (let ((cache (oref table cache))
+ (obj nil))
+ (while (and (not obj) cache)
+ (if (eq (object-class-fast (car cache)) desired-class)
+ (setq obj (car cache)))
+ (setq cache (cdr cache)))
+ (if obj
+ obj ;; Just return it.
+ ;; No object, lets create a new one and return that.
+ (setq obj (funcall desired-class "Cache" :table table))
+ (object-add-to-list table 'cache obj)
+ obj)))
+
+(defmethod semanticdb-cache-remove ((table semanticdb-abstract-table)
+ cache)
+ "Remove from TABLE the cache object CACHE."
+ (object-remove-from-list table 'cache cache))
+
+(defmethod semanticdb-synchronize ((cache semanticdb-abstract-cache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+(defmethod semanticdb-partial-synchronize ((cache semanticdb-abstract-cache)
+ new-tags)
+ "Synchronize a CACHE with some changed NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+(defclass semanticdb-abstract-db-cache ()
+ ((db :initarg :db
+ :type semanticdb-project-database
+ :documentation
+ "Cross reference to the database this belongs to.")
+ )
+ "Abstract baseclass for tools to use to cache information in semanticdb.
+Tools needing a database cache must subclass this, and then get one as
+needed. Cache objects are identified in semanticdb by subclass.
+In order to keep your cache up to date, be sure to implement
+`semanticdb-synchronize', and `semanticdb-partial-synchronize'.
+See the file semantic-scope.el for an example."
+ :abstract t)
+
+(defmethod semanticdb-cache-get ((db semanticdb-project-database)
+ desired-class)
+ "Get a cache object on DB of class DESIRED-CLASS.
+This method will create one if none exists with no init arguments
+other than :table."
+ (assert (child-of-class-p desired-class 'semanticdb-abstract-db-cache))
+ (let ((cache (oref db cache))
+ (obj nil))
+ (while (and (not obj) cache)
+ (if (eq (object-class-fast (car cache)) desired-class)
+ (setq obj (car cache)))
+ (setq cache (cdr cache)))
+ (if obj
+ obj ;; Just return it.
+ ;; No object, lets create a new one and return that.
+ (setq obj (funcall desired-class "Cache" :db db))
+ (object-add-to-list db 'cache obj)
+ obj)))
+
+(defmethod semanticdb-cache-remove ((db semanticdb-project-database)
+ cache)
+ "Remove from TABLE the cache object CACHE."
+ (object-remove-from-list db 'cache cache))
+
+
+(defmethod semanticdb-synchronize ((cache semanticdb-abstract-db-cache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+(defmethod semanticdb-partial-synchronize ((cache semanticdb-abstract-db-cache)
+ new-tags)
+ "Synchronize a CACHE with some changed NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+;;; REFRESH
+
+(defmethod semanticdb-refresh-table ((obj semanticdb-table) &optional force)
+ "If the tag list associated with OBJ is loaded, refresh it.
+Optional argument FORCE will force a refresh even if the file in question
+is not in a buffer. Avoid using FORCE for most uses, as an old cache
+may be sufficient for the general case. Forced updates can be slow.
+This will call `semantic-fetch-tags' if that file is in memory."
+ (when (or (semanticdb-in-buffer-p obj) force)
+ (save-excursion
+ (semanticdb-set-buffer obj)
+ (semantic-fetch-tags))))
+
+(defmethod semanticdb-needs-refresh-p ((obj semanticdb-table))
+ "Return non-nil of OBJ's tag list is out of date.
+The file associated with OBJ does not need to be in a buffer."
+ (let* ((ff (semanticdb-full-filename obj))
+ (buff (semanticdb-in-buffer-p obj))
+ )
+ (if buff
+ (save-excursion
+ (set-buffer buff)
+ ;; Use semantic's magic tracker to determine of the buffer is up
+ ;; to date or not.
+ (not (semantic-parse-tree-up-to-date-p))
+ ;; We assume that semanticdb is keeping itself up to date.
+ ;; via all the clever hooks
+ )
+ ;; Buffer isn't loaded. The only clue we have is if the file
+ ;; is somehow different from our mark in the semanticdb table.
+ (let* ((stats (file-attributes ff))
+ (actualsize (nth 7 stats))
+ (actualmod (nth 5 stats))
+ )
+
+ (or (not (slot-boundp obj 'tags))
+ ;; (not (oref obj tags)) --> not needed anymore?
+ (/= (or (oref obj fsize) 0) actualsize)
+ (not (equal (oref obj lastmodtime) actualmod))
+ )
+ ))))
+
+\f
+;;; Synchronization
+;;
+(defmethod semanticdb-synchronize ((table semanticdb-abstract-table)
+ new-tags)
+ "Synchronize the table TABLE with some NEW-TAGS."
+ (oset table tags new-tags)
+ (oset table pointmax (point-max))
+ (let ((fattr (file-attributes (semanticdb-full-filename table))))
+ (oset table fsize (nth 7 fattr))
+ (oset table lastmodtime (nth 5 fattr))
+ )
+ ;; Assume it is now up to date.
+ (oset table unmatched-syntax semantic-unmatched-syntax-cache)
+ ;; The lexical table should be good too.
+ (when (featurep 'semantic-lex-spp)
+ (oset table lexical-table (semantic-lex-spp-save-table)))
+ ;; this implies dirtyness
+ (semanticdb-set-dirty table)
+
+ ;; Synchronize the index
+ (when (slot-boundp table 'index)
+ (let ((idx (oref table index)))
+ (when idx (semanticdb-synchronize idx new-tags))))
+
+ ;; Synchronize application caches.
+ (dolist (C (oref table cache))
+ (semanticdb-synchronize C new-tags)
+ )
+
+ ;; Update cross references
+ ;; (semanticdb-refresh-references table)
+ )
+
+(defmethod semanticdb-partial-synchronize ((table semanticdb-abstract-table)
+ new-tags)
+ "Synchronize the table TABLE where some NEW-TAGS changed."
+ ;; You might think we need to reset the tags, but since the partial
+ ;; parser splices the lists, we don't need to do anything
+ ;;(oset table tags new-tags)
+ ;; We do need to mark ourselves dirty.
+ (semanticdb-set-dirty table)
+
+ ;; The lexical table may be modified.
+ (when (featurep 'semantic-lex-spp)
+ (oset table lexical-table (semantic-lex-spp-save-table)))
+
+ ;; Incremental parser doesn't mokey around with this.
+ (oset table unmatched-syntax semantic-unmatched-syntax-cache)
+
+ ;; Synchronize the index
+ (when (slot-boundp table 'index)
+ (let ((idx (oref table index)))
+ (when idx (semanticdb-partial-synchronize idx new-tags))))
+
+ ;; Synchronize application caches.
+ (dolist (C (oref table cache))
+ (semanticdb-synchronize C new-tags)
+ )
+
+ ;; Update cross references
+ ;;(when (semantic-find-tags-by-class 'include new-tags)
+ ;; (semanticdb-refresh-references table))
+ )
+
+;;; SAVE/LOAD
+;;
+(defmethod semanticdb-save-db ((DB semanticdb-project-database)
+ &optional supress-questions)
+ "Cause a database to save itself.
+The database base class does not save itself persistently.
+Subclasses could save themselves to a file, or to a database, or other
+form."
+ nil)
+
+(defun semanticdb-save-current-db ()
+ "Save the current tag database."
+ (interactive)
+ (message "Saving current tag summaries...")
+ (semanticdb-save-db semanticdb-current-database)
+ (message "Saving current tag summaries...done"))
+
+(defun semanticdb-save-all-db ()
+ "Save all semantic tag databases."
+ (interactive)
+ (message "Saving tag summaries...")
+ (mapc 'semanticdb-save-db semanticdb-database-list)
+ (message "Saving tag summaries...done"))
+
+(defun semanticdb-save-all-db-idle ()
+ "Save all semantic tag databases from idle time.
+Exit the save between databases if there is user input."
+ (semantic-safe "Auto-DB Save: %S"
+ (semantic-exit-on-input 'semanticdb-idle-save
+ (mapc (lambda (db)
+ (semantic-throw-on-input 'semanticdb-idle-save)
+ (semanticdb-save-db db t))
+ semanticdb-database-list))
+ ))
+
+;;; Directory Project support
+;;
+(defvar semanticdb-project-predicate-functions nil
+ "List of predicates to try that indicate a directory belongs to a project.
+This list is used when `semanticdb-persistent-path' contains the value
+'project. If the predicate list is nil, then presume all paths are valid.
+
+Project Management software (such as EDE and JDE) should add their own
+predicates with `add-hook' to this variable, and semanticdb will save tag
+caches in directories controlled by them.")
+
+(defmethod semanticdb-write-directory-p ((obj semanticdb-project-database))
+ "Return non-nil if OBJ should be written to disk.
+Uses `semanticdb-persistent-path' to determine the return value."
+ nil)
+
+;;; Utilities
+;;
+;; What is the current database, are two tables of an equivalent mode,
+;; and what databases are a part of the same project.
+(defun semanticdb-current-database ()
+ "Return the currently active database."
+ (or semanticdb-current-database
+ (and default-directory
+ (semanticdb-create-database semanticdb-new-database-class
+ default-directory)
+ )
+ nil))
+
+(defvar semanticdb-match-any-mode nil
+ "Non-nil to temporarilly search any major mode for a tag.
+If a particular major mode wants to search any mode, put the
+`semantic-match-any-mode' symbol onto the symbol of that major mode.
+Do not set the value of this variable permanently.")
+
+(defmacro semanticdb-with-match-any-mode (&rest body)
+ "A Semanticdb search occuring withing BODY will search tags in all modes.
+This temporarilly sets `semanticdb-match-any-mode' while executing BODY."
+ `(let ((semanticdb-match-any-mode t))
+ ,@body))
+(put 'semanticdb-with-match-any-mode 'lisp-indent-function 0)
+
+(defmethod semanticdb-equivalent-mode-for-search (table &optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+See `semanticdb-equivalent-mode' for details.
+This version is used during searches. Major-modes that opt
+to set the `semantic-match-any-mode' property will be able to search
+all files of any type."
+ (or (get major-mode 'semantic-match-any-mode)
+ semanticdb-match-any-mode
+ (semanticdb-equivalent-mode table buffer))
+ )
+
+(defmethod semanticdb-equivalent-mode ((table semanticdb-abstract-table) &optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+Equivalent modes are specified by by `semantic-equivalent-major-modes'
+local variable."
+ nil)
+
+(defmethod semanticdb-equivalent-mode ((table semanticdb-table) &optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+Equivalent modes are specified by by `semantic-equivalent-major-modes'
+local variable."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (or
+ ;; nil major mode in table means we don't know yet. Assume yes for now?
+ (null (oref table major-mode))
+ ;; nil means the same as major-mode
+ (and (not semantic-equivalent-major-modes)
+ (mode-local-use-bindings-p major-mode (oref table major-mode)))
+ (and semantic-equivalent-major-modes
+ (member (oref table major-mode) semantic-equivalent-major-modes))
+ )
+ ))
+
+
+;;; Associations
+;;
+;; These routines determine associations between a file, and multiple
+;; associated databases.
+
+(defcustom semanticdb-project-roots nil
+ "*List of directories, where each directory is the root of some project.
+All subdirectories of a root project are considered a part of one project.
+Values in this string can be overriden by project management programs
+via the `semanticdb-project-root-functions' variable."
+ :group 'semanticdb
+ :type '(repeat string))
+
+(defvar semanticdb-project-root-functions nil
+ "List of functions used to determine a given directories project root.
+Functions in this variable can override `semanticdb-project-roots'.
+Functions set in the variable are given one argument (a directory) and
+must return a string, (the root directory) or a list of strings (multiple
+root directories in a more complex system). This variable should be used
+by project management programs like EDE or JDE.")
+
+(defvar semanticdb-project-system-databases nil
+ "List of databases containing system library information.
+Mode authors can create their own system databases which know
+detailed information about the system libraries for querying purposes.
+Put those into this variable as a buffer-local, or mode-local
+value.")
+(make-variable-buffer-local 'semanticdb-project-system-databases)
+
+(defvar semanticdb-search-system-databases t
+ "Non nil if search routines are to include a system database.")
+
+(defun semanticdb-current-database-list (&optional dir)
+ "Return a list of databases associated with the current buffer.
+If optional argument DIR is non-nil, then use DIR as the starting directory.
+If this buffer has a database, but doesn't have a project associated
+with it, return nil.
+First, it checks `semanticdb-project-root-functions', and if that
+has no results, it checks `semanticdb-project-roots'. If that fails,
+it returns the results of function `semanticdb-current-database'.
+Always append `semanticdb-project-system-databases' if
+`semanticdb-search-system' is non-nil."
+ (let ((root nil) ; found root directory
+ (dbs nil) ; collected databases
+ (roots semanticdb-project-roots) ;all user roots
+ (dir (file-truename (or dir default-directory)))
+ )
+ ;; Find the root based on project functions.
+ (setq root (run-hook-with-args-until-success
+ 'semanticdb-project-root-functions
+ dir))
+ ;; Find roots based on strings
+ (while (and roots (not root))
+ (let ((r (file-truename (car roots))))
+ (if (string-match (concat "^" (regexp-quote r)) dir)
+ (setq root r)))
+ (setq roots (cdr roots)))
+
+ ;; If no roots are found, use this directory.
+ (unless root (setq root dir))
+
+ ;; Find databases based on the root directory.
+ (when root
+ ;; The rootlist allows the root functions to possibly
+ ;; return several roots which are in different areas but
+ ;; all apart of the same system.
+ (let ((regexp (concat "^" (regexp-quote root)))
+ (adb semanticdb-database-list) ; all databases
+ )
+ (while adb
+ ;; I don't like this part, but close enough.
+ (if (and (slot-boundp (car adb) 'reference-directory)
+ (string-match regexp (oref (car adb) reference-directory)))
+ (setq dbs (cons (car adb) dbs)))
+ (setq adb (cdr adb))))
+ )
+ ;; Add in system databases
+ (when semanticdb-search-system-databases
+ (setq dbs (nconc dbs semanticdb-project-system-databases)))
+ ;; Return
+ dbs))
+
+\f
+;;; Generic Accessor Routines
+;;
+;; These routines can be used to get at tags in files w/out
+;; having to know a lot about semanticDB.
+(defvar semanticdb-file-table-hash (make-hash-table :test 'equal)
+ "Hash table mapping file names to database tables.")
+
+(defun semanticdb-file-table-object-from-hash (file)
+ "Retrieve a DB table from the hash for FILE.
+Does not use `file-truename'."
+ (gethash file semanticdb-file-table-hash 'no-hit))
+
+(defun semanticdb-file-table-object-put-hash (file dbtable)
+ "For FILE, associate DBTABLE in the hash table."
+ (puthash file dbtable semanticdb-file-table-hash))
+
+(defun semanticdb-file-table-object (file &optional dontload)
+ "Return a semanticdb table belonging to FILE, make it up to date.
+If file has database tags available in the database, return it.
+If file does not have tags available, and DONTLOAD is nil,
+then load the tags for FILE, and create a new table object for it.
+DONTLOAD does not affect the creation of new database objects."
+ ;; (message "Object Translate: %s" file)
+ (when (file-exists-p file)
+ (let* ((default-directory (file-name-directory file))
+ (tab (semanticdb-file-table-object-from-hash file))
+ (fullfile nil))
+
+ ;; If it is not in the cache, then extract the more traditional
+ ;; way by getting the database, and finding a table in that database.
+ ;; Once we have a table, add it to the hash.
+ (when (eq tab 'no-hit)
+ (setq fullfile (file-truename file))
+ (let ((db (or ;; This line will pick up system databases.
+ (semanticdb-directory-loaded-p default-directory)
+ ;; this line will make a new one if needed.
+ (semanticdb-get-database default-directory))))
+ (setq tab (semanticdb-file-table db fullfile))
+ (when tab
+ (semanticdb-file-table-object-put-hash file tab)
+ (when (not (string= fullfile file))
+ (semanticdb-file-table-object-put-hash fullfile tab)
+ ))
+ ))
+
+ (cond
+ ((and tab
+ ;; Is this in a buffer?
+ ;;(find-buffer-visiting (semanticdb-full-filename tab))
+ (semanticdb-in-buffer-p tab)
+ )
+ (save-excursion
+ ;;(set-buffer (find-buffer-visiting (semanticdb-full-filename tab)))
+ (semanticdb-set-buffer tab)
+ (semantic-fetch-tags)
+ ;; Return the table.
+ tab))
+ ((and tab dontload)
+ ;; If we have table, and we don't want to load it, just return it.
+ tab)
+ ((and tab
+ ;; Is table fully loaded, or just a proxy?
+ (number-or-marker-p (oref tab pointmax))
+ ;; Is this table up to date with the file?
+ (not (semanticdb-needs-refresh-p tab)))
+ ;; A-ok!
+ tab)
+ ((or (and fullfile (get-file-buffer fullfile))
+ (get-file-buffer file))
+ ;; are these two calls this faster than `find-buffer-visiting'?
+
+ ;; If FILE is being visited, but none of the above state is
+ ;; true (meaning, there is no table object associated with it)
+ ;; then it is a file not supported by Semantic, and can be safely
+ ;; ignored.
+ nil)
+ ((not dontload) ;; We must load the file.
+ ;; Full file should have been set by now. Debug why not?
+ (when (and (not tab) (not fullfile))
+ ;; This case is if a 'nil is erroneously put into the hash table. This
+ ;; would need fixing
+ (setq fullfile (file-truename file))
+ )
+
+ ;; If we have a table, but no fullfile, that's ok. Lets get the filename
+ ;; from the table which is pre-truenamed.
+ (when (and (not fullfile) tab)
+ (setq fullfile (semanticdb-full-filename tab)))
+
+ (setq tab (semanticdb-create-table-for-file-not-in-buffer fullfile))
+
+ ;; Save the new table.
+ (semanticdb-file-table-object-put-hash file tab)
+ (when (not (string= fullfile file))
+ (semanticdb-file-table-object-put-hash fullfile tab)
+ )
+ ;; Done!
+ tab)
+ (t
+ ;; Full file should have been set by now. Debug why not?
+ ;; One person found this. Is it a file that failed to parse
+ ;; in the past?
+ (when (not fullfile)
+ (setq fullfile (file-truename file)))
+
+ ;; We were asked not to load the file in and parse it.
+ ;; Instead just create a database table with no tags
+ ;; and a claim of being empty.
+ ;;
+ ;; This will give us a starting point for storing
+ ;; database cross-references so when it is loaded,
+ ;; the cross-references will fire and caches will
+ ;; be cleaned.
+ (let ((ans (semanticdb-create-table-for-file file)))
+ (setq tab (cdr ans))
+
+ ;; Save the new table.
+ (semanticdb-file-table-object-put-hash file tab)
+ (when (not (string= fullfile file))
+ (semanticdb-file-table-object-put-hash fullfile tab)
+ )
+ ;; Done!
+ tab))
+ )
+ )))
+
+(defvar semanticdb-out-of-buffer-create-table-fcn nil
+ "When non-nil, a function for creating a semanticdb table.
+This should take a filename to be parsed.")
+(make-variable-buffer-local 'semanticdb-out-of-buffer-create-table-fcn)
+
+(defun semanticdb-create-table-for-file-not-in-buffer (filename)
+ "Create a table for the file FILENAME.
+If there are no language specific configurations, this
+function will read in the buffer, parse it, and kill the buffer."
+ (if (and semanticdb-out-of-buffer-create-table-fcn
+ (not (file-remote-p filename)))
+ ;; Use external parser only of the file is accessible to the
+ ;; local file system.
+ (funcall semanticdb-out-of-buffer-create-table-fcn filename)
+ (save-excursion
+ (let* ( ;; Remember the buffer to kill
+ (kill-buffer-flag (find-buffer-visiting filename))
+ (buffer-to-kill (or kill-buffer-flag
+ (semantic-find-file-noselect filename t))))
+
+ ;; This shouldn't ever be set. Debug some issue here?
+ ;; (when kill-buffer-flag (debug))
+
+ (set-buffer buffer-to-kill)
+ ;; Find file should automatically do this for us.
+ ;; Sometimes the DB table doesn't contains tags and needs
+ ;; a refresh. For example, when the file is loaded for
+ ;; the first time, and the idle scheduler didn't get a
+ ;; chance to trigger a parse before the file buffer is
+ ;; killed.
+ (when semanticdb-current-table
+ (semantic-fetch-tags))
+ (prog1
+ semanticdb-current-table
+ (when (not kill-buffer-flag)
+ ;; If we had to find the file, then we should kill it
+ ;; to keep the master buffer list clean.
+ (kill-buffer buffer-to-kill)
+ )))))
+ )
+
+(defun semanticdb-file-stream (file)
+ "Return a list of tags belonging to FILE.
+If file has database tags available in the database, return them.
+If file does not have tags available, then load the file, and create them."
+ (let ((table (semanticdb-file-table-object file)))
+ (when table
+ (semanticdb-get-tags table))))
+
+(provide 'semantic/db)
+
+;;; semanticdb.el ends here
--- /dev/null
+;;; semantic-decorate.el --- Utilities for decorating/highlighting tokens.
+
+;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2006, 2007, 2009
+;;; Free Software Foundation, Inc.
+
+;; Author: Eric M. Ludlam <zappo@gnu.org>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Text representing a semantic tag is wrapped in an overlay.
+;; This overlay can be used for highlighting, or setting other
+;; editing properties on a tag, such as "read only."
+;;
+
+(require 'semantic)
+(require 'pulse)
+
+;;; Code:
+
+;;; Highlighting Basics
+(defun semantic-highlight-tag (tag &optional face)
+ "Specify that TAG should be highlighted.
+Optional FACE specifies the face to use."
+ (let ((o (semantic-tag-overlay tag)))
+ (semantic-overlay-put o 'old-face
+ (cons (semantic-overlay-get o 'face)
+ (semantic-overlay-get o 'old-face)))
+ (semantic-overlay-put o 'face (or face 'semantic-tag-highlight-face))
+ ))
+
+(defun semantic-unhighlight-tag (tag)
+ "Unhighlight TAG, restoring it's previous face."
+ (let ((o (semantic-tag-overlay tag)))
+ (semantic-overlay-put o 'face (car (semantic-overlay-get o 'old-face)))
+ (semantic-overlay-put o 'old-face (cdr (semantic-overlay-get o 'old-face)))
+ ))
+
+;;; Momentary Highlighting - One line
+(defun semantic-momentary-highlight-one-tag-line (tag &optional face)
+ "Highlight the first line of TAG, unhighlighting before next command.
+Optional argument FACE specifies the face to do the highlighting."
+ (save-excursion
+ ;; Go to first line in tag
+ (semantic-go-to-tag tag)
+ (pulse-momentary-highlight-one-line (point))))
+
+;;; Momentary Highlighting - Whole Tag
+(defun semantic-momentary-highlight-tag (tag &optional face)
+ "Highlight TAG, removing highlighting when the user hits a key.
+Optional argument FACE is the face to use for highlighting.
+If FACE is not specified, then `highlight' will be used."
+ (when (semantic-tag-with-position-p tag)
+ (if (not (semantic-overlay-p (semantic-tag-overlay tag)))
+ ;; No overlay, but a position. Highlight the first line only.
+ (semantic-momentary-highlight-one-tag-line tag face)
+ ;; The tag has an overlay, highlight the whole thing
+ (pulse-momentary-highlight-overlay (semantic-tag-overlay tag)
+ face)
+ )))
+
+(defun semantic-set-tag-face (tag face)
+ "Specify that TAG should use FACE for display."
+ (semantic-overlay-put (semantic-tag-overlay tag) 'face face))
+
+(defun semantic-set-tag-invisible (tag &optional visible)
+ "Enable the text in TAG to be made invisible.
+If VISIBLE is non-nil, make the text visible."
+ (semantic-overlay-put (semantic-tag-overlay tag) 'invisible
+ (not visible)))
+
+(defun semantic-tag-invisible-p (tag)
+ "Return non-nil if TAG is invisible."
+ (semantic-overlay-get (semantic-tag-overlay tag) 'invisible))
+
+(defun semantic-set-tag-intangible (tag &optional tangible)
+ "Enable the text in TAG to be made intangible.
+If TANGIBLE is non-nil, make the text visible.
+This function does not have meaning in XEmacs because it seems that
+the extent 'intangible' property does not exist."
+ (semantic-overlay-put (semantic-tag-overlay tag) 'intangible
+ (not tangible)))
+
+(defun semantic-tag-intangible-p (tag)
+ "Return non-nil if TAG is intangible.
+This function does not have meaning in XEmacs because it seems that
+the extent 'intangible' property does not exist."
+ (semantic-overlay-get (semantic-tag-overlay tag) 'intangible))
+
+(defun semantic-overlay-signal-read-only
+ (overlay after start end &optional len)
+ "Hook used in modification hooks to prevent modification.
+Allows deletion of the entire text.
+Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system."
+ ;; Stolen blithly from cpp.el in Emacs 21.1
+ (if (and (not after)
+ (or (< (semantic-overlay-start overlay) start)
+ (> (semantic-overlay-end overlay) end)))
+ (error "This text is read only")))
+
+(defun semantic-set-tag-read-only (tag &optional writable)
+ "Enable the text in TAG to be made read-only.
+Optional argument WRITABLE should be non-nil to make the text writable
+instead of read-only."
+ (let ((o (semantic-tag-overlay tag))
+ (hook (if writable nil '(semantic-overlay-signal-read-only))))
+ (if (featurep 'xemacs)
+ ;; XEmacs extents have a 'read-only' property.
+ (semantic-overlay-put o 'read-only (not writable))
+ (semantic-overlay-put o 'modification-hooks hook)
+ (semantic-overlay-put o 'insert-in-front-hooks hook)
+ (semantic-overlay-put o 'insert-behind-hooks hook))))
+
+(defun semantic-tag-read-only-p (tag)
+ "Return non-nil if the current TAG is marked read only."
+ (let ((o (semantic-tag-overlay tag)))
+ (if (featurep 'xemacs)
+ ;; XEmacs extents have a 'read-only' property.
+ (semantic-overlay-get o 'read-only)
+ (member 'semantic-overlay-signal-read-only
+ (semantic-overlay-get o 'modification-hooks)))))
+
+;;; backwards compatability
+
+(semantic-alias-obsolete 'semantic-highlight-token
+ 'semantic-highlight-tag)
+(semantic-alias-obsolete 'semantic-unhighlight-token
+ 'semantic-unhighlight-tag)
+(semantic-alias-obsolete 'semantic-momentary-highlight-token
+ 'semantic-momentary-highlight-tag)
+(semantic-alias-obsolete 'semantic-set-token-face
+ 'semantic-set-tag-face)
+(semantic-alias-obsolete 'semantic-set-token-invisible
+ 'semantic-set-tag-invisible)
+(semantic-alias-obsolete 'semantic-token-invisible-p
+ 'semantic-tag-invisible-p)
+(semantic-alias-obsolete 'semantic-set-token-intangible
+ 'semantic-set-tag-intangible)
+(semantic-alias-obsolete 'semantic-token-intangible-p
+ 'semantic-tag-intangible-p)
+(semantic-alias-obsolete 'semantic-set-token-read-only
+ 'semantic-set-tag-read-only)
+(semantic-alias-obsolete 'semantic-token-read-only-p
+ 'semantic-tag-read-only-p)
+
+;;; Secondary overlays
+;;
+;; Some types of decoration require a second overlay to be made.
+;; It could be for images, arrows, or whatever.
+;; We need a way to create such an overlay, and make sure it
+;; gets whacked, but doesn't show up in the master list
+;; of overlays used for searching.
+(defun semantic-tag-secondary-overlays (tag)
+ "Return a list of secondary overlays active on TAG."
+ (semantic--tag-get-property tag 'secondary-overlays))
+
+(defun semantic-tag-create-secondary-overlay (tag &optional link-hook)
+ "Create a secondary overlay for TAG.
+Returns an overlay. The overlay is also saved in TAG.
+LINK-HOOK is a function called whenever TAG is to be linked into
+a buffer. It should take TAG and OVERLAY as arguments.
+The LINK-HOOK should be used to position and set properties on the
+generated secondary overlay."
+ (if (not (semantic-tag-overlay tag))
+ ;; do nothing if there is no overlay
+ nil
+ (let* ((os (semantic-tag-start tag))
+ (oe (semantic-tag-end tag))
+ (o (semantic-make-overlay os oe (semantic-tag-buffer tag) t))
+ (attr (semantic-tag-secondary-overlays tag))
+ )
+ (semantic--tag-put-property tag 'secondary-overlays (cons o attr))
+ (semantic-overlay-put o 'semantic-secondary t)
+ (semantic-overlay-put o 'semantic-link-hook link-hook)
+ (semantic-tag-add-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
+ (semantic-tag-add-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
+ (semantic-tag-add-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
+ (run-hook-with-args link-hook tag o)
+ o)))
+
+(defun semantic-tag-get-secondary-overlay (tag property)
+ "Return secondary overlays from TAG with PROPERTY.
+PROPERTY is a symbol and all overlays with that symbol are returned.."
+ (let* ((olsearch (semantic-tag-secondary-overlays tag))
+ (o nil))
+ (while olsearch
+ (when (semantic-overlay-get (car olsearch) property)
+ (setq o (cons (car olsearch) o)))
+ (setq olsearch (cdr olsearch)))
+ o))
+
+(defun semantic-tag-delete-secondary-overlay (tag overlay-or-property)
+ "Delete from TAG the secondary overlay OVERLAY-OR-PROPERTY.
+If OVERLAY-OR-PROPERTY is an overlay, delete that overlay.
+If OVERLAY-OR-PROPERTY is a symbol, find the overlay with that property."
+ (let* ((o overlay-or-property))
+ (if (semantic-overlay-p o)
+ (setq o (list o))
+ (setq o (semantic-tag-get-secondary-overlay tag overlay-or-property)))
+ (while (semantic-overlay-p (car o))
+ ;; We don't really need to worry about the hooks.
+ ;; They will clean themselves up eventually ??
+ (semantic--tag-put-property
+ tag 'secondary-overlays
+ (delete (car o) (semantic-tag-secondary-overlays tag)))
+ (semantic-overlay-delete (car o))
+ (setq o (cdr o)))))
+
+(defun semantic--tag-unlink-copy-secondary-overlays (tag)
+ "Unlink secondary overlays from TAG which is a copy.
+This means we don't destroy the overlays, only remove reference
+from them in TAG."
+ (let ((ol (semantic-tag-secondary-overlays tag)))
+ (while ol
+ ;; Else, remove all traces of ourself from the tag
+ ;; Note to self: Does this prevent multiple types of secondary
+ ;; overlays per tag?
+ (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
+ (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
+ (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
+ ;; Next!
+ (setq ol (cdr ol)))
+ (semantic--tag-put-property tag 'secondary-overlays nil)
+ ))
+
+(defun semantic--tag-unlink-secondary-overlays (tag)
+ "Unlink secondary overlays from TAG."
+ (let ((ol (semantic-tag-secondary-overlays tag))
+ (nl nil))
+ (while ol
+ (if (semantic-overlay-get (car ol) 'semantic-link-hook)
+ ;; Only put in a proxy if there is a link-hook. If there is no link-hook
+ ;; the decorating mode must know when tags are unlinked on its own.
+ (setq nl (cons (semantic-overlay-get (car ol) 'semantic-link-hook)
+ nl))
+ ;; Else, remove all traces of ourself from the tag
+ ;; Note to self: Does this prevent multiple types of secondary
+ ;; overlays per tag?
+ (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays)
+ (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays)
+ (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays)
+ )
+ (semantic-overlay-delete (car ol))
+ (setq ol (cdr ol)))
+ (semantic--tag-put-property tag 'secondary-overlays (nreverse nl))
+ ))
+
+(defun semantic--tag-link-secondary-overlays (tag)
+ "Unlink secondary overlays from TAG."
+ (let ((ol (semantic-tag-secondary-overlays tag)))
+ ;; Wipe out old values.
+ (semantic--tag-put-property tag 'secondary-overlays nil)
+ ;; Run all the link hooks.
+ (while ol
+ (semantic-tag-create-secondary-overlay tag (car ol))
+ (setq ol (cdr ol)))
+ ))
+
+;;; Secondary Overlay Uses
+;;
+;; States to put on tags that depend on a secondary overlay.
+(defun semantic-set-tag-folded (tag &optional folded)
+ "Fold TAG, such that only the first line of text is shown.
+Optional argument FOLDED should be non-nil to fold the tag.
+nil implies the tag should be fully shown."
+ ;; If they are different, do the deed.
+ (let ((o (semantic-tag-folded-p tag)))
+ (if (not folded)
+ ;; We unfold.
+ (when o
+ (semantic-tag-delete-secondary-overlay tag 'semantic-folded))
+ (unless o
+ ;; Add the foldn
+ (setq o (semantic-tag-create-secondary-overlay tag))
+ ;; mark as folded
+ (semantic-overlay-put o 'semantic-folded t)
+ ;; Move to cover end of tag
+ (save-excursion
+ (goto-char (semantic-tag-start tag))
+ (end-of-line)
+ (semantic-overlay-move o (point) (semantic-tag-end tag)))
+ ;; We need to modify the invisibility spec for this to
+ ;; work.
+ (if (or (eq buffer-invisibility-spec t)
+ (not (assoc 'semantic-fold buffer-invisibility-spec)))
+ (add-to-invisibility-spec '(semantic-fold . t)))
+ (semantic-overlay-put o 'invisible 'semantic-fold)
+ (overlay-put o 'isearch-open-invisible
+ 'semantic-set-tag-folded-isearch)))
+ ))
+
+(defun semantic-set-tag-folded-isearch (overlay)
+ "Called by isearch if it discovers text in the folded region.
+OVERLAY is passed in by isearch."
+ (semantic-set-tag-folded (semantic-current-tag) nil)
+ )
+
+(defun semantic-tag-folded-p (tag)
+ "Non-nil if TAG is currently folded."
+ (semantic-tag-get-secondary-overlay tag 'semantic-folded)
+ )
+
+(provide 'semantic/decorate)
+
+;;; semantic-decorate.el ends here
--- /dev/null
+;;; semantic-lex-spp.el --- Semantic Lexical Pre-processor
+
+;;; Copyright (C) 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:
+;;
+;; The Semantic Preprocessor works with semantic-lex to provide a phase
+;; during lexical analysis to do the work of a pre-processor.
+;;
+;; A pre-processor identifies lexical syntax mixed in with another language
+;; and replaces some keyword tokens with streams of alternate tokens.
+;;
+;; If you use SPP in your language, be sure to specify this in your
+;; semantic language setup function:
+;;
+;; (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t)
+;;
+;;
+;; Special Lexical Tokens:
+;;
+;; There are several special lexical tokens that are used by the
+;; Semantic PreProcessor lexer. They are:
+;;
+;; Declarations:
+;; spp-macro-def - A definition of a lexical macro.
+;; spp-macro-undef - A removal of a definition of a lexical macro.
+;; spp-system-include - A system level include file
+;; spp-include - An include file
+;; spp-concat - A lexical token representing textual concatenation
+;; of symbol parts.
+;;
+;; Operational tokens:
+;; spp-arg-list - Represents an argument list to a macro.
+;; spp-symbol-merge - A request for multiple symbols to be textually merged.
+;;
+;;; TODO:
+;;
+;; Use `semantic-push-parser-warning' for situations where there are likely
+;; macros that are undefined unexpectedly, or other problem.
+;;
+;; TODO:
+;;
+;; Try to handle the case of:
+;;
+;; #define NN namespace nn {
+;; #define NN_END }
+;;
+;; NN
+;; int mydecl() {}
+;; NN_END
+;;
+
+(require 'semantic/lex)
+
+;;; Code:
+(defvar semantic-lex-spp-macro-symbol-obarray nil
+ "Table of macro keywords used by the Semantic Preprocessor.
+These symbols will be used in addition to those in
+`semantic-lex-spp-dynamic-macro-symbol-obarray'.")
+(make-variable-buffer-local 'semantic-lex-spp-macro-symbol-obarray)
+
+(defvar semantic-lex-spp-project-macro-symbol-obarray nil
+ "Table of macro keywords for this project.
+These symbols will be used in addition to those in
+`semantic-lex-spp-dynamic-macro-symbol-obarray'.")
+(make-variable-buffer-local 'semantic-lex-spp-project-macro-symbol-obarray)
+
+(defvar semantic-lex-spp-dynamic-macro-symbol-obarray nil
+ "Table of macro keywords used during lexical analysis.
+Macros are lexical symbols which are replaced by other lexical
+tokens during lexical analysis. During analysis symbols can be
+added and removed from this symbol table.")
+(make-variable-buffer-local 'semantic-lex-spp-dynamic-macro-symbol-obarray)
+
+(defvar semantic-lex-spp-dynamic-macro-symbol-obarray-stack nil
+ "A stack of obarrays for temporarilly scoped macro values.")
+(make-variable-buffer-local 'semantic-lex-spp-dynamic-macro-symbol-obarray-stack)
+
+(defvar semantic-lex-spp-expanded-macro-stack nil
+ "The stack of lexical SPP macros we have expanded.")
+;; The above is not buffer local. Some macro expansions need to be
+;; dumped into a secondary buffer for re-lexing.
+
+;;; NON-RECURSIVE MACRO STACK
+;; C Pre-processor does not allow recursive macros. Here are some utils
+;; for managing the symbol stack of where we've been.
+
+(defmacro semantic-lex-with-macro-used (name &rest body)
+ "With the macro NAME currently being expanded, execute BODY.
+Pushes NAME into the macro stack. The above stack is checked
+by `semantic-lex-spp-symbol' to not return true for any symbol
+currently being expanded."
+ `(unwind-protect
+ (progn
+ (push ,name semantic-lex-spp-expanded-macro-stack)
+ ,@body)
+ (pop semantic-lex-spp-expanded-macro-stack)))
+(put 'semantic-lex-with-macro-used 'lisp-indent-function 1)
+
+(add-hook
+ 'edebug-setup-hook
+ #'(lambda ()
+
+ (def-edebug-spec semantic-lex-with-macro-used
+ (symbolp def-body)
+ )
+
+ ))
+
+;;; MACRO TABLE UTILS
+;;
+;; The dynamic macro table is a buffer local variable that is modified
+;; during the analysis. OBARRAYs are used, so the language must
+;; have symbols that are compatible with Emacs Lisp symbols.
+;;
+(defsubst semantic-lex-spp-symbol (name)
+ "Return spp symbol with NAME or nil if not found.
+The searcy priority is:
+ 1. DYNAMIC symbols
+ 2. PROJECT specified symbols.
+ 3. SYSTEM specified symbols."
+ (and
+ ;; Only strings...
+ (stringp name)
+ ;; Make sure we don't recurse.
+ (not (member name semantic-lex-spp-expanded-macro-stack))
+ ;; Do the check of the various tables.
+ (or
+ ;; DYNAMIC
+ (and (arrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
+ (intern-soft name semantic-lex-spp-dynamic-macro-symbol-obarray))
+ ;; PROJECT
+ (and (arrayp semantic-lex-spp-project-macro-symbol-obarray)
+ (intern-soft name semantic-lex-spp-project-macro-symbol-obarray))
+ ;; SYSTEM
+ (and (arrayp semantic-lex-spp-macro-symbol-obarray)
+ (intern-soft name semantic-lex-spp-macro-symbol-obarray))
+ ;; ...
+ )))
+
+(defsubst semantic-lex-spp-symbol-p (name)
+ "Return non-nil if a keyword with NAME exists in any keyword table."
+ (if (semantic-lex-spp-symbol name)
+ t))
+
+(defsubst semantic-lex-spp-dynamic-map ()
+ "Return the dynamic macro map for the current buffer."
+ (or semantic-lex-spp-dynamic-macro-symbol-obarray
+ (setq semantic-lex-spp-dynamic-macro-symbol-obarray
+ (make-vector 13 0))))
+
+(defsubst semantic-lex-spp-dynamic-map-stack ()
+ "Return the dynamic macro map for the current buffer."
+ (or semantic-lex-spp-dynamic-macro-symbol-obarray-stack
+ (setq semantic-lex-spp-dynamic-macro-symbol-obarray-stack
+ (make-vector 13 0))))
+
+(defun semantic-lex-spp-symbol-set (name value &optional obarray-in)
+ "Set value of spp symbol with NAME to VALUE and return VALUE.
+If optional OBARRAY-IN is non-nil, then use that obarray instead of
+the dynamic map."
+ (if (and (stringp value) (string= value "")) (setq value nil))
+ (set (intern name (or obarray-in
+ (semantic-lex-spp-dynamic-map)))
+ value))
+
+(defsubst semantic-lex-spp-symbol-remove (name &optional obarray)
+ "Remove the spp symbol with NAME.
+If optional OBARRAY is non-nil, then use that obarray instead of
+the dynamic map."
+ (unintern name (or obarray
+ (semantic-lex-spp-dynamic-map))))
+
+(defun semantic-lex-spp-symbol-push (name value)
+ "Push macro NAME with VALUE into the map.
+Reverse with `semantic-lex-spp-symbol-pop'."
+ (let* ((map (semantic-lex-spp-dynamic-map))
+ (stack (semantic-lex-spp-dynamic-map-stack))
+ (mapsym (intern name map))
+ (stacksym (intern name stack))
+ (mapvalue (when (boundp mapsym) (symbol-value mapsym)))
+ )
+ (when (boundp mapsym)
+ ;; Make sure there is a stack
+ (if (not (boundp stacksym)) (set stacksym nil))
+ ;; If there is a value to push, then push it.
+ (set stacksym (cons mapvalue (symbol-value stacksym)))
+ )
+ ;; Set our new value here.
+ (set mapsym value)
+ ))
+
+(defun semantic-lex-spp-symbol-pop (name)
+ "Pop macro NAME from the stackmap into the orig map.
+Reverse with `semantic-lex-spp-symbol-pop'."
+ (let* ((map (semantic-lex-spp-dynamic-map))
+ (stack (semantic-lex-spp-dynamic-map-stack))
+ (mapsym (intern name map))
+ (stacksym (intern name stack))
+ (oldvalue nil)
+ )
+ (if (or (not (boundp stacksym) )
+ (= (length (symbol-value stacksym)) 0))
+ ;; Nothing to pop, remove it.
+ (unintern name map)
+ ;; If there is a value to pop, then add it to the map.
+ (set mapsym (car (symbol-value stacksym)))
+ (set stacksym (cdr (symbol-value stacksym)))
+ )))
+
+(defsubst semantic-lex-spp-symbol-stream (name)
+ "Return replacement stream of macro with NAME."
+ (let ((spp (semantic-lex-spp-symbol name)))
+ (if spp
+ (symbol-value spp))))
+
+(defun semantic-lex-make-spp-table (specs)
+ "Convert spp macro list SPECS into an obarray and return it.
+SPECS must be a list of (NAME . REPLACEMENT) elements, where:
+
+NAME is the name of the spp macro symbol to define.
+REPLACEMENT a string that would be substituted in for NAME."
+
+ ;; Create the symbol hash table
+ (let ((semantic-lex-spp-macro-symbol-obarray (make-vector 13 0))
+ spec)
+ ;; fill it with stuff
+ (while specs
+ (setq spec (car specs)
+ specs (cdr specs))
+ (semantic-lex-spp-symbol-set
+ (car spec)
+ (cdr spec)
+ semantic-lex-spp-macro-symbol-obarray))
+ semantic-lex-spp-macro-symbol-obarray))
+
+(defun semantic-lex-spp-save-table ()
+ "Return a list of spp macros and values.
+The return list is meant to be saved in a semanticdb table."
+ (let (macros)
+ (when (arrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
+ (mapatoms
+ #'(lambda (symbol)
+ (setq macros (cons (cons (symbol-name symbol)
+ (symbol-value symbol))
+ macros)))
+ semantic-lex-spp-dynamic-macro-symbol-obarray))
+ macros))
+
+(defun semantic-lex-spp-macros ()
+ "Return a list of spp macros as Lisp symbols.
+The value of each symbol is the replacement stream."
+ (let (macros)
+ (when (arrayp semantic-lex-spp-macro-symbol-obarray)
+ (mapatoms
+ #'(lambda (symbol)
+ (setq macros (cons symbol macros)))
+ semantic-lex-spp-macro-symbol-obarray))
+ (when (arrayp semantic-lex-spp-project-macro-symbol-obarray)
+ (mapatoms
+ #'(lambda (symbol)
+ (setq macros (cons symbol macros)))
+ semantic-lex-spp-project-macro-symbol-obarray))
+ (when (arrayp semantic-lex-spp-dynamic-macro-symbol-obarray)
+ (mapatoms
+ #'(lambda (symbol)
+ (setq macros (cons symbol macros)))
+ semantic-lex-spp-dynamic-macro-symbol-obarray))
+ macros))
+
+(defun semantic-lex-spp-set-dynamic-table (new-entries)
+ "Set the dynamic symbol table to NEW-ENTRIES.
+For use with semanticdb restoration of state."
+ (dolist (e new-entries)
+ ;; Default obarray for below is the dynamic map.
+ (semantic-lex-spp-symbol-set (car e) (cdr e))))
+
+(defun semantic-lex-spp-reset-hook (start end)
+ "Reset anything needed by SPP for parsing.
+In this case, reset the dynamic macro symbol table if
+START is (point-min).
+END is not used."
+ (when (= start (point-min))
+ (setq semantic-lex-spp-dynamic-macro-symbol-obarray nil
+ semantic-lex-spp-dynamic-macro-symbol-obarray-stack nil
+ ;; This shouldn't not be nil, but reset just in case.
+ semantic-lex-spp-expanded-macro-stack nil)
+ ))
+
+;;; MACRO EXPANSION: Simple cases
+;;
+;; If a user fills in the table with simple strings, we can
+;; support that by converting them into tokens with the
+;; various analyzers that are available.
+
+(defun semantic-lex-spp-extract-regex-and-compare (analyzer value)
+ "Extract a regexp from an ANALYZER and use to match VALUE.
+Return non-nil if it matches"
+ (let* ((condition (car analyzer))
+ (regex (cond ((eq (car condition) 'looking-at)
+ (nth 1 condition))
+ (t
+ nil))))
+ (when regex
+ (string-match regex value))
+ ))
+
+(defun semantic-lex-spp-simple-macro-to-macro-stream (val beg end argvalues)
+ "Convert lexical macro contents VAL into a macro expansion stream.
+These are for simple macro expansions that a user may have typed in directly.
+As such, we need to analyze the input text, to figure out what kind of real
+lexical token we should be inserting in its place.
+
+Argument VAL is the value of some macro to be converted into a stream.
+BEG and END are the token bounds of the macro to be expanded
+that will somehow gain a much longer token stream.
+ARGVALUES are values for any arg list, or nil."
+ (cond
+ ;; We perform a replacement. Technically, this should
+ ;; be a full lexical step over the "val" string, but take
+ ;; a guess that its just a keyword or existing symbol.
+ ;;
+ ;; Probably a really bad idea. See how it goes.
+ ((semantic-lex-spp-extract-regex-and-compare
+ semantic-lex-symbol-or-keyword val)
+ (semantic-lex-push-token
+ (semantic-lex-token (or (semantic-lex-keyword-p val) 'symbol)
+ beg end
+ val)))
+
+ ;; Ok, the rest of these are various types of syntax.
+ ;; Conveniences for users that type in their symbol table.
+ ((semantic-lex-spp-extract-regex-and-compare
+ semantic-lex-punctuation val)
+ (semantic-lex-token 'punctuation beg end val))
+ ((semantic-lex-spp-extract-regex-and-compare
+ semantic-lex-number val)
+ (semantic-lex-token 'number beg end val))
+ ((semantic-lex-spp-extract-regex-and-compare
+ semantic-lex-paren-or-list val)
+ (semantic-lex-token 'semantic-list beg end val))
+ ((semantic-lex-spp-extract-regex-and-compare
+ semantic-lex-string val)
+ (semantic-lex-token 'string beg end val))
+ (t nil)
+ ))
+
+;;; MACRO EXPANSION : Lexical token replacement
+;;
+;; When substituting in a macro from a token stream of formatted
+;; semantic lex tokens, things can be much more complicated.
+;;
+;; Some macros have arguments that get set into the dynamic macro
+;; table during replacement.
+;;
+;; In general, the macro tokens are substituted into the regular
+;; token stream, but placed under the characters of the original
+;; macro symbol.
+;;
+;; Argument lists are saved as a lexical token at the beginning
+;; of a replacement value.
+
+(defun semantic-lex-spp-one-token-to-txt (tok)
+ "Convert the token TOK into a string.
+If TOK is made of multiple tokens, convert those to text. This
+conversion is needed if a macro has a merge symbol in it that
+combines the text of two previously distinct symbols. For
+exampe, in c:
+
+#define (a,b) a ## b;"
+ (let ((txt (semantic-lex-token-text tok))
+ (sym nil)
+ )
+ (cond ((and (eq (car tok) 'symbol)
+ (setq sym (semantic-lex-spp-symbol txt))
+ (not (semantic-lex-spp-macro-with-args (symbol-value sym)))
+ )
+ ;; Now that we have a symbol,
+ (let ((val (symbol-value sym)))
+ (cond ((and (consp val)
+ (symbolp (car val)))
+ (semantic-lex-spp-one-token-to-txt val))
+ ((and (consp val)
+ (consp (car val))
+ (symbolp (car (car val))))
+ (mapconcat (lambda (subtok)
+ (semantic-lex-spp-one-token-to-txt subtok))
+ val
+ ""))
+ ;; If val is nil, that's probably wrong.
+ ;; Found a system header case where this was true.
+ ((null val) "")
+ ;; Debug wierd stuff.
+ (t (debug)))
+ ))
+ ((stringp txt)
+ txt)
+ (t nil))
+ ))
+
+(defun semantic-lex-spp-macro-with-args (val)
+ "If the macro value VAL has an argument list, return the arglist."
+ (when (and val (consp val) (consp (car val))
+ (eq 'spp-arg-list (car (car val))))
+ (car (cdr (car val)))))
+
+(defun semantic-lex-spp-token-macro-to-macro-stream (val beg end argvalues)
+ "Convert lexical macro contents VAL into a macro expansion stream.
+Argument VAL is the value of some macro to be converted into a stream.
+BEG and END are the token bounds of the macro to be expanded
+that will somehow gain a much longer token stream.
+ARGVALUES are values for any arg list, or nil.
+See comments in code for information about how token streams are processed
+and what valid VAL values are."
+
+ ;; A typical VAL value might be either a stream of tokens.
+ ;; Tokens saved into a macro stream always includes the text from the
+ ;; buffer, since the locations specified probably don't represent
+ ;; that text anymore, or even the same buffer.
+ ;;
+ ;; CASE 1: Simple token stream
+ ;;
+ ;; #define SUPER mysuper::
+ ;; ==>
+ ;;((symbol "mysuper" 480 . 487)
+ ;; (punctuation ":" 487 . 488)
+ ;; (punctuation ":" 488 . 489))
+ ;;
+ ;; CASE 2: Token stream with argument list
+ ;;
+ ;; #define INT_FCN(name) int name (int in)
+ ;; ==>
+ ;; ((spp-arg-list ("name") 558 . 564)
+ ;; (INT "int" 565 . 568)
+ ;; (symbol "name" 569 . 573)
+ ;; (semantic-list "(int in)" 574 . 582))
+ ;;
+ ;; In the second case, a macro with an argument list as the a rgs as the
+ ;; first entry.
+ ;;
+ ;; CASE 3: Symbol text merge
+ ;;
+ ;; #define TMP(a) foo_ ## a
+ ;; ==>
+ ;; ((spp-arg-list ("a") 20 . 23)
+ ;; (spp-symbol-merge ((symbol "foo_" 24 . 28) (symbol "a" 32 . 33))
+ ;; 24 . 33))
+ ;;
+ ;; Usually in conjunction with a macro with an argument, merging symbol
+ ;; parts is a way of fabricating new symbols from pieces inside the macro.
+ ;; These macros use `spp-symbol-merge' tokens whose TEXT part is another
+ ;; token stream. This sub-stream ought to consist of only 2 SYMBOL pieces,
+ ;; though I suppose keywords might be ok. The end result of this example
+ ;; merge symbol would be (symbol "foo_A" 24 . 33) where A is the symbol
+ ;; passed in from the arg list "a".
+ ;;
+ ;; CASE 4: Nested token streams
+ ;;
+ ;; #define FOO(f) f
+ ;; #define BLA bla FOO(foo)
+ ;; ==>
+ ;; ((INT "int" 82 . 85)
+ ;; (symbol "FOO" 86 . 89)
+ ;; (semantic-list "(foo)" 89 . 94))
+ ;;
+ ;; Nested token FOO shows up in the table of macros, and gets replace
+ ;; inline. This is the same as case 2.
+
+ (let ((arglist (semantic-lex-spp-macro-with-args val))
+ (argalist nil)
+ (val-tmp nil)
+ (v nil)
+ )
+ ;; CASE 2: Dealing with the arg list.
+ (when arglist
+ ;; Skip the arg list.
+ (setq val (cdr val))
+
+ ;; Push args into the replacement list.
+ (let ((AV argvalues))
+ (dolist (A arglist)
+ (let* ((argval (car AV)))
+
+ (semantic-lex-spp-symbol-push A argval)
+ (setq argalist (cons (cons A argval) argalist))
+ (setq AV (cdr AV)))))
+ )
+
+ ;; Set val-tmp after stripping arguments.
+ (setq val-tmp val)
+
+ ;; CASE 1: Push everything else onto the list.
+ ;; Once the arg list is stripped off, CASE 2 is the same
+ ;; as CASE 1.
+ (while val-tmp
+ (setq v (car val-tmp))
+ (setq val-tmp (cdr val-tmp))
+
+ (let* (;; The text of the current lexical token.
+ (txt (car (cdr v)))
+ ;; Try to convert txt into a macro declaration. If it is
+ ;; not a macro, use nil.
+ (txt-macro-or-nil (semantic-lex-spp-symbol txt))
+ ;; If our current token is a macro, then pull off the argument
+ ;; list.
+ (macro-and-args
+ (when txt-macro-or-nil
+ (semantic-lex-spp-macro-with-args (symbol-value txt-macro-or-nil)))
+ )
+ ;; We need to peek at the next token when testing for
+ ;; used macros with arg lists.
+ (next-tok-class (semantic-lex-token-class (car val-tmp)))
+ )
+
+ (cond
+ ;; CASE 3: Merge symbols together.
+ ((eq (semantic-lex-token-class v) 'spp-symbol-merge)
+ ;; We need to merge the tokens in the 'text segement together,
+ ;; and produce a single symbol from it.
+ (let ((newsym
+ (mapconcat (lambda (tok)
+ (semantic-lex-spp-one-token-to-txt tok))
+ txt
+ "")))
+ (semantic-lex-push-token
+ (semantic-lex-token 'symbol beg end newsym))
+ ))
+
+ ;; CASE 2: Argument replacement. If a discovered symbol is in
+ ;; the active list of arguments, then we need to substitute
+ ;; in the new value.
+ ((and (eq (semantic-lex-token-class v) 'symbol) txt-macro-or-nil
+ (or (and macro-and-args (eq next-tok-class 'semantic-list))
+ (not macro-and-args))
+ )
+ (let ((AV nil))
+ (when macro-and-args
+ (setq AV
+ (semantic-lex-spp-stream-for-arglist (car val-tmp)))
+ ;; We used up these args. Pull from the stream.
+ (setq val-tmp (cdr val-tmp))
+ )
+
+ (semantic-lex-with-macro-used txt
+ ;; Don't recurse directly into this same fcn, because it is
+ ;; convenient to have plain string replacements too.
+ (semantic-lex-spp-macro-to-macro-stream
+ (symbol-value txt-macro-or-nil)
+ beg end AV))
+ ))
+
+ ;; This is a HACK for the C parser. The 'macros text
+ ;; property is some storage so that the parser can do
+ ;; some C specific text manipulations.
+ ((eq (semantic-lex-token-class v) 'semantic-list)
+ ;; Push our arg list onto the semantic list.
+ (when argalist
+ (setq txt (concat txt)) ; Copy the text.
+ (put-text-property 0 1 'macros argalist txt))
+ (semantic-lex-push-token
+ (semantic-lex-token (semantic-lex-token-class v) beg end txt))
+ )
+
+ ;; CASE 1: Just another token in the stream.
+ (t
+ ;; Nothing new.
+ (semantic-lex-push-token
+ (semantic-lex-token (semantic-lex-token-class v) beg end txt))
+ )
+ )))
+
+ ;; CASE 2: The arg list we pushed onto the symbol table
+ ;; must now be removed.
+ (dolist (A arglist)
+ (semantic-lex-spp-symbol-pop A))
+ ))
+
+;;; Macro Merging
+;;
+;; Used when token streams from different macros include eachother.
+;; Merged macro streams perform in place replacements.
+
+(defun semantic-lex-spp-merge-streams (raw-stream)
+ "Merge elements from the RAW-STREAM together.
+Handle spp-concat symbol concatenation.
+Handle Nested macro replacements.
+Return the cooked stream."
+ (let ((cooked-stream nil))
+ ;; Merge the stream
+ (while raw-stream
+ (cond ((eq (semantic-lex-token-class (car raw-stream)) 'spp-concat)
+ ;; handle hashhash, by skipping it.
+ (setq raw-stream (cdr raw-stream))
+ ;; Now merge the symbols.
+ (let ((prev-tok (car cooked-stream))
+ (next-tok (car raw-stream)))
+ (setq cooked-stream (cdr cooked-stream))
+ (push (semantic-lex-token
+ 'spp-symbol-merge
+ (semantic-lex-token-start prev-tok)
+ (semantic-lex-token-end next-tok)
+ (list prev-tok next-tok))
+ cooked-stream)
+ ))
+ (t
+ (push (car raw-stream) cooked-stream))
+ )
+ (setq raw-stream (cdr raw-stream))
+ )
+
+ (nreverse cooked-stream))
+ )
+
+;;; MACRO EXPANSION
+;;
+;; There are two types of expansion.
+;;
+;; 1. Expansion using a value made up of lexical tokens.
+;; 2. User input replacement from a plain string.
+
+(defun semantic-lex-spp-macro-to-macro-stream (val beg end argvalues)
+ "Convert lexical macro contents VAL into a macro expansion stream.
+Argument VAL is the value of some macro to be converted into a stream.
+BEG and END are the token bounds of the macro to be expanded
+that will somehow gain a much longer token stream.
+ARGVALUES are values for any arg list, or nil."
+ (cond
+ ;; If val is nil, then just skip it.
+ ((null val) t)
+ ;; If it is a token, then return that token rebuilt.
+ ((and (consp val) (car val) (symbolp (car val)))
+ (semantic-lex-push-token
+ (semantic-lex-token (car val) beg end (semantic-lex-token-text val))))
+ ;; Test for a token list.
+ ((and (consp val) (consp (car val)) (car (car val))
+ (symbolp (car (car val))))
+ (semantic-lex-spp-token-macro-to-macro-stream val beg end argvalues))
+ ;; Test for miscellaneous strings.
+ ((stringp val)
+ (semantic-lex-spp-simple-macro-to-macro-stream val beg end argvalues))
+ ))
+
+;;; --------------------------------------------------------
+;;;
+;;; ANALYZERS:
+;;;
+
+;;; Symbol Is Macro
+;;
+;; An analyser that will push tokens from a macro in place
+;; of the macro symbol.
+;;
+(defun semantic-lex-spp-anlyzer-do-replace (sym val beg end)
+ "Do the lexical replacement for SYM with VAL.
+Argument BEG and END specify the bounds of SYM in the buffer."
+ (if (not val)
+ (setq semantic-lex-end-point end)
+ (let ((arg-in nil)
+ (arg-parsed nil)
+ (arg-split nil)
+ )
+
+ ;; Check for arguments.
+ (setq arg-in (semantic-lex-spp-macro-with-args val))
+
+ (when arg-in
+ (save-excursion
+ (goto-char end)
+ (setq arg-parsed
+ (semantic-lex-spp-one-token-and-move-for-macro
+ (point-at-eol)))
+ (setq end (semantic-lex-token-end arg-parsed))
+
+ (when (and (listp arg-parsed) (eq (car arg-parsed) 'semantic-list))
+ (setq arg-split
+ ;; Use lex to split up the contents of the argument list.
+ (semantic-lex-spp-stream-for-arglist arg-parsed)
+ ))
+ ))
+
+ ;; if we have something to sub in, then do it.
+ (semantic-lex-spp-macro-to-macro-stream val beg end arg-split)
+ (setq semantic-lex-end-point end)
+ )
+ ))
+
+(defvar semantic-lex-spp-replacements-enabled t
+ "Non-nil means do replacements when finding keywords.
+Disable this only to prevent recursive expansion issues.")
+
+(defun semantic-lex-spp-analyzer-push-tokens-for-symbol (str beg end)
+ "Push lexical tokens for the symbol or keyword STR.
+STR occurs in the current buffer between BEG and END."
+ (let (sym val)
+ (cond
+ ;;
+ ;; It is a macro. Prepare for a replacement.
+ ((and semantic-lex-spp-replacements-enabled
+ (semantic-lex-spp-symbol-p str))
+ (setq sym (semantic-lex-spp-symbol str)
+ val (symbol-value sym)
+ count 0)
+
+ (let ((semantic-lex-spp-expanded-macro-stack
+ semantic-lex-spp-expanded-macro-stack))
+
+ (semantic-lex-with-macro-used str
+ ;; Do direct replacements of single value macros of macros.
+ ;; This solves issues with a macro containing one symbol that
+ ;; is another macro, and get arg lists passed around.
+ (while (and val (consp val)
+ (semantic-lex-token-p (car val))
+ (eq (length val) 1)
+ (eq (semantic-lex-token-class (car val)) 'symbol)
+ (semantic-lex-spp-symbol-p (semantic-lex-token-text (car val)))
+ (< count 10)
+ )
+ (setq str (semantic-lex-token-text (car val)))
+ (setq sym (semantic-lex-spp-symbol str)
+ val (symbol-value sym))
+ ;; Prevent recursion
+ (setq count (1+ count))
+ ;; This prevents a different kind of recursion.
+ (push str semantic-lex-spp-expanded-macro-stack)
+ )
+
+ (semantic-lex-spp-anlyzer-do-replace sym val beg end))
+
+ ))
+ ;; Anything else.
+ (t
+ ;; A regular keyword.
+ (semantic-lex-push-token
+ (semantic-lex-token (or (semantic-lex-keyword-p str) 'symbol)
+ beg end))))
+ ))
+
+(define-lex-regex-analyzer semantic-lex-spp-replace-or-symbol-or-keyword
+ "Like 'semantic-lex-symbol-or-keyword' plus preprocessor macro replacement."
+ "\\(\\sw\\|\\s_\\)+"
+ (let ((str (match-string 0))
+ (beg (match-beginning 0))
+ (end (match-end 0)))
+ (semantic-lex-spp-analyzer-push-tokens-for-symbol str beg end)))
+
+;;; ANALYZERS FOR NEW MACROS
+;;
+;; These utilities and analyzer declaration function are for
+;; creating an analyzer which produces new macros in the macro table.
+;;
+;; There are two analyzers. One for new macros, and one for removing
+;; a macro.
+
+(defun semantic-lex-spp-first-token-arg-list (token)
+ "If TOKEN is a semantic-list, turn it into a an SPP ARG LIST."
+ (when (and (consp token)
+ (symbolp (car token))
+ (eq 'semantic-list (car token)))
+ ;; Convert TOKEN in place.
+ (let ((argsplit (cedet-split-string (semantic-lex-token-text token)
+ "[(), ]" t)))
+ (setcar token 'spp-arg-list)
+ (setcar (nthcdr 1 token) argsplit))
+ ))
+
+(defun semantic-lex-spp-one-token-and-move-for-macro (max)
+ "Lex up one token, and move to end of that token.
+Don't go past MAX."
+ (let ((ans (semantic-lex (point) max 0 0)))
+ (if (not ans)
+ (progn (goto-char max)
+ nil)
+ (when (> (semantic-lex-token-end (car ans)) max)
+ (let ((bounds (semantic-lex-token-bounds (car ans))))
+ (setcdr bounds max)))
+ (goto-char (semantic-lex-token-end (car ans)))
+ (car ans))
+ ))
+
+(defun semantic-lex-spp-stream-for-arglist (token)
+ "Lex up the contents of the arglist TOKEN.
+Parsing starts inside the parens, and ends at the end of TOKEN."
+ (let ((end (semantic-lex-token-end token))
+ (fresh-toks nil)
+ (toks nil))
+ (save-excursion
+
+ (if (stringp (nth 1 token))
+ ;; If the 2nd part of the token is a string, then we have
+ ;; a token specifically extracted from a buffer. Possibly
+ ;; a different buffer. This means we need to do something
+ ;; nice to parse its contents.
+ (let ((txt (semantic-lex-token-text token)))
+ (semantic-lex-spp-lex-text-string
+ (substring txt 1 (1- (length txt)))))
+
+ ;; This part is like the original
+ (goto-char (semantic-lex-token-start token))
+ ;; A cheat for going into the semantic list.
+ (forward-char 1)
+ (setq fresh-toks (semantic-lex-spp-stream-for-macro (1- end)))
+ (dolist (tok fresh-toks)
+ (when (memq (semantic-lex-token-class tok) '(symbol semantic-list))
+ (setq toks (cons tok toks))))
+
+ (nreverse toks)))))
+
+(defun semantic-lex-spp-lex-text-string (text)
+ "Lex the text string TEXT using the current buffer's state.
+Use this to parse text extracted from a macro as if it came from
+the current buffer. Since the lexer is designed to only work in
+a buffer, we need to create a new buffer, and populate it with rules
+and variable state from the current buffer."
+ (let* ((buf (get-buffer-create " *SPP parse hack*"))
+ (mode major-mode)
+ (fresh-toks nil)
+ (toks nil)
+ (origbuff (current-buffer))
+ (important-vars '(semantic-lex-spp-macro-symbol-obarray
+ semantic-lex-spp-project-macro-symbol-obarray
+ semantic-lex-spp-dynamic-macro-symbol-obarray
+ semantic-lex-spp-dynamic-macro-symbol-obarray-stack
+ semantic-lex-spp-expanded-macro-stack
+ ))
+ )
+ (set-buffer buf)
+ (erase-buffer)
+ ;; Below is a painful hack to make sure everything is setup correctly.
+ (when (not (eq major-mode mode))
+ (funcall mode)
+ ;; Hack in mode-local
+ (activate-mode-local-bindings)
+ ;; CHEATER! The following 3 lines are from
+ ;; `semantic-new-buffer-fcn', but we don't want to turn
+ ;; on all the other annoying modes for this little task.
+ (setq semantic-new-buffer-fcn-was-run t)
+ (semantic-lex-init)
+ (semantic-clear-toplevel-cache)
+ (remove-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook
+ t)
+ ;; Second Cheat: copy key variables reguarding macro state from the
+ ;; the originating buffer we are parsing.
+ (dolist (V important-vars)
+ (set V (semantic-buffer-local-value V origbuff)))
+ )
+ (insert text)
+ (goto-char (point-min))
+
+ (setq fresh-toks (semantic-lex-spp-stream-for-macro (point-max)))
+ (dolist (tok fresh-toks)
+ (when (memq (semantic-lex-token-class tok) '(symbol semantic-list))
+ (setq toks (cons tok toks))))
+
+ (nreverse toks)))
+
+;;;; FIRST DRAFT
+;; This is the fist version of semantic-lex-spp-stream-for-arglist
+;; that worked pretty well. It doesn't work if the TOKEN was derived
+;; from some other buffer, in which case it can get the wrong answer
+;; or throw an error if the token location in the originating buffer is
+;; larger than the current buffer.
+;;(defun semantic-lex-spp-stream-for-arglist-orig (token)
+;; "Lex up the contents of the arglist TOKEN.
+;; Parsing starts inside the parens, and ends at the end of TOKEN."
+;; (save-excursion
+;; (let ((end (semantic-lex-token-end token))
+;; (fresh-toks nil)
+;; (toks nil))
+;; (goto-char (semantic-lex-token-start token))
+;; ;; A cheat for going into the semantic list.
+;; (forward-char 1)
+;; (setq fresh-toks (semantic-lex-spp-stream-for-macro (1- end)))
+;; (dolist (tok fresh-toks)
+;; (when (memq (semantic-lex-token-class tok) '(symbol semantic-list))
+;; (setq toks (cons tok toks))))
+;; (nreverse toks))
+;; ))
+
+;;;; USING SPLIT
+;; This doesn't work, because some arguments passed into a macro
+;; might contain non-simple symbol words, which this doesn't handle.
+;;
+;; Thus, you need a full lex to occur.
+;; (defun semantic-lex-spp-stream-for-arglist-split (token)
+;; "Lex up the contents of the arglist TOKEN.
+;; Parsing starts inside the parens, and ends at the end of TOKEN."
+;; (let* ((txt (semantic-lex-token-text token))
+;; (split (split-string (substring txt 1 (1- (length txt)))
+;; "(), " t))
+;; ;; Hack for lexing.
+;; (semantic-lex-spp-analyzer-push-tokens-for-symbol nil))
+;; (dolist (S split)
+;; (semantic-lex-spp-analyzer-push-tokens-for-symbol S 0 1))
+;; (reverse semantic-lex-spp-analyzer-push-tokens-for-symbol)))
+
+
+(defun semantic-lex-spp-stream-for-macro (eos)
+ "Lex up a stream of tokens for a #define statement.
+Parsing starts at the current point location.
+EOS is the end of the stream to lex for this macro."
+ (let ((stream nil))
+ (while (< (point) eos)
+ (let* ((tok (semantic-lex-spp-one-token-and-move-for-macro eos))
+ (str (when tok
+ (semantic-lex-token-text tok)))
+ )
+ (if str
+ (push (semantic-lex-token (semantic-lex-token-class tok)
+ (semantic-lex-token-start tok)
+ (semantic-lex-token-end tok)
+ str)
+ stream)
+ ;; Nothing to push.
+ nil)))
+ (goto-char eos)
+ ;; Fix the order
+ (nreverse stream)
+ ))
+
+(defmacro define-lex-spp-macro-declaration-analyzer (name doc regexp tokidx
+ &rest valform)
+ "Define a lexical analyzer for defining new MACROS.
+NAME is the name of the analyzer.
+DOC is the documentation for the analyzer.
+REGEXP is a regular expression for the analyzer to match.
+See `define-lex-regex-analyzer' for more on regexp.
+TOKIDX is an index into REGEXP for which a new lexical token
+of type `spp-macro-def' is to be created.
+VALFORM are forms that return the value to be saved for this macro, or nil.
+When implementing a macro, you can use `semantic-lex-spp-stream-for-macro'
+to convert text into a lexical stream for storage in the macro."
+ (let ((start (make-symbol "start"))
+ (end (make-symbol "end"))
+ (val (make-symbol "val"))
+ (startpnt (make-symbol "startpnt"))
+ (endpnt (make-symbol "endpnt")))
+ `(define-lex-regex-analyzer ,name
+ ,doc
+ ,regexp
+ (let ((,start (match-beginning ,tokidx))
+ (,end (match-end ,tokidx))
+ (,startpnt semantic-lex-end-point)
+ (,val (save-match-data ,@valform))
+ (,endpnt semantic-lex-end-point))
+ (semantic-lex-spp-symbol-set
+ (buffer-substring-no-properties ,start ,end)
+ ,val)
+ (semantic-lex-push-token
+ (semantic-lex-token 'spp-macro-def
+ ,start ,end))
+ ;; Preserve setting of the end point from the calling macro.
+ (when (and (/= ,startpnt ,endpnt)
+ (/= ,endpnt semantic-lex-end-point))
+ (setq semantic-lex-end-point ,endpnt))
+ ))))
+
+(defmacro define-lex-spp-macro-undeclaration-analyzer (name doc regexp tokidx)
+ "Undefine a lexical analyzer for defining new MACROS.
+NAME is the name of the analyzer.
+DOC is the documentation for the analyzer.
+REGEXP is a regular expression for the analyzer to match.
+See `define-lex-regex-analyzer' for more on regexp.
+TOKIDX is an index into REGEXP for which a new lexical token
+of type `spp-macro-undef' is to be created."
+ (let ((start (make-symbol "start"))
+ (end (make-symbol "end")))
+ `(define-lex-regex-analyzer ,name
+ ,doc
+ ,regexp
+ (let ((,start (match-beginning ,tokidx))
+ (,end (match-end ,tokidx))
+ )
+ (semantic-lex-spp-symbol-remove
+ (buffer-substring-no-properties ,start ,end))
+ (semantic-lex-push-token
+ (semantic-lex-token 'spp-macro-undef
+ ,start ,end))
+ ))))
+
+;;; INCLUDES
+;;
+;; These analyzers help a language define how include files
+;; are identified. These are ONLY for languages that perform
+;; an actual textual includesion, and not for imports.
+;;
+;; This section is supposed to allow the macros from the headers to be
+;; added to the local dynamic macro table, but that hasn't been
+;; written yet.
+;;
+(defcustom semantic-lex-spp-use-headers-flag nil
+ "*Non-nil means to pre-parse headers as we go.
+For languages that use the Semantic pre-processor, this can
+improve the accuracy of parsed files where include files
+can change the state of what's parsed in the current file.
+
+Note: Note implemented yet"
+ :group 'semantic
+ :type 'boolean)
+
+(defun semantic-lex-spp-merge-header (name)
+ "Extract and merge any macros from the header with NAME.
+Finds the header file belonging to NAME, gets the macros
+from that file, and then merge the macros with our current
+symbol table."
+ (when semantic-lex-spp-use-headers-flag
+ ;; @todo - do this someday, ok?
+ ))
+
+(defmacro define-lex-spp-include-analyzer (name doc regexp tokidx
+ &rest valform)
+ "Define a lexical analyzer for defining a new INCLUDE lexical token.
+Macros defined in the found include will be added to our running table
+at the time the include statement is found.
+NAME is the name of the analyzer.
+DOC is the documentation for the analyzer.
+REGEXP is a regular expression for the analyzer to match.
+See `define-lex-regex-analyzer' for more on regexp.
+TOKIDX is an index into REGEXP for which a new lexical token
+of type `spp-macro-include' is to be created.
+VALFORM are forms that return the name of the thing being included, and the
+type of include. The return value should be of the form:
+ (NAME . TYPE)
+where NAME is the name of the include, and TYPE is the type of the include,
+where a valid symbol is 'system, or nil."
+ (let ((start (make-symbol "start"))
+ (end (make-symbol "end"))
+ (val (make-symbol "val"))
+ (startpnt (make-symbol "startpnt"))
+ (endpnt (make-symbol "endpnt")))
+ `(define-lex-regex-analyzer ,name
+ ,doc
+ ,regexp
+ (let ((,start (match-beginning ,tokidx))
+ (,end (match-end ,tokidx))
+ (,startpnt semantic-lex-end-point)
+ (,val (save-match-data ,@valform))
+ (,endpnt semantic-lex-end-point))
+ ;;(message "(car ,val) -> %S" (car ,val))
+ (semantic-lex-spp-merge-header (car ,val))
+ (semantic-lex-push-token
+ (semantic-lex-token (if (eq (cdr ,val) 'system)
+ 'spp-system-include
+ 'spp-include)
+ ,start ,end
+ (car ,val)))
+ ;; Preserve setting of the end point from the calling macro.
+ (when (and (/= ,startpnt ,endpnt)
+ (/= ,endpnt semantic-lex-end-point))
+ (setq semantic-lex-end-point ,endpnt))
+ ))))
+
+;;; EIEIO USAGE
+;;
+;; Semanticdb can save off macro tables for quick lookup later.
+;;
+;; These routines are for saving macro lists into an EIEIO persistent
+;; file.
+(defvar semantic-lex-spp-macro-max-length-to-save 200
+ "*Maximum length of an SPP macro before we opt to not save it.")
+
+(defun semantic-lex-spp-table-write-slot-value (value)
+ "Write out the VALUE of a slot for EIEIO.
+The VALUE is a spp lexical table."
+ (if (not value)
+ (princ "nil")
+ (princ "\n '(")
+ ;(princ value)
+ (dolist (sym value)
+ (princ "(")
+ (prin1 (car sym))
+ (let* ((first (car (cdr sym)))
+ (rest (cdr sym)))
+ (when (not (listp first))
+ (error "Error in macro \"%s\"" (car sym)))
+ (when (eq (car first) 'spp-arg-list)
+ (princ " ")
+ (prin1 first)
+ (setq rest (cdr rest))
+ )
+
+ (when rest
+ (princ " . ")
+ (let ((len (length (cdr rest))))
+ (cond ((< len 2)
+ (condition-case nil
+ (prin1 rest)
+ (error
+ (princ "nil ;; Error writing macro\n"))))
+ ((< len semantic-lex-spp-macro-max-length-to-save)
+ (princ "\n ")
+ (condition-case nil
+ (prin1 rest)
+ (error
+ (princ "nil ;; Error writing macro\n ")))
+ )
+ (t ;; Too Long!
+ (princ "nil ;; Too Long!\n ")
+ ))))
+ )
+ (princ ")\n ")
+ )
+ (princ ")\n"))
+)
+
+;;; TESTS
+;;
+(defun semantic-lex-spp-write-test ()
+ "Test the semantic tag writer against the current buffer."
+ (interactive)
+ (with-output-to-temp-buffer "*SPP Write Test*"
+ (semantic-lex-spp-table-write-slot-value
+ (semantic-lex-spp-save-table))))
+
+(defun semantic-lex-spp-write-utest ()
+ "Unit test using the test spp file to test the slot write fcn."
+ (interactive)
+ (let* ((sem (locate-library "semantic-lex-spp.el"))
+ (dir (file-name-directory sem)))
+ (save-excursion
+ (set-buffer (find-file-noselect
+ (expand-file-name "tests/testsppreplace.c"
+ dir)))
+ (semantic-lex-spp-write-test))))
+
+;;; MACRO TABLE DEBUG
+;;
+(defun semantic-lex-spp-describe (&optional buffer)
+ "Describe the current list of spp macros for BUFFER.
+If BUFFER is not provided, use the current buffer."
+ (interactive)
+ (let ((syms (save-excursion
+ (if buffer (set-buffer buffer))
+ (semantic-lex-spp-macros)))
+ (sym nil))
+ (with-output-to-temp-buffer "*SPP MACROS*"
+ (princ "Macro\t\tValue\n")
+ (while syms
+ (setq sym (car syms)
+ syms (cdr syms))
+ (princ (symbol-name sym))
+ (princ "\t")
+ (if (< (length (symbol-name sym)) 8)
+ (princ "\t"))
+ (prin1 (symbol-value sym))
+ (princ "\n")
+ ))))
+
+;;; EDEBUG Handlers
+;;
+(add-hook
+ 'edebug-setup-hook
+ #'(lambda ()
+
+ (def-edebug-spec define-lex-spp-macro-declaration-analyzer
+ (&define name stringp stringp form def-body)
+ )
+
+ (def-edebug-spec define-lex-spp-macro-undeclaration-analyzer
+ (&define name stringp stringp form)
+ )
+
+ (def-edebug-spec define-lex-spp-include-analyzer
+ (&define name stringp stringp form def-body)
+ )
+ ))
+
+
+(provide 'semantic/lex-spp)
+
+;;; semantic-lex-spp.el ends here
--- /dev/null
+;;; semantic-util-modes.el --- Semantic minor modes
+
+;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
+;;; Free Software Foundation, Inc.
+
+;; Authors: Eric M. Ludlam <zappo@gnu.org>
+;; David Ponce <david@dponce.com>
+;; Keywords: syntax
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Semantic utility minor modes.
+;;
+
+;;; Code:
+(require 'semantic)
+
+(eval-when-compile
+ (require 'semantic/decorate)
+ )
+
+;;; Compatibility
+(if (fboundp 'propertize)
+ (defalias 'semantic-propertize 'propertize)
+ (defsubst semantic-propertize (string &rest properties)
+ "Return a copy of STRING with text properties added.
+Dummy implementation for compatibility which just return STRING and
+ignore PROPERTIES."
+ string)
+ )
+
+;;; Group for all semantic enhancing modes
+(defgroup semantic-modes nil
+ "Minor modes associated with the Semantic architecture."
+ :group 'semantic)
+
+;;;;
+;;;; Semantic minor modes stuff
+;;;;
+(defcustom semantic-update-mode-line t
+ "*If non-nil, show enabled minor modes in the mode line.
+Only minor modes that are not turned on globally are shown in the mode
+line."
+ :group 'semantic
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (set-default sym val)
+ ;; Update status of all Semantic enabled buffers
+ (semantic-map-buffers
+ #'semantic-mode-line-update)))
+
+(defcustom semantic-mode-line-prefix
+ (semantic-propertize "S" 'face 'bold)
+ "*Prefix added to minor mode indicators in the mode line."
+ :group 'semantic
+ :type 'string
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default)
+
+(defvar semantic-minor-modes-status nil
+ "String showing Semantic minor modes which are locally enabled.
+It is displayed in the mode line.")
+(make-variable-buffer-local 'semantic-minor-modes-status)
+
+(defvar semantic-minor-mode-alist nil
+ "Alist saying how to show Semantic minor modes in the mode line.
+Like variable `minor-mode-alist'.")
+
+(defun semantic-mode-line-update ()
+ "Update display of Semantic minor modes in the mode line.
+Only minor modes that are locally enabled are shown in the mode line."
+ (setq semantic-minor-modes-status nil)
+ (if semantic-update-mode-line
+ (let ((ml semantic-minor-mode-alist)
+ mm ms see)
+ (while ml
+ (setq mm (car ml)
+ ms (cadr mm)
+ mm (car mm)
+ ml (cdr ml))
+ (when (and (symbol-value mm)
+ ;; Only show local minor mode status
+ (not (memq mm semantic-init-hooks)))
+ (and ms
+ (symbolp ms)
+ (setq ms (symbol-value ms)))
+ (and (stringp ms)
+ (not (member ms see)) ;; Don't duplicate same status
+ (setq see (cons ms see)
+ ms (if (string-match "^[ ]*\\(.+\\)" ms)
+ (match-string 1 ms)))
+ (setq semantic-minor-modes-status
+ (if semantic-minor-modes-status
+ (concat semantic-minor-modes-status "/" ms)
+ ms)))))
+ (if semantic-minor-modes-status
+ (setq semantic-minor-modes-status
+ (concat
+ " "
+ (if (string-match "^[ ]*\\(.+\\)"
+ semantic-mode-line-prefix)
+ (match-string 1 semantic-mode-line-prefix)
+ "S")
+ "/"
+ semantic-minor-modes-status))))))
+
+(defun semantic-desktop-ignore-this-minor-mode (buffer)
+ "Installed as a minor-mode initializer for Desktop mode.
+BUFFER is the buffer to not initialize a Semantic minor mode in."
+ nil)
+
+(defun semantic-add-minor-mode (toggle name &optional keymap)
+ "Register a new Semantic minor mode.
+TOGGLE is a symbol which is the name of a buffer-local variable that
+is toggled on or off to say whether the minor mode is active or not.
+It is also an interactive function to toggle the mode.
+
+NAME specifies what will appear in the mode line when the minor mode
+is active. NAME should be either a string starting with a space, or a
+symbol whose value is such a string.
+
+Optional KEYMAP is the keymap for the minor mode that will be added to
+`minor-mode-map-alist'."
+ ;; Add a dymmy semantic minor mode to display the status
+ (or (assq 'semantic-minor-modes-status minor-mode-alist)
+ (setq minor-mode-alist (cons (list 'semantic-minor-modes-status
+ 'semantic-minor-modes-status)
+ minor-mode-alist)))
+ (if (fboundp 'add-minor-mode)
+ ;; Emacs 21 & XEmacs
+ (add-minor-mode toggle "" keymap)
+ ;; Emacs 20
+ (or (assq toggle minor-mode-alist)
+ (setq minor-mode-alist (cons (list toggle "") minor-mode-alist)))
+ (or (not keymap)
+ (assq toggle minor-mode-map-alist)
+ (setq minor-mode-map-alist (cons (cons toggle keymap)
+ minor-mode-map-alist))))
+ ;; Record how to display this minor mode in the mode line
+ (let ((mm (assq toggle semantic-minor-mode-alist)))
+ (if mm
+ (setcdr mm (list name))
+ (setq semantic-minor-mode-alist (cons (list toggle name)
+ semantic-minor-mode-alist))))
+
+ ;; Semantic minor modes don't work w/ Desktop restore.
+ ;; This line will disable this minor mode from being restored
+ ;; by Desktop.
+ (when (boundp 'desktop-minor-mode-handlers)
+ (add-to-list 'desktop-minor-mode-handlers
+ (cons toggle 'semantic-desktop-ignore-this-minor-mode)))
+ )
+
+(defun semantic-toggle-minor-mode-globally (mode &optional arg)
+ "Toggle minor mode MODE in every Semantic enabled buffer.
+Return non-nil if MODE is turned on in every Semantic enabled buffer.
+If ARG is positive, enable, if it is negative, disable. If ARG is
+nil, then toggle. Otherwise do nothing. MODE must be a valid minor
+mode defined in `minor-mode-alist' and must be too an interactive
+function used to toggle the mode."
+ (or (and (fboundp mode) (assq mode minor-mode-alist))
+ (error "Semantic minor mode %s not found" mode))
+ (if (not arg)
+ (if (memq mode semantic-init-hooks)
+ (setq arg -1)
+ (setq arg 1)))
+ ;; Add or remove the MODE toggle function from
+ ;; `semantic-init-hooks'. Then turn MODE on or off in every
+ ;; Semantic enabled buffer.
+ (cond
+ ;; Turn off if ARG < 0
+ ((< arg 0)
+ (remove-hook 'semantic-init-hooks mode)
+ (semantic-map-buffers #'(lambda () (funcall mode -1)))
+ nil)
+ ;; Turn on if ARG > 0
+ ((> arg 0)
+ (add-hook 'semantic-init-hooks mode)
+ (semantic-map-buffers #'(lambda () (funcall mode 1)))
+ t)
+ ;; Otherwise just check MODE state
+ (t
+ (memq mode semantic-init-hooks))
+ ))
+\f
+;;;;
+;;;; Minor mode to highlight areas that a user edits.
+;;;;
+
+(defun global-semantic-highlight-edits-mode (&optional arg)
+ "Toggle global use of option `semantic-highlight-edits-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-highlight-edits-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-highlight-edits-mode arg)))
+
+(defcustom global-semantic-highlight-edits-mode nil
+ "*If non-nil enable global use of variable `semantic-highlight-edits-mode'.
+When this mode is enabled, changes made to a buffer are highlighted
+until the buffer is reparsed."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-highlight-edits-mode (if val 1 -1))))
+
+(defcustom semantic-highlight-edits-mode-hook nil
+ "*Hook run at the end of function `semantic-highlight-edits-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defface semantic-highlight-edits-face
+ '((((class color) (background dark))
+ ;; Put this back to something closer to black later.
+ (:background "gray20"))
+ (((class color) (background light))
+ (:background "gray90")))
+ "*Face used to show dirty tokens in `semantic-highlight-edits-mode'."
+ :group 'semantic-faces)
+
+(defun semantic-highlight-edits-new-change-hook-fcn (overlay)
+ "Function set into `semantic-edits-new-change-hook'.
+Argument OVERLAY is the overlay created to mark the change.
+This function will set the face property on this overlay."
+ (semantic-overlay-put overlay 'face 'semantic-highlight-edits-face))
+
+(defvar semantic-highlight-edits-mode-map
+ (let ((km (make-sparse-keymap)))
+ km)
+ "Keymap for highlight-edits minor mode.")
+
+(defvar semantic-highlight-edits-mode nil
+ "Non-nil if highlight-edits minor mode is enabled.
+Use the command `semantic-highlight-edits-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-highlight-edits-mode)
+
+(defun semantic-highlight-edits-mode-setup ()
+ "Setup option `semantic-highlight-edits-mode'.
+The minor mode can be turned on only if semantic feature is available
+and the current buffer was set up for parsing. When minor mode is
+enabled parse the current buffer if needed. Return non-nil if the
+minor mode is enabled."
+ (if semantic-highlight-edits-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-highlight-edits-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ (semantic-make-local-hook 'semantic-edits-new-change-hooks)
+ (add-hook 'semantic-edits-new-change-hooks
+ 'semantic-highlight-edits-new-change-hook-fcn nil t)
+ )
+ ;; Remove hooks
+ (remove-hook 'semantic-edits-new-change-hooks
+ 'semantic-highlight-edits-new-change-hook-fcn t)
+ )
+ semantic-highlight-edits-mode)
+
+(defun semantic-highlight-edits-mode (&optional arg)
+ "Minor mode for highlighting changes made in a buffer.
+Changes are tracked by semantic so that the incremental parser can work
+properly.
+This mode will highlight those changes as they are made, and clear them
+when the incremental parser accounts for those edits.
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-highlight-edits-mode 0 1))))
+ (setq semantic-highlight-edits-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-highlight-edits-mode)))
+ (semantic-highlight-edits-mode-setup)
+ (run-hooks 'semantic-highlight-edits-mode-hook)
+ (if (interactive-p)
+ (message "highlight-edits minor mode %sabled"
+ (if semantic-highlight-edits-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-highlight-edits-mode)
+
+(semantic-add-minor-mode 'semantic-highlight-edits-mode
+ "e"
+ semantic-highlight-edits-mode-map)
+
+\f
+;;;;
+;;;; Minor mode to show unmatched-syntax elements
+;;;;
+(defun global-semantic-show-unmatched-syntax-mode (&optional arg)
+ "Toggle global use of option `semantic-show-unmatched-syntax-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-show-unmatched-syntax-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-show-unmatched-syntax-mode arg)))
+
+(defcustom global-semantic-show-unmatched-syntax-mode nil
+ "*If non-nil, enable global use of `semantic-show-unmatched-syntax-mode'.
+When this mode is enabled, syntax in the current buffer which the
+semantic parser cannot match is highlighted with a red underline."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-show-unmatched-syntax-mode (if val 1 -1))))
+
+(defcustom semantic-show-unmatched-syntax-mode-hook nil
+ "*Hook run at the end of function `semantic-show-unmatched-syntax-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defface semantic-unmatched-syntax-face
+ '((((class color) (background dark))
+ (:underline "red"))
+ (((class color) (background light))
+ (:underline "red")))
+ "*Face used to show unmatched syntax in.
+The face is used in `semantic-show-unmatched-syntax-mode'."
+ :group 'semantic-faces)
+
+(defsubst semantic-unmatched-syntax-overlay-p (overlay)
+ "Return non-nil if OVERLAY is an unmatched syntax one."
+ (eq (semantic-overlay-get overlay 'semantic) 'unmatched))
+
+(defun semantic-showing-unmatched-syntax-p ()
+ "Return non-nil if an unmatched syntax overlay was found in buffer."
+ (let ((ol (semantic-overlays-in (point-min) (point-max)))
+ found)
+ (while (and ol (not found))
+ (setq found (semantic-unmatched-syntax-overlay-p (car ol))
+ ol (cdr ol)))
+ found))
+
+(defun semantic-show-unmatched-lex-tokens-fetch ()
+ "Fetch a list of unmatched lexical tokens from the current buffer.
+Uses the overlays which have accurate bounds, and rebuilds what was
+originally passed in."
+ (let ((ol (semantic-overlays-in (point-min) (point-max)))
+ (ustc nil))
+ (while ol
+ (if (semantic-unmatched-syntax-overlay-p (car ol))
+ (setq ustc (cons (cons 'thing
+ (cons (semantic-overlay-start (car ol))
+ (semantic-overlay-end (car ol))))
+ ustc)))
+ (setq ol (cdr ol)))
+ (nreverse ustc))
+ )
+
+(defun semantic-clean-unmatched-syntax-in-region (beg end)
+ "Remove all unmatched syntax overlays between BEG and END."
+ (let ((ol (semantic-overlays-in beg end)))
+ (while ol
+ (if (semantic-unmatched-syntax-overlay-p (car ol))
+ (semantic-overlay-delete (car ol)))
+ (setq ol (cdr ol)))))
+
+(defsubst semantic-clean-unmatched-syntax-in-buffer ()
+ "Remove all unmatched syntax overlays found in current buffer."
+ (semantic-clean-unmatched-syntax-in-region
+ (point-min) (point-max)))
+
+(defsubst semantic-clean-token-of-unmatched-syntax (token)
+ "Clean the area covered by TOKEN of unmatched syntax markers."
+ (semantic-clean-unmatched-syntax-in-region
+ (semantic-tag-start token) (semantic-tag-end token)))
+
+(defun semantic-show-unmatched-syntax (syntax)
+ "Function set into `semantic-unmatched-syntax-hook'.
+This will highlight elements in SYNTAX as unmatched syntax."
+ ;; This is called when `semantic-show-unmatched-syntax-mode' is
+ ;; enabled. Highlight the unmatched syntax, and then add a semantic
+ ;; property to that overlay so we can add it to the official list of
+ ;; semantic supported overlays. This gets it cleaned up for errors,
+ ;; buffer cleaning, and the like.
+ (semantic-clean-unmatched-syntax-in-buffer) ;Clear previous highlighting
+ (if syntax
+ (let (o)
+ (while syntax
+ (setq o (semantic-make-overlay (semantic-lex-token-start (car syntax))
+ (semantic-lex-token-end (car syntax))))
+ (semantic-overlay-put o 'semantic 'unmatched)
+ (semantic-overlay-put o 'face 'semantic-unmatched-syntax-face)
+ (setq syntax (cdr syntax))))
+ ))
+
+(defun semantic-next-unmatched-syntax (point &optional bound)
+ "Find the next overlay for unmatched syntax after POINT.
+Do not search past BOUND if non-nil."
+ (save-excursion
+ (goto-char point)
+ (let ((os point) (ol nil))
+ (while (and os (< os (or bound (point-max))) (not ol))
+ (setq os (semantic-overlay-next-change os))
+ (when os
+ ;; Get overlays at position
+ (setq ol (semantic-overlays-at os))
+ ;; find the overlay that belongs to semantic
+ ;; and starts at the found position.
+ (while (and ol (listp ol))
+ (and (semantic-unmatched-syntax-overlay-p (car ol))
+ (setq ol (car ol)))
+ (if (listp ol)
+ (setq ol (cdr ol))))))
+ ol)))
+
+(defvar semantic-show-unmatched-syntax-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "\C-c,`" 'semantic-show-unmatched-syntax-next)
+ km)
+ "Keymap for command `semantic-show-unmatched-syntax-mode'.")
+
+(defvar semantic-show-unmatched-syntax-mode nil
+ "Non-nil if show-unmatched-syntax minor mode is enabled.
+Use the command `semantic-show-unmatched-syntax-mode' to change this
+variable.")
+(make-variable-buffer-local 'semantic-show-unmatched-syntax-mode)
+
+(defun semantic-show-unmatched-syntax-mode-setup ()
+ "Setup the `semantic-show-unmatched-syntax' minor mode.
+The minor mode can be turned on only if semantic feature is available
+and the current buffer was set up for parsing. When minor mode is
+enabled parse the current buffer if needed. Return non-nil if the
+minor mode is enabled."
+ (if semantic-show-unmatched-syntax-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-show-unmatched-syntax-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ ;; Add hooks
+ (semantic-make-local-hook 'semantic-unmatched-syntax-hook)
+ (add-hook 'semantic-unmatched-syntax-hook
+ 'semantic-show-unmatched-syntax nil t)
+ (semantic-make-local-hook 'semantic-pre-clean-token-hooks)
+ (add-hook 'semantic-pre-clean-token-hooks
+ 'semantic-clean-token-of-unmatched-syntax nil t)
+ ;; Show unmatched syntax elements
+ (if (not (semantic--umatched-syntax-needs-refresh-p))
+ (semantic-show-unmatched-syntax
+ (semantic-unmatched-syntax-tokens))))
+ ;; Remove hooks
+ (remove-hook 'semantic-unmatched-syntax-hook
+ 'semantic-show-unmatched-syntax t)
+ (remove-hook 'semantic-pre-clean-token-hooks
+ 'semantic-clean-token-of-unmatched-syntax t)
+ ;; Cleanup unmatched-syntax highlighting
+ (semantic-clean-unmatched-syntax-in-buffer))
+ semantic-show-unmatched-syntax-mode)
+
+(defun semantic-show-unmatched-syntax-mode (&optional arg)
+ "Minor mode to highlight unmatched lexical syntax tokens.
+When a parser executes, some elements in the buffer may not match any
+parser rules. These text characters are considered unmatched syntax.
+Often time, the display of unmatched syntax can expose coding
+problems before the compiler is run.
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled.
+
+\\{semantic-show-unmatched-syntax-mode-map}"
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-show-unmatched-syntax-mode 0 1))))
+ (setq semantic-show-unmatched-syntax-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-show-unmatched-syntax-mode)))
+ (semantic-show-unmatched-syntax-mode-setup)
+ (run-hooks 'semantic-show-unmatched-syntax-mode-hook)
+ (if (interactive-p)
+ (message "show-unmatched-syntax minor mode %sabled"
+ (if semantic-show-unmatched-syntax-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-show-unmatched-syntax-mode)
+
+(semantic-add-minor-mode 'semantic-show-unmatched-syntax-mode
+ "u"
+ semantic-show-unmatched-syntax-mode-map)
+
+(defun semantic-show-unmatched-syntax-next ()
+ "Move forward to the next occurrence of unmatched syntax."
+ (interactive)
+ (let ((o (semantic-next-unmatched-syntax (point))))
+ (if o
+ (goto-char (semantic-overlay-start o)))))
+
+\f
+;;;;
+;;;; Minor mode to display the parser state in the modeline.
+;;;;
+
+(defcustom global-semantic-show-parser-state-mode nil
+ "*If non-nil enable global use of `semantic-show-parser-state-mode'.
+When enabled, the current parse state of the current buffer is displayed
+in the mode line. See `semantic-show-parser-state-marker' for details
+on what is displayed."
+ :group 'semantic
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-show-parser-state-mode (if val 1 -1))))
+
+(defun global-semantic-show-parser-state-mode (&optional arg)
+ "Toggle global use of option `semantic-show-parser-state-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-show-parser-state-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-show-parser-state-mode arg)))
+
+(defcustom semantic-show-parser-state-mode-hook nil
+ "*Hook run at the end of function `semantic-show-parser-state-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defvar semantic-show-parser-state-mode-map
+ (let ((km (make-sparse-keymap)))
+ km)
+ "Keymap for show-parser-state minor mode.")
+
+(defvar semantic-show-parser-state-mode nil
+ "Non-nil if show-parser-state minor mode is enabled.
+Use the command `semantic-show-parser-state-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-show-parser-state-mode)
+
+(defun semantic-show-parser-state-mode-setup ()
+ "Setup option `semantic-show-parser-state-mode'.
+The minor mode can be turned on only if semantic feature is available
+and the current buffer was set up for parsing. When minor mode is
+enabled parse the current buffer if needed. Return non-nil if the
+minor mode is enabled."
+ (if semantic-show-parser-state-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-show-parser-state-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ ;; Set up mode line
+
+ (when (not
+ (memq 'semantic-show-parser-state-string mode-line-modified))
+ (setq mode-line-modified
+ (append mode-line-modified
+ '(semantic-show-parser-state-string))))
+ ;; Add hooks
+ (semantic-make-local-hook 'semantic-edits-new-change-hooks)
+ (add-hook 'semantic-edits-new-change-hooks
+ 'semantic-show-parser-state-marker nil t)
+ (semantic-make-local-hook 'semantic-edits-incremental-reparse-failed-hooks)
+ (add-hook 'semantic-edits-incremental-reparse-failed-hooks
+ 'semantic-show-parser-state-marker nil t)
+ (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
+ (add-hook 'semantic-after-partial-cache-change-hook
+ 'semantic-show-parser-state-marker nil t)
+ (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
+ (add-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-show-parser-state-marker nil t)
+ (semantic-show-parser-state-marker)
+
+ (semantic-make-local-hook 'semantic-before-auto-parse-hooks)
+ (add-hook 'semantic-before-auto-parse-hooks
+ 'semantic-show-parser-state-auto-marker nil t)
+ (semantic-make-local-hook 'semantic-after-auto-parse-hooks)
+ (add-hook 'semantic-after-auto-parse-hooks
+ 'semantic-show-parser-state-marker nil t)
+
+ (semantic-make-local-hook 'semantic-before-idle-scheduler-reparse-hooks)
+ (add-hook 'semantic-before-idle-scheduler-reparse-hooks
+ 'semantic-show-parser-state-auto-marker nil t)
+ (semantic-make-local-hook 'semantic-after-idle-scheduler-reparse-hooks)
+ (add-hook 'semantic-after-idle-scheduler-reparse-hooks
+ 'semantic-show-parser-state-marker nil t)
+ )
+ ;; Remove parts of mode line
+ (setq mode-line-modified
+ (delq 'semantic-show-parser-state-string mode-line-modified))
+ ;; Remove hooks
+ (remove-hook 'semantic-edits-new-change-hooks
+ 'semantic-show-parser-state-marker t)
+ (remove-hook 'semantic-edits-incremental-reparse-failed-hooks
+ 'semantic-show-parser-state-marker t)
+ (remove-hook 'semantic-after-partial-cache-change-hook
+ 'semantic-show-parser-state-marker t)
+ (remove-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-show-parser-state-marker t)
+
+ (remove-hook 'semantic-before-auto-parse-hooks
+ 'semantic-show-parser-state-auto-marker t)
+ (remove-hook 'semantic-after-auto-parse-hooks
+ 'semantic-show-parser-state-marker t)
+
+ (remove-hook 'semantic-before-idle-scheduler-reparse-hooks
+ 'semantic-show-parser-state-auto-marker t)
+ (remove-hook 'semantic-after-idle-scheduler-reparse-hooks
+ 'semantic-show-parser-state-marker t)
+ )
+ semantic-show-parser-state-mode)
+
+(defun semantic-show-parser-state-mode (&optional arg)
+ "Minor mode for displaying parser cache state in the modeline.
+The cache can be in one of three states. They are
+Up to date, Partial reprase needed, and Full reparse needed.
+The state is indicated in the modeline with the following characters:
+ `-' -> The cache is up to date.
+ `!' -> The cache requires a full update.
+ `~' -> The cache needs to be incrementally parsed.
+ `%' -> The cache is not currently parseable.
+ `@' -> Auto-parse in progress (not set here.)
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-show-parser-state-mode 0 1))))
+ (setq semantic-show-parser-state-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-show-parser-state-mode)))
+ (semantic-show-parser-state-mode-setup)
+ (run-hooks 'semantic-show-parser-state-mode-hook)
+ (if (interactive-p)
+ (message "show-parser-state minor mode %sabled"
+ (if semantic-show-parser-state-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-show-parser-state-mode)
+
+(semantic-add-minor-mode 'semantic-show-parser-state-mode
+ ""
+ semantic-show-parser-state-mode-map)
+
+(defvar semantic-show-parser-state-string nil
+ "String showing the parser state for this buffer.
+See `semantic-show-parser-state-marker' for details.")
+(make-variable-buffer-local 'semantic-show-parser-state-string)
+
+(defun semantic-show-parser-state-marker (&rest ignore)
+ "Set `semantic-show-parser-state-string' to indicate parser state.
+This marker is one of the following:
+ `-' -> The cache is up to date.
+ `!' -> The cache requires a full update.
+ `~' -> The cache needs to be incrementally parsed.
+ `%' -> The cache is not currently parseable.
+ `@' -> Auto-parse in progress (not set here.)
+Arguments IGNORE are ignored, and accepted so this can be used as a hook
+in many situations."
+ (setq semantic-show-parser-state-string
+ (cond ((semantic-parse-tree-needs-rebuild-p)
+ "!")
+ ((semantic-parse-tree-needs-update-p)
+ "^")
+ ((semantic-parse-tree-unparseable-p)
+ "%")
+ (t
+ "-")))
+ ;;(message "Setup mode line indicator to [%s]" semantic-show-parser-state-string)
+ (semantic-mode-line-update))
+
+(defun semantic-show-parser-state-auto-marker ()
+ "Hook function run before an autoparse.
+Set up `semantic-show-parser-state-marker' to show `@'
+to indicate a parse in progress."
+ (unless (semantic-parse-tree-up-to-date-p)
+ (setq semantic-show-parser-state-string "@")
+ (semantic-mode-line-update)
+ ;; For testing.
+ ;;(sit-for 1)
+ ))
+
+\f
+;;;;
+;;;; Minor mode to make function decls sticky.
+;;;;
+
+(defun global-semantic-stickyfunc-mode (&optional arg)
+ "Toggle global use of option `semantic-stickyfunc-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-stickyfunc-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-stickyfunc-mode arg)))
+
+(defcustom global-semantic-stickyfunc-mode nil
+ "*If non-nil, enable global use of `semantic-stickyfunc-mode'.
+This minor mode only works for Emacs 21 or later.
+When enabled, the header line is enabled, and the first line
+of the current function or method is displayed in it.
+This makes it appear that the first line of that tag is
+`sticky' to the top of the window."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-stickyfunc-mode (if val 1 -1))))
+
+(defcustom semantic-stickyfunc-mode-hook nil
+ "*Hook run at the end of function `semantic-stickyfunc-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defvar semantic-stickyfunc-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km [ header-line down-mouse-1 ] 'semantic-stickyfunc-menu)
+ km)
+ "Keymap for stickyfunc minor mode.")
+
+(defvar semantic-stickyfunc-popup-menu nil
+ "Menu used if the user clicks on the header line used by stickyfunc mode.")
+
+(easy-menu-define
+ semantic-stickyfunc-popup-menu
+ semantic-stickyfunc-mode-map
+ "Stickyfunc Menu"
+ '("Stickyfunc Mode" :visible (progn nil)
+ [ "Copy Headerline Tag" senator-copy-tag
+ :active (semantic-current-tag)
+ :help "Copy the current tag to the tag ring"]
+ [ "Kill Headerline Tag" senator-kill-tag
+ :active (semantic-current-tag)
+ :help "Kill tag text to the kill ring, and copy the tag to the tag ring"
+ ]
+ [ "Copy Headerline Tag to Register" senator-copy-tag-to-register
+ :active (semantic-current-tag)
+ :help "Copy the current tag to a register"
+ ]
+ [ "Narrow To Headerline Tag" senator-narrow-to-defun
+ :active (semantic-current-tag)
+ :help "Narrow to the bounds of the current tag."]
+ [ "Fold Headerline Tag" senator-fold-tag-toggle
+ :active (semantic-current-tag)
+ :style toggle
+ :selected (let ((tag (semantic-current-tag)))
+ (and tag (semantic-tag-folded-p tag)))
+ :help "Fold the current tag to one line"
+ ]
+ "---"
+ [ "About This Header Line"
+ (lambda () (interactive)
+ (describe-function 'semantic-stickyfunc-mode)) t])
+ )
+
+(defvar semantic-stickyfunc-mode nil
+ "Non-nil if stickyfunc minor mode is enabled.
+Use the command `semantic-stickyfunc-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-stickyfunc-mode)
+
+(defcustom semantic-stickyfunc-indent-string
+ (if (and window-system (not (featurep 'xemacs)))
+ (concat
+ (condition-case nil
+ ;; Test scroll bar location
+ (let ((charwidth (frame-char-width))
+ (scrollpos (frame-parameter (selected-frame)
+ 'vertical-scroll-bars))
+ )
+ (if (or (eq scrollpos 'left)
+ ;; Now wait a minute. If you turn scroll-bar-mode
+ ;; on, then off, the new value is t, not left.
+ ;; Will this mess up older emacs where the default
+ ;; was on the right? I don't think so since they don't
+ ;; support a header line.
+ (eq scrollpos t))
+ (let ((w (when (boundp 'scroll-bar-width)
+ (symbol-value 'scroll-bar-width))))
+
+ (if (not w)
+ (setq w (frame-parameter (selected-frame)
+ 'scroll-bar-width)))
+
+ ;; in 21.2, the frame parameter is sometimes empty
+ ;; so we need to get the value here.
+ (if (not w)
+ (setq w (+ (get 'scroll-bar-width 'x-frame-parameter)
+ ;; In 21.4, or perhaps 22.1 the x-frame
+ ;; parameter is different from the frame
+ ;; parameter by only 1 pixel.
+ 1)))
+
+ (if (not w)
+ " "
+ (setq w (+ 2 w)) ; Some sort of border around
+ ; the scrollbar.
+ (make-string (/ w charwidth) ? )))
+ ""))
+ (error ""))
+ (condition-case nil
+ ;; Test fringe size.
+ (let* ((f (window-fringes))
+ (fw (car f))
+ (numspace (/ fw (frame-char-width)))
+ )
+ (make-string numspace ? ))
+ (error
+ ;; Well, the fancy new Emacs functions failed. Try older
+ ;; tricks.
+ (condition-case nil
+ ;; I'm not so sure what's up with the 21.1-21.3 fringe.
+ ;; It looks to be about 1 space wide.
+ (if (get 'fringe 'face)
+ " "
+ "")
+ (error ""))))
+ )
+ ;; Not Emacs or a window system means no scrollbar or fringe,
+ ;; and perhaps not even a header line to worry about.
+ "")
+ "*String used to indent the stickyfunc header.
+Customize this string to match the space used by scrollbars and
+fringe so it does not appear that the code is moving left/right
+when it lands in the sticky line."
+ :group 'semantic
+ :type 'string)
+
+(defvar semantic-stickyfunc-old-hlf nil
+ "Value of the header line when entering sticky func mode.")
+
+(defconst semantic-stickyfunc-header-line-format
+ (cond ((featurep 'xemacs)
+ nil)
+ ((>= emacs-major-version 22)
+ '(:eval (list
+ ;; Magic bit I found on emacswiki.
+ (propertize " " 'display '((space :align-to 0)))
+ (semantic-stickyfunc-fetch-stickyline))))
+ ((= emacs-major-version 21)
+ '(:eval (list semantic-stickyfunc-indent-string
+ (semantic-stickyfunc-fetch-stickyline))))
+ (t nil))
+ "The header line format used by sticky func mode.")
+
+(defun semantic-stickyfunc-mode-setup ()
+ "Setup option `semantic-stickyfunc-mode'.
+For semantic enabled buffers, make the function declaration for the top most
+function \"sticky\". This is accomplished by putting the first line of
+text for that function in Emacs 21's header line."
+ (if semantic-stickyfunc-mode
+ (progn
+ (unless (and (featurep 'semantic) (semantic-active-p))
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-stickyfunc-mode nil)
+ (error "Buffer %s was not set up for parsing" (buffer-name)))
+ (unless (boundp 'default-header-line-format)
+ ;; Disable if there are no header lines to use.
+ (setq semantic-stickyfunc-mode nil)
+ (error "Sticky Function mode requires Emacs 21"))
+ ;; Enable the mode
+ ;; Save previous buffer local value of header line format.
+ (when (and (local-variable-p 'header-line-format (current-buffer))
+ (not (eq header-line-format
+ semantic-stickyfunc-header-line-format)))
+ (set (make-local-variable 'semantic-stickyfunc-old-hlf)
+ header-line-format))
+ (setq header-line-format semantic-stickyfunc-header-line-format)
+ )
+ ;; Disable sticky func mode
+ ;; Restore previous buffer local value of header line format if
+ ;; the current one is the sticky func one.
+ (when (eq header-line-format semantic-stickyfunc-header-line-format)
+ (kill-local-variable 'header-line-format)
+ (when (local-variable-p 'semantic-stickyfunc-old-hlf (current-buffer))
+ (setq header-line-format semantic-stickyfunc-old-hlf)
+ (kill-local-variable 'semantic-stickyfunc-old-hlf))))
+ semantic-stickyfunc-mode)
+
+(defun semantic-stickyfunc-mode (&optional arg)
+ "Minor mode to show the title of a tag in the header line.
+Enables/disables making the header line of functions sticky.
+A function (or other tag class specified by
+`semantic-stickyfunc-sticky-classes') has a header line, meaning the
+first line which describes the rest of the construct. This first
+line is what is displayed in the Emacs 21 header line.
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-stickyfunc-mode 0 1))))
+ (setq semantic-stickyfunc-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-stickyfunc-mode)))
+ (semantic-stickyfunc-mode-setup)
+ (run-hooks 'semantic-stickyfunc-mode-hook)
+ (if (interactive-p)
+ (message "Stickyfunc minor mode %sabled"
+ (if semantic-stickyfunc-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-stickyfunc-mode)
+
+(defvar semantic-stickyfunc-sticky-classes
+ '(function type)
+ "List of tag classes which sticky func will display in the header line.")
+(make-variable-buffer-local 'semantic-stickyfunc-sticky-classes)
+
+(defun semantic-stickyfunc-tag-to-stick ()
+ "Return the tag to stick at the current point."
+ (let ((tags (nreverse (semantic-find-tag-by-overlay (point)))))
+ ;; Get rid of non-matching tags.
+ (while (and tags
+ (not (member
+ (semantic-tag-class (car tags))
+ semantic-stickyfunc-sticky-classes))
+ )
+ (setq tags (cdr tags)))
+ (car tags)))
+
+(defun semantic-stickyfunc-fetch-stickyline ()
+ "Make the function at the top of the current window sticky.
+Capture it's function declaration, and place it in the header line.
+If there is no function, disable the header line."
+ (let ((str
+ (save-excursion
+ (goto-char (window-start (selected-window)))
+ (forward-line -1)
+ (end-of-line)
+ ;; Capture this function
+ (let* ((tag (semantic-stickyfunc-tag-to-stick)))
+ ;; TAG is nil if there was nothing of the apropriate type there.
+ (if (not tag)
+ ;; Set it to be the text under the header line
+ (buffer-substring (point-at-bol) (point-at-eol))
+ ;; Get it
+ (goto-char (semantic-tag-start tag))
+ ;; Klaus Berndl <klaus.berndl@sdm.de>:
+ ;; goto the tag name; this is especially needed for languages
+ ;; like c++ where a often used style is like:
+ ;; void
+ ;; ClassX::methodM(arg1...)
+ ;; {
+ ;; ...
+ ;; }
+ ;; Without going to the tag-name we would get"void" in the
+ ;; header line which is IMHO not really useful
+ (search-forward (semantic-tag-name tag) nil t)
+ (buffer-substring (point-at-bol) (point-at-eol))
+ ))))
+ (start 0))
+ (while (string-match "%" str start)
+ (setq str (replace-match "%%" t t str 0)
+ start (1+ (match-end 0)))
+ )
+ ;; In 21.4 (or 22.1) the heder doesn't expand tabs. Hmmmm.
+ ;; We should replace them here.
+ ;;
+ ;; This hack assumes that tabs are kept smartly at tab boundaries
+ ;; instead of in a tab boundary where it might only represent 4 spaces.
+ (while (string-match "\t" str start)
+ (setq str (replace-match " " t t str 0)))
+ str))
+
+(defun semantic-stickyfunc-menu (event)
+ "Popup a menu that can help a user understand stickyfunc-mode.
+Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ (win (car (car (cdr event))))
+ )
+ (select-window win t)
+ (save-excursion
+ (goto-char (window-start win))
+ (sit-for 0)
+ (popup-menu semantic-stickyfunc-popup-menu event)
+ )
+ (select-window startwin)))
+
+
+(semantic-add-minor-mode 'semantic-stickyfunc-mode
+ "" ;; Don't need indicator. It's quite visible
+ semantic-stickyfunc-mode-map)
+
+
+\f
+;;;;
+;;;; Minor mode to make highlight the current function
+;;;;
+
+;; Highlight the first like of the function we are in if it is different
+;; from the the tag going off the top of the screen.
+(defun global-semantic-highlight-func-mode (&optional arg)
+ "Toggle global use of option `semantic-highlight-func-mode'.
+If ARG is positive, enable, if it is negative, disable.
+If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-highlight-func-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-highlight-func-mode arg)))
+
+(defcustom global-semantic-highlight-func-mode nil
+ "*If non-nil, enable global use of `semantic-highlight-func-mode'.
+When enabled, the first line of the current tag is highlighted."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/util-modes
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-highlight-func-mode (if val 1 -1))))
+
+(defcustom semantic-highlight-func-mode-hook nil
+ "*Hook run at the end of function `semantic-highlight-func-mode'."
+ :group 'semantic
+ :type 'hook)
+
+(defvar semantic-highlight-func-mode-map
+ (let ((km (make-sparse-keymap))
+ (m3 (if (featurep 'xemacs) [ button3 ] [ mouse-3 ]))
+ )
+ (define-key km m3 'semantic-highlight-func-menu)
+ km)
+ "Keymap for highlight-func minor mode.")
+
+(defvar semantic-highlight-func-popup-menu nil
+ "Menu used if the user clicks on the header line used by `semantic-highlight-func-mode'.")
+
+(easy-menu-define
+ semantic-highlight-func-popup-menu
+ semantic-highlight-func-mode-map
+ "Highlight-Func Menu"
+ '("Highlight-Func Mode" :visible (progn nil)
+ [ "Copy Tag" senator-copy-tag
+ :active (semantic-current-tag)
+ :help "Copy the current tag to the tag ring"]
+ [ "Kill Tag" senator-kill-tag
+ :active (semantic-current-tag)
+ :help "Kill tag text to the kill ring, and copy the tag to the tag ring"
+ ]
+ [ "Copy Tag to Register" senator-copy-tag-to-register
+ :active (semantic-current-tag)
+ :help "Copy the current tag to a register"
+ ]
+ [ "Narrow To Tag" senator-narrow-to-defun
+ :active (semantic-current-tag)
+ :help "Narrow to the bounds of the current tag."]
+ [ "Fold Tag" senator-fold-tag-toggle
+ :active (semantic-current-tag)
+ :style toggle
+ :selected (let ((tag (semantic-stickyfunc-tag-to-stick)))
+ (and tag (semantic-tag-folded-p tag)))
+ :help "Fold the current tag to one line"
+ ]
+ "---"
+ [ "About This Tag" semantic-describe-tag t])
+ )
+
+(defun semantic-highlight-func-menu (event)
+ "Popup a menu that displays things to do to the current tag.
+Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ (win (semantic-event-window event))
+ )
+ (select-window win t)
+ (save-excursion
+ ;(goto-char (window-start win))
+ (mouse-set-point event)
+ (sit-for 0)
+ (semantic-popup-menu semantic-highlight-func-popup-menu)
+ )
+ (select-window startwin)))
+
+(defvar semantic-highlight-func-mode nil
+ "Non-nil if highlight-func minor mode is enabled.
+Use the command `semantic-highlight-func-mode' to change this variable.")
+(make-variable-buffer-local 'semantic-highlight-func-mode)
+
+(defvar semantic-highlight-func-ct-overlay nil
+ "Overlay used to highlight the tag the cursor is in.")
+(make-variable-buffer-local 'semantic-highlight-func-ct-overlay)
+
+(defface semantic-highlight-func-current-tag-face
+ '((((class color) (background dark))
+ ;; Put this back to something closer to black later.
+ (:background "gray20"))
+ (((class color) (background light))
+ (:background "gray90")))
+ "Face used to show the top of current function."
+ :group 'semantic-faces)
+
+
+(defun semantic-highlight-func-mode-setup ()
+ "Setup option `semantic-highlight-func-mode'.
+For semantic enabled buffers, highlight the first line of the
+current tag declaration."
+ (if semantic-highlight-func-mode
+ (progn
+ (unless (and (featurep 'semantic) (semantic-active-p))
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-highlight-func-mode nil)
+ (error "Buffer %s was not set up for parsing" (buffer-name)))
+ ;; Setup our hook
+ (add-hook 'post-command-hook 'semantic-highlight-func-highlight-current-tag nil t)
+ )
+ ;; Disable highlight func mode
+ (remove-hook 'post-command-hook 'semantic-highlight-func-highlight-current-tag t)
+ (semantic-highlight-func-highlight-current-tag t)
+ )
+ semantic-highlight-func-mode)
+
+(defun semantic-highlight-func-mode (&optional arg)
+ "Minor mode to highlight the first line of the current tag.
+Enables/disables making the header line of functions sticky.
+A function (or other tag class specified by
+`semantic-stickfunc-sticky-classes') is highlighted, meaning the
+first line which describes the rest of the construct.
+
+See `semantic-stickfunc-mode' for putting a function in the
+header line. This mode recycles the stickyfunc configuration
+classes list.
+
+With prefix argument ARG, turn on if positive, otherwise off. The
+minor mode can be turned on only if semantic feature is available and
+the current buffer was set up for parsing. Return non-nil if the
+minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-highlight-func-mode 0 1))))
+ (setq semantic-highlight-func-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-highlight-func-mode)))
+ (semantic-highlight-func-mode-setup)
+ (run-hooks 'semantic-highlight-func-mode-hook)
+ (if (interactive-p)
+ (message "Highlight-Func minor mode %sabled"
+ (if semantic-highlight-func-mode "en" "dis")))
+ semantic-highlight-func-mode)
+
+(defun semantic-highlight-func-highlight-current-tag (&optional disable)
+ "Highlight the current tag under point.
+Optional argument DISABLE will turn off any active highlight.
+If the current tag for this buffer is different from the last time this
+function was called, move the overlay."
+ (when (and (not (minibufferp))
+ (or (not semantic-highlight-func-ct-overlay)
+ (eq (semantic-overlay-buffer
+ semantic-highlight-func-ct-overlay)
+ (current-buffer))))
+ (let* ((tag (semantic-stickyfunc-tag-to-stick))
+ (ol semantic-highlight-func-ct-overlay))
+ (when (not ol)
+ ;; No overlay in this buffer. Make one.
+ (setq ol (semantic-make-overlay (point-min) (point-min)
+ (current-buffer) t nil))
+ (semantic-overlay-put ol 'highlight-func t)
+ (semantic-overlay-put ol 'face 'semantic-highlight-func-current-tag-face)
+ (semantic-overlay-put ol 'keymap semantic-highlight-func-mode-map)
+ (semantic-overlay-put ol 'help-echo
+ "Current Function : mouse-3 - Context menu")
+ (setq semantic-highlight-func-ct-overlay ol)
+ )
+
+ ;; TAG is nil if there was nothing of the apropriate type there.
+ (if (or (not tag) disable)
+ ;; No tag, make the overlay go away.
+ (progn
+ (semantic-overlay-put ol 'tag nil)
+ (semantic-overlay-move ol (point-min) (point-min) (current-buffer))
+ )
+
+ ;; We have a tag, if it is the same, do nothing.
+ (unless (eq (semantic-overlay-get ol 'tag) tag)
+ (save-excursion
+ (goto-char (semantic-tag-start tag))
+ (search-forward (semantic-tag-name tag) nil t)
+ (semantic-overlay-put ol 'tag tag)
+ (semantic-overlay-move ol (point-at-bol) (point-at-eol))
+ )
+ )
+ )))
+ nil)
+
+(semantic-add-minor-mode 'semantic-highlight-func-mode
+ "" ;; Don't need indicator. It's quite visible
+ nil)
+
+(provide 'semantic/util-modes)
+
+;;; semantic-util-modes.el ends here
projects / emacs.git / commitdiff