From: Chong Yidong Date: Fri, 28 Aug 2009 15:19:20 +0000 (+0000) Subject: cedet/semantic/db.el, cedet/semantic/decorate.el, X-Git-Tag: emacs-pretest-23.1.90~1091^2~106 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=7a0e7d3387b5b675042878e5e2e5878b94b2487a;p=emacs.git cedet/semantic/db.el, cedet/semantic/decorate.el, cedet/semantic/lex-spp.el, cedet/semantic/util-modes.el: New files. --- diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el new file mode 100644 index 00000000000..3b32a9a8123 --- /dev/null +++ b/lisp/cedet/semantic/db.el @@ -0,0 +1,989 @@ +;;; 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 +;; 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 . + +;;; 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)) + ) + )))) + + +;;; 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)) + + +;;; 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 diff --git a/lisp/cedet/semantic/decorate.el b/lisp/cedet/semantic/decorate.el new file mode 100644 index 00000000000..cde0b25d03b --- /dev/null +++ b/lisp/cedet/semantic/decorate.el @@ -0,0 +1,320 @@ +;;; 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 +;; 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 . + +;;; 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 diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el new file mode 100644 index 00000000000..7be7a3a816b --- /dev/null +++ b/lisp/cedet/semantic/lex-spp.el @@ -0,0 +1,1187 @@ +;;; semantic-lex-spp.el --- Semantic Lexical Pre-processor + +;;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; 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 . + +;;; 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 diff --git a/lisp/cedet/semantic/util-modes.el b/lisp/cedet/semantic/util-modes.el new file mode 100644 index 00000000000..e38e1b94637 --- /dev/null +++ b/lisp/cedet/semantic/util-modes.el @@ -0,0 +1,1228 @@ +;;; 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 +;; David Ponce +;; 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 . + +;;; 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)) + )) + +;;;; +;;;; 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) + + +;;;; +;;;; 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))))) + + +;;;; +;;;; 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) + )) + + +;;;; +;;;; 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 : + ;; 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) + + + +;;;; +;;;; 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