-2009-09-27 Chong Yidong <cyd@stupidchicken.com>
++2009-09-28 Eric Ludlam <zappo@gnu.org>
+
- * cedet/ede/system.el (ede-upload-html-documentation)
- (ede-upload-distribution, ede-edit-web-page)
- (ede-web-browse-home): Autoload.
++ CEDET (development tools) package merged.
+
- * cedet/ede/proj-elisp.el: Add autoload for
- semantic-ede-proj-target-grammar.
++ * cedet/*.el:
++ * cedet/ede/*.el:
++ * cedet/semantic/*.el:
++ * cedet/srecode/*.el: New files.
+
- * cedet/semantic.el (navigate-menu): Show menu items only if
- semantic-mode is enabled.
+2009-09-28 Michael Albinus <michael.albinus@gmx.de>
- * cedet/ede.el: Remove comments.
+ * Makefile.in (ELCFILES): Add net/tramp-imap.elc.
- * cedet/cedet.el (cedet-menu-map): Minor doc fix.
+ * net/tramp.el (top): Require tramp-imap.
- * cedet/semantic/grammar.el:
- * cedet/semantic/grammar-wy.el:
- * cedet/semantic/ede-grammar.el: New files.
+ * net/tramp-smb.el (tramp-smb-handle-directory-files-and-attributes):
+ Use `tramp-compat-handle-file-attributes'.
- * cedet/semantic/db-mode.el (global-semanticdb-minor-mode): Define
- using define-minor-mode, so that the usual mode variable exists.
+2009-09-28 Teodor Zlatanov <tzz@lifelogs.com>
-2009-09-27 Chong Yidong <cyd@stupidchicken.com>
+ * net/tramp-imap.el: New package.
+
+2009-09-28 Eric Ludlam <zappo@gnu.org>
+
+ * emacs-lisp/chart.el:
+ * emacs-lisp/eieio-base.el:
+ * emacs-lisp/eieio-comp.el:
+ * emacs-lisp/eieio-custom.el:
+ * emacs-lisp/eieio-datadebug.el:
+ * emacs-lisp/eieio-opt.el:
+ * emacs-lisp/eieio-speedbar.el:
+ * emacs-lisp/eieio.el: New files.
- * cedet/ede.el (global-ede-mode-map): Move menu to
- global-ede-mode-map.
- (ede-minor-mode, global-ede-mode): Use define-minor-mode.
+ * cedet/cedet-cscope.el:
+ * cedet/cedet-files.el:
+ * cedet/cedet-global.el:
+ * cedet/cedet-idutils.el:
+ * cedet/data-debug.el:
+ * cedet/inversion.el:
+ * cedet/mode-local.el:
+ * cedet/pulse.el: New files.
- * cedet/semantic.el (semantic-mode-map): Use cedet-menu-map.
+2009-09-27 Vinicius Jose Latorre <viniciusjl@ig.com.br>
- * cedet/cedet.el (cedet-menu-map): New var. Don't require
- Semantic etc.
+ * whitespace.el (whitespace-trailing-regexp)
+ (whitespace-empty-at-bob-regexp, whitespace-empty-at-eob-regexp):
+ Fix doc string.
2009-09-27 Chong Yidong <cyd@stupidchicken.com>
--- /dev/null
- (ede-or (mapcar (lambda (o) (obj-of-class-p o class)) ede-object))
+ ;;; ede.el --- Emacs Development Environment gloss
+
+ ;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ ;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: project, make
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; EDE is the top level Lisp interface to a project management scheme
+ ;; for Emacs. Emacs does many things well, including editing,
+ ;; building, and debugging. Folks migrating from other IDEs don't
+ ;; seem to think this qualifies, however, because they still have to
+ ;; write the makefiles, and specify parameters to programs.
+ ;;
+ ;; This EDE mode will attempt to link these diverse programs together
+ ;; into a comprehensive single interface, instead of a bunch of
+ ;; different ones.
+
+ ;;; Install
+ ;;
+ ;; This command enables project mode on all files.
+ ;;
+ ;; (global-ede-mode t)
+
+ (require 'cedet)
+ (require 'eieio)
+ (require 'eieio-speedbar)
+ (require 'ede/source)
+ (require 'ede/loaddefs)
+
+ (declare-function ede-convert-path "ede/files")
+ (declare-function ede-directory-get-open-project "ede/files")
+ (declare-function ede-directory-get-toplevel-open-project "ede/files")
+ (declare-function ede-directory-project-p "ede/files")
+ (declare-function ede-find-subproject-for-directory "ede/files")
+ (declare-function ede-project-directory-remove-hash "ede/files")
+ (declare-function ede-project-root "ede/files")
+ (declare-function ede-project-root-directory "ede/files")
+ (declare-function ede-toplevel "ede/files")
+ (declare-function ede-toplevel-project "ede/files")
+ (declare-function ede-up-directory "ede/files")
+ (declare-function data-debug-new-buffer "data-debug")
+ (declare-function data-debug-insert-object-slots "eieio-datadebug")
+ (declare-function semantic-lex-make-spp-table "semantic/lex-spp")
+
+ (defconst ede-version "1.0pre7"
+ "Current version of the Emacs EDE.")
+
+ ;;; Code:
+ (defun ede-version ()
+ "Display the current running version of EDE."
+ (interactive) (message "EDE %s" ede-version))
+
+ (defgroup ede nil
+ "Emacs Development Environment gloss."
+ :group 'tools
+ :group 'convenience
+ )
+
+ (defcustom ede-auto-add-method 'ask
+ "Whether a new source file shoud be automatically added to a target.
+ Whenever a new file is encountered in a directory controlled by a
+ project file, all targets are queried to see if it should be added.
+ If the value is 'always, then the new file is added to the first
+ target encountered. If the value is 'multi-ask, then if more than one
+ target wants the file, the user is asked. If only one target wants
+ the file, then then it is automatically added to that target. If the
+ value is 'ask, then the user is always asked, unless there is no
+ target willing to take the file. 'never means never perform the check."
+ :group 'ede
+ :type '(choice (const always)
+ (const multi-ask)
+ (const ask)
+ (const never)))
+
+ (defcustom ede-debug-program-function 'gdb
+ "Default Emacs command used to debug a target."
+ :group 'ede
+ :type 'sexp) ; make this be a list of options some day
+
+
+ ;;; Top level classes for projects and targets
+
+ (defclass ede-project-autoload ()
+ ((name :initarg :name
+ :documentation "Name of this project type")
+ (file :initarg :file
+ :documentation "The lisp file belonging to this class.")
+ (proj-file :initarg :proj-file
+ :documentation "Name of a project file of this type.")
+ (proj-root :initarg :proj-root
+ :type function
+ :documentation "A function symbol to call for the project root.
+ This function takes no arguments, and returns the current directories
+ root, if available. Leave blank to use the EDE directory walking
+ routine instead.")
+ (initializers :initarg :initializers
+ :initform nil
+ :documentation
+ "Initializers passed to the project object.
+ These are used so there can be multiple types of projects
+ associated with a single object class, based on the initilizeres used.")
+ (load-type :initarg :load-type
+ :documentation "Fn symbol used to load this project file.")
+ (class-sym :initarg :class-sym
+ :documentation "Symbol representing the project class to use.")
+ (new-p :initarg :new-p
+ :initform t
+ :documentation
+ "Non-nil if this is an option when a user creates a project.")
+ )
+ "Class representing minimal knowledge set to run preliminary EDE functions.
+ When more advanced functionality is needed from a project type, that projects
+ type is required and the load function used.")
+
+ (defvar ede-project-class-files
+ (list
+ (ede-project-autoload "edeproject-makefile"
+ :name "Make" :file 'ede/proj
+ :proj-file "Project.ede"
+ :load-type 'ede-proj-load
+ :class-sym 'ede-proj-project)
+ (ede-project-autoload "edeproject-automake"
+ :name "Automake" :file 'ede/proj
+ :proj-file "Project.ede"
+ :initializers '(:makefile-type Makefile.am)
+ :load-type 'ede-proj-load
+ :class-sym 'ede-proj-project)
+ (ede-project-autoload "automake"
+ :name "automake" :file 'ede/project-am
+ :proj-file "Makefile.am"
+ :load-type 'project-am-load
+ :class-sym 'project-am-makefile
+ :new-p nil)
+ (ede-project-autoload "cpp-root"
+ :name "CPP ROOT" :file 'ede/cpp-root
+ :proj-file 'ede-cpp-root-project-file-for-dir
+ :proj-root 'ede-cpp-root-project-root
+ :load-type 'ede-cpp-root-load
+ :class-sym 'ede-cpp-root
+ :new-p nil)
+ (ede-project-autoload "emacs"
+ :name "EMACS ROOT" :file 'ede/emacs
+ :proj-file "src/emacs.c"
+ :proj-root 'ede-emacs-project-root
+ :load-type 'ede-emacs-load
+ :class-sym 'ede-emacs-project
+ :new-p nil)
+ (ede-project-autoload "linux"
+ :name "LINUX ROOT" :file 'ede/linux
+ :proj-file "scripts/ver_linux"
+ :proj-root 'ede-linux-project-root
+ :load-type 'ede-linux-load
+ :class-sym 'ede-linux-project
+ :new-p nil)
+ (ede-project-autoload "simple-overlay"
+ :name "Simple" :file 'ede/simple
+ :proj-file 'ede-simple-projectfile-for-dir
+ :load-type 'ede-simple-load
+ :class-sym 'ede-simple-project))
+ "List of vectos defining how to determine what type of projects exist.")
+
+ ;;; Generic project information manager objects
+
+ (defclass ede-target (eieio-speedbar-directory-button)
+ ((buttonface :initform speedbar-file-face) ;override for superclass
+ (name :initarg :name
+ :type string
+ :custom string
+ :label "Name"
+ :group (default name)
+ :documentation "Name of this target.")
+ ;; @todo - I think this should be "dir", and not "path".
+ (path :initarg :path
+ :type string
+ ;:custom string
+ ;:label "Path to target"
+ ;:group (default name)
+ :documentation "The path to the sources of this target.
+ Relative to the path of the project it belongs to.")
+ (source :initarg :source
+ :initform nil
+ ;; I'd prefer a list of strings.
+ :type list
+ :custom (repeat (string :tag "File"))
+ :label "Source Files"
+ :group (default source)
+ :documentation "Source files in this target.")
+ (versionsource :initarg :versionsource
+ :initform nil
+ :type list
+ :custom (repeat (string :tag "File"))
+ :label "Source Files with Version String"
+ :group (source)
+ :documentation
+ "Source files with a version string in them.
+ These files are checked for a version string whenever the EDE version
+ of the master project is changed. When strings are found, the version
+ previously there is updated.")
+ ;; Class level slots
+ ;;
+ ; (takes-compile-command :allocation :class
+ ; :initarg :takes-compile-command
+ ; :type boolean
+ ; :initform nil
+ ; :documentation
+ ; "Non-nil if this target requires a user approved command.")
+ (sourcetype :allocation :class
+ :type list ;; list of symbols
+ :documentation
+ "A list of `ede-sourcecode' objects this class will handle.
+ This is used to match target objects with the compilers they can use, and
+ which files this object is interested in."
+ :accessor ede-object-sourcecode)
+ (keybindings :allocation :class
+ :initform (("D" . ede-debug-target))
+ :documentation
+ "Keybindings specialized to this type of target."
+ :accessor ede-object-keybindings)
+ (menu :allocation :class
+ :initform ( [ "Debug target" ede-debug-target
+ (and ede-object
+ (obj-of-class-p ede-object ede-target)) ]
+ )
+ :documentation "Menu specialized to this type of target."
+ :accessor ede-object-menu)
+ )
+ "A top level target to build.")
+
+ (defclass ede-project-placeholder (eieio-speedbar-directory-button)
+ ((name :initarg :name
+ :initform "Untitled"
+ :type string
+ :custom string
+ :label "Name"
+ :group (default name)
+ :documentation "The name used when generating distribution files.")
+ (version :initarg :version
+ :initform "1.0"
+ :type string
+ :custom string
+ :label "Version"
+ :group (default name)
+ :documentation "The version number used when distributing files.")
+ (directory :type string
+ :initarg :directory
+ :documentation "Directory this project is associated with.")
+ (dirinode :documentation "The inode id for :directory.")
+ (file :type string
+ :initarg :file
+ :documentation "File name where this project is stored.")
+ (rootproject ; :initarg - no initarg, don't save this slot!
+ :initform nil
+ :type (or null ede-project-placeholder-child)
+ :documentation "Pointer to our root project.")
+ )
+ "Placeholder object for projects not loaded into memory.
+ Projects placeholders will be stored in a user specific location
+ and querying them will cause the actual project to get loaded.")
+
+ (defclass ede-project (ede-project-placeholder)
+ ((subproj :initform nil
+ :type list
+ :documentation "Sub projects controlled by this project.
+ For Automake based projects, each directory is treated as a project.")
+ (targets :initarg :targets
+ :type list
+ :custom (repeat (object :objectcreatefcn ede-new-target-custom))
+ :label "Local Targets"
+ :group (targets)
+ :documentation "List of top level targets in this project.")
+ (locate-obj :type (or null ede-locate-base-child)
+ :documentation
+ "A locate object to use as a backup to `ede-expand-filename'.")
+ (tool-cache :initarg :tool-cache
+ :type list
+ :custom (repeat object)
+ :label "Tool: "
+ :group tools
+ :documentation "List of tool cache configurations in this project.
+ This allows any tool to create, manage, and persist project-specific settings.")
+ (mailinglist :initarg :mailinglist
+ :initform ""
+ :type string
+ :custom string
+ :label "Mailing List Address"
+ :group name
+ :documentation
+ "An email address where users might send email for help.")
+ (web-site-url :initarg :web-site-url
+ :initform ""
+ :type string
+ :custom string
+ :label "Web Site URL"
+ :group name
+ :documentation "URL to this projects web site.
+ This is a URL to be sent to a web site for documentation.")
+ (web-site-directory :initarg :web-site-directory
+ :initform ""
+ :custom string
+ :label "Web Page Directory"
+ :group name
+ :documentation
+ "A directory where web pages can be found by Emacs.
+ For remote locations use a path compatible with ange-ftp or EFS.
+ You can also use TRAMP for use with rcp & scp.")
+ (web-site-file :initarg :web-site-file
+ :initform ""
+ :custom string
+ :label "Web Page File"
+ :group name
+ :documentation
+ "A file which contains the home page for this project.
+ This file can be relative to slot `web-site-directory'.
+ This can be a local file, use ange-ftp, EFS, or TRAMP.")
+ (ftp-site :initarg :ftp-site
+ :initform ""
+ :type string
+ :custom string
+ :label "FTP site"
+ :group name
+ :documentation
+ "FTP site where this project's distribution can be found.
+ This FTP site should be in Emacs form, as needed by `ange-ftp', but can
+ also be of a form used by TRAMP for use with scp, or rcp.")
+ (ftp-upload-site :initarg :ftp-upload-site
+ :initform ""
+ :type string
+ :custom string
+ :label "FTP Upload site"
+ :group name
+ :documentation
+ "FTP Site to upload new distributions to.
+ This FTP site should be in Emacs form as needed by `ange-ftp'.
+ If this slot is nil, then use `ftp-site' instead.")
+ (configurations :initarg :configurations
+ :initform ("debug" "release")
+ :type list
+ :custom (repeat string)
+ :label "Configuration Options"
+ :group (settings)
+ :documentation "List of available configuration types.
+ Individual target/project types can form associations between a configuration,
+ and target specific elements such as build variables.")
+ (configuration-default :initarg :configuration-default
+ :initform "debug"
+ :custom string
+ :label "Current Configuration"
+ :group (settings)
+ :documentation "The default configuration.")
+ (local-variables :initarg :local-variables
+ :initform nil
+ :custom (repeat (cons (sexp :tag "Variable")
+ (sexp :tag "Value")))
+ :label "Project Local Variables"
+ :group (settings)
+ :documentation "Project local variables")
+ (keybindings :allocation :class
+ :initform (("D" . ede-debug-target))
+ :documentation "Keybindings specialized to this type of target."
+ :accessor ede-object-keybindings)
+ (menu :allocation :class
+ :initform
+ (
+ [ "Update Version" ede-update-version ede-object ]
+ [ "Version Control Status" ede-vc-project-directory ede-object ]
+ [ "Edit Project Homepage" ede-edit-web-page
+ (and ede-object (oref (ede-toplevel) web-site-file)) ]
+ [ "Browse Project URL" ede-web-browse-home
+ (and ede-object
+ (not (string= "" (oref (ede-toplevel) web-site-url)))) ]
+ "--"
+ [ "Rescan Project Files" ede-rescan-toplevel t ]
+ [ "Edit Projectfile" ede-edit-file-target
+ (and ede-object
+ (or (listp ede-object)
+ (not (obj-of-class-p ede-object ede-project)))) ]
+ )
+ :documentation "Menu specialized to this type of target."
+ :accessor ede-object-menu)
+ )
+ "Top level EDE project specification.
+ All specific project types must derive from this project."
+ :method-invocation-order :depth-first)
+ \f
+ ;;; Management variables
+
+ (defvar ede-projects nil
+ "A list of all active projects currently loaded in Emacs.")
+
+ (defvar ede-object-root-project nil
+ "The current buffer's current root project.
+ If a file is under a project, this specifies the project that is at
+ the root of a project tree.")
+ (make-variable-buffer-local 'ede-object-root-project)
+
+ (defvar ede-object-project nil
+ "The current buffer's current project at that level.
+ If a file is under a project, this specifies the project that contains the
+ current target.")
+ (make-variable-buffer-local 'ede-object-project)
+
+ (defvar ede-object nil
+ "The current buffer's target object.
+ This object's class determines how to compile and debug from a buffer.")
+ (make-variable-buffer-local 'ede-object)
+
+ (defvar ede-selected-object nil
+ "The currently user-selected project or target.
+ If `ede-object' is nil, then commands will operate on this object.")
+
+ (defvar ede-constructing nil
+ "Non nil when constructing a project hierarchy.")
+
+ (defvar ede-deep-rescan nil
+ "Non nil means scan down a tree, otherwise rescans are top level only.
+ Do not set this to non-nil globally. It is used internally.")
+ \f
+ ;;; The EDE persistent cache.
+ ;;
+ (defcustom ede-project-placeholder-cache-file
+ (expand-file-name "~/.projects.ede")
+ "File containing the list of projects EDE has viewed."
+ :group 'ede
+ :type 'file)
+
+ (defvar ede-project-cache-files nil
+ "List of project files EDE has seen before.")
+
+ (defun ede-save-cache ()
+ "Save a cache of EDE objects that Emacs has seen before."
+ (interactive)
+ (let ((p ede-projects)
+ (c ede-project-cache-files)
+ (recentf-exclude '(ignore))
+ )
+ (condition-case nil
+ (progn
+ (set-buffer (find-file-noselect ede-project-placeholder-cache-file t))
+ (erase-buffer)
+ (insert ";; EDE project cache file.
+ ;; This contains a list of projects you have visited.\n(")
+ (while p
+ (when (and (car p) (ede-project-p p))
+ (let ((f (oref (car p) file)))
+ (when (file-exists-p f)
+ (insert "\n \"" f "\""))))
+ (setq p (cdr p)))
+ (while c
+ (insert "\n \"" (car c) "\"")
+ (setq c (cdr c)))
+ (insert "\n)\n")
+ (condition-case nil
+ (save-buffer 0)
+ (error
+ (message "File %s could not be saved."
+ ede-project-placeholder-cache-file)))
+ (kill-buffer (current-buffer))
+ )
+ (error
+ (message "File %s could not be read."
+ ede-project-placeholder-cache-file))
+
+ )))
+
+ (defun ede-load-cache ()
+ "Load the cache of EDE projects."
+ (save-excursion
+ (let ((cachebuffer nil))
+ (condition-case nil
+ (progn
+ (setq cachebuffer
+ (find-file-noselect ede-project-placeholder-cache-file t))
+ (set-buffer cachebuffer)
+ (goto-char (point-min))
+ (let ((c (read (current-buffer)))
+ (new nil)
+ (p ede-projects))
+ ;; Remove loaded projects from the cache.
+ (while p
+ (setq c (delete (oref (car p) file) c))
+ (setq p (cdr p)))
+ ;; Remove projects that aren't on the filesystem
+ ;; anymore.
+ (while c
+ (when (file-exists-p (car c))
+ (setq new (cons (car c) new)))
+ (setq c (cdr c)))
+ ;; Save it
+ (setq ede-project-cache-files (nreverse new))))
+ (error nil))
+ (when cachebuffer (kill-buffer cachebuffer))
+ )))
+ \f
+ ;;; Important macros for doing commands.
+ ;;
+ (defmacro ede-with-projectfile (obj &rest forms)
+ "For the project in which OBJ resides, execute FORMS."
+ (list 'save-window-excursion
+ (list 'let* (list
+ (list 'pf
+ (list 'if (list 'obj-of-class-p
+ obj 'ede-target)
+ ;; @todo -I think I can change
+ ;; this to not need ede-load-project-file
+ ;; but I'm not sure how to test well.
+ (list 'ede-load-project-file
+ (list 'oref obj 'path))
+ obj))
+ '(dbka (get-file-buffer (oref pf file))))
+ '(if (not dbka) (find-file (oref pf file))
+ (switch-to-buffer dbka))
+ (cons 'progn forms)
+ '(if (not dbka) (kill-buffer (current-buffer))))))
+ (put 'ede-with-projectfile 'lisp-indent-function 1)
+
+ \f
+ ;;; Prompting
+ ;;
+ (defun ede-singular-object (prompt)
+ "Using PROMPT, choose a single object from the current buffer."
+ (if (listp ede-object)
+ (ede-choose-object prompt ede-object)
+ ede-object))
+
+ (defun ede-choose-object (prompt list-o-o)
+ "Using PROMPT, ask the user which OBJECT to use based on the name field.
+ Argument LIST-O-O is the list of objects to choose from."
+ (let* ((al (object-assoc-list 'name list-o-o))
+ (ans (completing-read prompt al nil t)))
+ (setq ans (assoc ans al))
+ (cdr ans)))
+ \f
+ ;;; Menu and Keymap
+
+ (defvar ede-minor-mode-map
+ (let ((map (make-sparse-keymap))
+ (pmap (make-sparse-keymap)))
+ (define-key pmap "e" 'ede-edit-file-target)
+ (define-key pmap "a" 'ede-add-file)
+ (define-key pmap "d" 'ede-remove-file)
+ (define-key pmap "t" 'ede-new-target)
+ (define-key pmap "g" 'ede-rescan-toplevel)
+ (define-key pmap "s" 'ede-speedbar)
+ (define-key pmap "l" 'ede-load-project-file)
+ (define-key pmap "f" 'ede-find-file)
+ (define-key pmap "C" 'ede-compile-project)
+ (define-key pmap "c" 'ede-compile-target)
+ (define-key pmap "\C-c" 'ede-compile-selected)
+ (define-key pmap "D" 'ede-debug-target)
+ ;; bind our submap into map
+ (define-key map "\C-c." pmap)
+ map)
+ "Keymap used in project minor mode.")
+
+ (defvar global-ede-mode-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [menu-bar cedet-menu]
+ (cons "Development" cedet-menu-map))
+ map)
+ "Keymap used in `global-ede-mode'")
+
+ ;; Activate the EDE items in cedet-menu-map
+
+ (define-key cedet-menu-map [ede-find-file]
+ '(menu-item "Find File in Project..." ede-find-file :enable ede-object))
+ (define-key cedet-menu-map [ede-speedbar]
+ '(menu-item "View Project Tree" ede-speedbar :enable ede-object))
+ (define-key cedet-menu-map [ede]
+ '(menu-item "Load Project" ede))
+ (define-key cedet-menu-map [ede-new]
+ '(menu-item "Create Project" ede-new
+ :enable (not ede-object)))
+ (define-key cedet-menu-map [ede-target-options]
+ '(menu-item "Target Options" ede-target-options
+ :filter ede-target-forms-menu))
+ (define-key cedet-menu-map [ede-project-options]
+ '(menu-item "Project Options" ede-project-options
+ :filter ede-project-forms-menu))
+ (define-key cedet-menu-map [ede-build-forms-menu]
+ '(menu-item "Build Project" ede-build-forms-menu
+ :filter ede-build-forms-menu
+ :enable ede-object))
+ (define-key cedet-menu-map [semantic-menu-separator] 'undefined)
+ (define-key cedet-menu-map [cedet-menu-separator] 'undefined)
+ (define-key cedet-menu-map [ede-menu-separator] '("--"))
+
+ (defun ede-menu-obj-of-class-p (class)
+ "Return non-nil if some member of `ede-object' is a child of CLASS."
+ (if (listp ede-object)
- (ede-or (ede-map-targets this proc)))
++ (eval (cons 'or (mapcar (lambda (o) (obj-of-class-p o class)) ede-object)))
+ (obj-of-class-p ede-object class)))
+
+ (defun ede-build-forms-menu (menu-def)
+ "Create a sub menu for building different parts of an EDE system.
+ Argument MENU-DEF is the menu definition to use."
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Build Forms"
+ (let ((obj (ede-current-project))
+ (newmenu nil) ;'([ "Build Selected..." ede-compile-selected t ]))
+ targets
+ targitems
+ ede-obj
+ (tskip nil))
+ (if (not obj)
+ nil
+ (setq targets (when (slot-boundp obj 'targets)
+ (oref obj targets))
+ ede-obj (if (listp ede-object) ede-object (list ede-object)))
+ ;; First, collect the build items from the project
+ (setq newmenu (append newmenu (ede-menu-items-build obj t)))
+ ;; Second, Declare the current target menu items
+ (if (and ede-obj (ede-menu-obj-of-class-p ede-target))
+ (while ede-obj
+ (setq newmenu (append newmenu
+ (ede-menu-items-build (car ede-obj) t))
+ tskip (car ede-obj)
+ ede-obj (cdr ede-obj))))
+ ;; Third, by name, enable builds for other local targets
+ (while targets
+ (unless (eq tskip (car targets))
+ (setq targitems (ede-menu-items-build (car targets) nil))
+ (setq newmenu
+ (append newmenu
+ (if (= 1 (length targitems))
+ targitems
+ (cons (ede-name (car targets))
+ targitems))))
+ )
+ (setq targets (cdr targets)))
+ ;; Fourth, build sub projects.
+ ;; -- nerp
+ ;; Fifth, Add make distribution
+ (append newmenu (list [ "Make distribution" ede-make-dist t ]))
+ )))))
+
+ (defun ede-target-forms-menu (menu-def)
+ "Create a target MENU-DEF based on the object belonging to this buffer."
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Target Forms"
+ (let ((obj (or ede-selected-object ede-object)))
+ (append
+ '([ "Add File" ede-add-file (ede-current-project) ]
+ [ "Remove File" ede-remove-file
+ (and ede-object
+ (or (listp ede-object)
+ (not (obj-of-class-p ede-object ede-project)))) ]
+ "-")
+ (if (not obj)
+ nil
+ (if (and (not (listp obj)) (oref obj menu))
+ (oref obj menu)
+ (when (listp obj)
+ ;; This is bad, but I'm not sure what else to do.
+ (oref (car obj) menu)))))))))
+
+ (defun ede-project-forms-menu (menu-def)
+ "Create a target MENU-DEF based on the object belonging to this buffer."
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Project Forms"
+ (let* ((obj (ede-current-project))
+ (class (if obj (object-class obj)))
+ (menu nil))
+ (condition-case err
+ (progn
+ (while (and class (slot-exists-p class 'menu))
+ ;;(message "Looking at class %S" class)
+ (setq menu (append menu (oref class menu))
+ class (class-parent class))
+ (if (listp class) (setq class (car class))))
+ (append
+ '( [ "Add Target" ede-new-target (ede-current-project) ]
+ [ "Remove Target" ede-delete-target ede-object ]
+ "-")
+ menu
+ ))
+ (error (message "Err found: %S" err)
+ menu)
+ )))))
+
+ (defun ede-customize-forms-menu (menu-def)
+ "Create a menu of the project, and targets that can be customized.
+ Argument MENU-DEF is the definition of the current menu."
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Customize Project"
+ (let* ((obj (ede-current-project))
+ targ)
+ (when obj
+ (setq targ (when (slot-boundp obj 'targets)
+ (oref obj targets)))
+ ;; Make custom menus for everything here.
+ (append (list
+ (cons (concat "Project " (ede-name obj))
+ (eieio-customize-object-group obj))
+ [ "Reorder Targets" ede-project-sort-targets t ]
+ )
+ (mapcar (lambda (o)
+ (cons (concat "Target " (ede-name o))
+ (eieio-customize-object-group o)))
+ targ)))))))
+
+
+ (defun ede-apply-object-keymap (&optional default)
+ "Add target specific keybindings into the local map.
+ Optional argument DEFAULT indicates if this should be set to the default
+ version of the keymap."
+ (let ((object (or ede-object ede-selected-object)))
+ (condition-case nil
+ (let ((keys (ede-object-keybindings object)))
+ (while keys
+ (local-set-key (concat "\C-c." (car (car keys)))
+ (cdr (car keys)))
+ (setq keys (cdr keys))))
+ (error nil))))
+
+ ;;; Menu building methods for building
+ ;;
+ (defmethod ede-menu-items-build ((obj ede-project) &optional current)
+ "Return a list of menu items for building project OBJ.
+ If optional argument CURRENT is non-nil, return sub-menu code."
+ (if current
+ (list [ "Build Current Project" ede-compile-project t ])
+ (list (vector
+ (list
+ (concat "Build Project " (ede-name obj))
+ `(project-compile-project ,obj))))))
+
+ (defmethod ede-menu-items-build ((obj ede-target) &optional current)
+ "Return a list of menu items for building target OBJ.
+ If optional argument CURRENT is non-nil, return sub-menu code."
+ (if current
+ (list [ "Build Current Target" ede-compile-target t ])
+ (list (vector
+ (concat "Build Target " (ede-name obj))
+ `(project-compile-target ,obj)
+ t))))
+ \f
+ ;;; Mode Declarations
+ ;;
+ (eval-and-compile
+ (autoload 'ede-dired-minor-mode "ede/dired" "EDE commands for dired" t))
+
+ (defun ede-apply-target-options ()
+ "Apply options to the current buffer for the active project/target."
+ (if (ede-current-project)
+ (ede-set-project-variables (ede-current-project)))
+ (ede-apply-object-keymap)
+ (ede-apply-preprocessor-map)
+ )
+
+ (defun ede-turn-on-hook ()
+ "Turn on EDE minor mode in the current buffer if needed.
+ To be used in hook functions."
+ (if (or (and (stringp (buffer-file-name))
+ (stringp default-directory))
+ ;; Emacs 21 has no buffer file name for directory edits.
+ ;; so we need to add these hacks in.
+ (eq major-mode 'dired-mode)
+ (eq major-mode 'vc-dired-mode))
+ (ede-minor-mode 1)))
+
+ (define-minor-mode ede-minor-mode
+ "Toggle EDE (Emacs Development Environment) minor mode.
+ With non-nil argument ARG, enable EDE minor mode if ARG is
+ positive; otherwise, disable it.
+
+ If this file is contained, or could be contained in an EDE
+ controlled project, then this mode is activated automatically
+ provided `global-ede-mode' is enabled."
+ :group 'ede
+ (cond ((or (eq major-mode 'dired-mode)
+ (eq major-mode 'vc-dired-mode))
+ (ede-dired-minor-mode (if ede-minor-mode 1 -1)))
+ (ede-minor-mode
+ (if (and (not ede-constructing)
+ (ede-directory-project-p default-directory t))
+ (let* ((ROOT nil)
+ (proj (ede-directory-get-open-project default-directory
+ 'ROOT)))
+ (when (not proj)
+ ;; @todo - this could be wasteful.
+ (setq proj (ede-load-project-file default-directory 'ROOT)))
+ (setq ede-object-project proj)
+ (setq ede-object-root-project
+ (or ROOT (ede-project-root proj)))
+ (setq ede-object (ede-buffer-object))
+ (if (and (not ede-object) ede-object-project)
+ (ede-auto-add-to-target))
+ (ede-apply-target-options))
+ ;; If we fail to have a project here, turn it back off.
+ (ede-minor-mode -1)))))
+
+ (defun ede-reset-all-buffers (onoff)
+ "Reset all the buffers due to change in EDE.
+ ONOFF indicates enabling or disabling the mode."
+ (let ((b (buffer-list)))
+ (while b
+ (when (buffer-file-name (car b))
+ (ede-buffer-object (car b))
+ )
+ (setq b (cdr b)))))
+
+ ;;;###autoload
+ (define-minor-mode global-ede-mode
+ "Toggle global EDE (Emacs Development Environment) mode.
+ With non-nil argument ARG, enable global EDE mode if ARG is
+ positive; otherwise, disable it.
+
+ This global minor mode enables `ede-minor-mode' in all buffers in
+ an EDE controlled project."
+ :global t
+ :group 'ede
+ (if global-ede-mode
+ ;; Turn on global-ede-mode
+ (progn
+ (add-hook 'semanticdb-project-predicate-functions 'ede-directory-project-p)
+ (add-hook 'semanticdb-project-root-functions 'ede-toplevel-project-or-nil)
+ (add-hook 'ecb-source-path-functions 'ede-ecb-project-paths)
+ (add-hook 'find-file-hook 'ede-turn-on-hook)
+ (add-hook 'dired-mode-hook 'ede-turn-on-hook)
+ (add-hook 'kill-emacs-hook 'ede-save-cache)
+ (ede-load-cache)
+ (ede-reset-all-buffers 1))
+ ;; Turn off global-ede-mode
+ (remove-hook 'semanticdb-project-predicate-functions 'ede-directory-project-p)
+ (remove-hook 'semanticdb-project-root-functions 'ede-toplevel-project-or-nil)
+ (remove-hook 'ecb-source-path-functions 'ede-ecb-project-paths)
+ (remove-hook 'find-file-hook 'ede-turn-on-hook)
+ (remove-hook 'dired-mode-hook 'ede-turn-on-hook)
+ (remove-hook 'kill-emacs-hook 'ede-save-cache)
+ (ede-save-cache)
+ (ede-reset-all-buffers -1)))
+
+ (defvar ede-ignored-file-alist
+ '( "\\.cvsignore$"
+ "\\.#"
+ "~$"
+ )
+ "List of file name patters that EDE will never ask about.")
+
+ (defun ede-ignore-file (filename)
+ "Should we ignore FILENAME?"
+ (let ((any nil)
+ (F ede-ignored-file-alist))
+ (while (and (not any) F)
+ (when (string-match (car F) filename)
+ (setq any t))
+ (setq F (cdr F)))
+ any))
+
+ (defun ede-auto-add-to-target ()
+ "Look for a target that wants to own the current file.
+ Follow the preference set with `ede-auto-add-method' and get the list
+ of objects with the `ede-want-file-p' method."
+ (if ede-object (error "Ede-object already defined for %s" (buffer-name)))
+ (if (or (eq ede-auto-add-method 'never)
+ (ede-ignore-file (buffer-file-name)))
+ nil
+ (let (wants desires)
+ ;; Find all the objects.
+ (setq wants (oref (ede-current-project) targets))
+ (while wants
+ (if (ede-want-file-p (car wants) (buffer-file-name))
+ (setq desires (cons (car wants) desires)))
+ (setq wants (cdr wants)))
+ (if desires
+ (cond ((or (eq ede-auto-add-method 'ask)
+ (and (eq ede-auto-add-method 'multi-ask)
+ (< 1 (length desires))))
+ (let* ((al (append
+ ;; some defaults
+ '(("none" . nil)
+ ("new target" . new))
+ ;; If we are in an unparented subdir,
+ ;; offer new a subproject
+ (if (ede-directory-project-p default-directory)
+ ()
+ '(("create subproject" . project)))
+ ;; Here are the existing objects we want.
+ (object-assoc-list 'name desires)))
+ (case-fold-search t)
+ (ans (completing-read
+ (format "Add %s to target: " (buffer-file-name))
+ al nil t)))
+ (setq ans (assoc ans al))
+ (cond ((eieio-object-p (cdr ans))
+ (ede-add-file (cdr ans)))
+ ((eq (cdr ans) 'new)
+ (ede-new-target))
+ (t nil))))
+ ((or (eq ede-auto-add-method 'always)
+ (and (eq ede-auto-add-method 'multi-ask)
+ (= 1 (length desires))))
+ (ede-add-file (car desires)))
+ (t nil))))))
+
+ \f
+ ;;; Interactive method invocations
+ ;;
+ (defun ede (file)
+ "Start up EDE on something.
+ Argument FILE is the file or directory to load a project from."
+ (interactive "fProject File: ")
+ (if (not (file-exists-p file))
+ (ede-new file)
+ (ede-load-project-file (file-name-directory file))))
+
+ (defun ede-new (type &optional name)
+ "Create a new project starting of project type TYPE.
+ Optional argument NAME is the name to give this project."
+ (interactive
+ (list (completing-read "Project Type: "
+ (object-assoc-list
+ 'name
+ (let* ((l ede-project-class-files)
+ (cp (ede-current-project))
+ (cs (when cp (object-class cp)))
+ (r nil))
+ (while l
+ (if cs
+ (if (eq (oref (car l) :class-sym)
+ cs)
+ (setq r (cons (car l) r)))
+ (if (oref (car l) new-p)
+ (setq r (cons (car l) r))))
+ (setq l (cdr l)))
+ (when (not r)
+ (if cs
+ (error "No valid interactive sub project types for %s"
+ cs)
+ (error "EDE error: Can't fin project types to create")))
+ r)
+ )
+ nil t)))
+ ;; Make sure we have a valid directory
+ (when (not (file-exists-p default-directory))
+ (error "Cannot create project in non-existant directory %s" default-directory))
+ (when (not (file-writable-p default-directory))
+ (error "No write permissions for %s" default-directory))
+ ;; Create the project
+ (let* ((obj (object-assoc type 'name ede-project-class-files))
+ (nobj (let ((f (oref obj file))
+ (pf (oref obj proj-file)))
+ ;; We are about to make something new, changing the
+ ;; state of existing directories.
+ (ede-project-directory-remove-hash default-directory)
+ ;; Make sure this class gets loaded!
+ (require f)
+ (make-instance (oref obj class-sym)
+ :name (or name (read-string "Name: "))
+ :directory default-directory
+ :file (cond ((stringp pf)
+ (expand-file-name pf))
+ ((fboundp pf)
+ (funcall pf))
+ (t
+ (error
+ "Unknown file name specifier %S"
+ pf)))
+ :targets nil)))
+ (inits (oref obj initializers)))
+ ;; Force the name to match for new objects.
+ (object-set-name-string nobj (oref nobj :name))
+ ;; Handle init args.
+ (while inits
+ (eieio-oset nobj (car inits) (car (cdr inits)))
+ (setq inits (cdr (cdr inits))))
+ (let ((pp (ede-parent-project)))
+ (when pp
+ (ede-add-subproject pp nobj)
+ (ede-commit-project pp)))
+ (ede-commit-project nobj))
+ ;; Have the menu appear
+ (setq ede-minor-mode t)
+ ;; Allert the user
+ (message "Project created and saved. You may now create targets."))
+
+ (defmethod ede-add-subproject ((proj-a ede-project) proj-b)
+ "Add into PROJ-A, the subproject PROJ-B."
+ (oset proj-a subproj (cons proj-b (oref proj-a subproj))))
+
+ (defmethod ede-subproject-relative-path ((proj ede-project) &optional parent-in)
+ "Get a path name for PROJ which is relative to the parent project.
+ If PARENT is specified, then be relative to the PARENT project.
+ Specifying PARENT is useful for sub-sub projects relative to the root project."
+ (let* ((parent (or parent-in (ede-parent-project proj)))
+ (dir (file-name-directory (oref proj file))))
+ (if (and parent (not (eq parent proj)))
+ (file-relative-name dir (file-name-directory (oref parent file)))
+ "")))
+
+ (defmethod ede-subproject-p ((proj ede-project))
+ "Return non-nil if PROJ is a sub project."
+ (ede-parent-project proj))
+
+ (defun ede-invoke-method (sym &rest args)
+ "Invoke method SYM on the current buffer's project object.
+ ARGS are additional arguments to pass to method sym."
+ (if (not ede-object)
+ (error "Cannot invoke %s for %s" (symbol-name sym)
+ (buffer-name)))
+ ;; Always query a target. There should never be multiple
+ ;; projects in a single buffer.
+ (apply sym (ede-singular-object "Target: ") args))
+
+ (defun ede-rescan-toplevel ()
+ "Rescan all project files."
+ (interactive)
+ (let ((toppath (ede-toplevel-project default-directory))
+ (ede-deep-rescan t))
+ (project-rescan (ede-load-project-file toppath))
+ (ede-reset-all-buffers 1)
+ ))
+
+ (defun ede-new-target (&rest args)
+ "Create a new target specific to this type of project file.
+ Different projects accept different arguments ARGS.
+ Typically you can specify NAME, target TYPE, and AUTOADD, where AUTOADD is
+ a string \"y\" or \"n\", which answers the y/n question done interactively."
+ (interactive)
+ (apply 'project-new-target (ede-current-project) args)
+ (setq ede-object nil)
+ (setq ede-object (ede-buffer-object (current-buffer)))
+ (ede-apply-target-options))
+
+ (defun ede-new-target-custom ()
+ "Create a new target specific to this type of project file."
+ (interactive)
+ (project-new-target-custom (ede-current-project)))
+
+ (defun ede-delete-target (target)
+ "Delete TARGET from the current project."
+ (interactive (list
+ (let ((ede-object (ede-current-project)))
+ (ede-invoke-method 'project-interactive-select-target
+ "Target: "))))
+ ;; Find all sources in buffers associated with the condemned buffer.
+ (let ((condemned (ede-target-buffers target)))
+ (project-delete-target target)
+ ;; Loop over all project controlled buffers
+ (save-excursion
+ (while condemned
+ (set-buffer (car condemned))
+ (setq ede-object nil)
+ (setq ede-object (ede-buffer-object (current-buffer)))
+ (setq condemned (cdr condemned))))
+ (ede-apply-target-options)))
+
+ (defun ede-add-file (target)
+ "Add the current buffer to a TARGET in the current project."
+ (interactive (list
+ (let ((ede-object (ede-current-project)))
+ (ede-invoke-method 'project-interactive-select-target
+ "Target: "))))
+ (when (stringp target)
+ (let* ((proj (ede-current-project))
+ (ob (object-assoc-list 'name (oref proj targets))))
+ (setq target (cdr (assoc target ob)))))
+
+ (when (not target)
+ (error "Could not find specified target %S" target))
+
+ (project-add-file target (buffer-file-name))
+ (setq ede-object nil)
+ (setq ede-object (ede-buffer-object (current-buffer)))
+ (when (not ede-object)
+ (error "Can't add %s to target %s: Wrong file type"
+ (file-name-nondirectory (buffer-file-name))
+ (object-name target)))
+ (ede-apply-target-options))
+
+ (defun ede-remove-file (&optional force)
+ "Remove the current file from targets.
+ Optional argument FORCE forces the file to be removed without asking."
+ (interactive "P")
+ (if (not ede-object)
+ (error "Cannot invoke remove-file for %s" (buffer-name)))
+ (let ((eo (if (listp ede-object)
+ (prog1
+ ede-object
+ (setq force nil))
+ (list ede-object))))
+ (while eo
+ (if (or force (y-or-n-p (format "Remove from %s? " (ede-name (car eo)))))
+ (project-remove-file (car eo) (buffer-file-name)))
+ (setq eo (cdr eo)))
+ (setq ede-object nil)
+ (setq ede-object (ede-buffer-object (current-buffer)))
+ (ede-apply-target-options)))
+
+ (defun ede-edit-file-target ()
+ "Enter the project file to hand edit the current buffer's target."
+ (interactive)
+ (ede-invoke-method 'project-edit-file-target))
+
+ (defun ede-compile-project ()
+ "Compile the current project."
+ (interactive)
+ ;; @TODO - This just wants the root. There should be a better way.
+ (let ((cp (ede-current-project)))
+ (while (ede-parent-project cp)
+ (setq cp (ede-parent-project cp)))
+ (let ((ede-object cp))
+ (ede-invoke-method 'project-compile-project))))
+
+ (defun ede-compile-selected (target)
+ "Compile some TARGET from the current project."
+ (interactive (list (project-interactive-select-target (ede-current-project)
+ "Target to Build: ")))
+ (project-compile-target target))
+
+ (defun ede-compile-target ()
+ "Compile the current buffer's associated target."
+ (interactive)
+ (ede-invoke-method 'project-compile-target))
+
+ (defun ede-debug-target ()
+ "Debug the current buffer's assocated target."
+ (interactive)
+ (ede-invoke-method 'project-debug-target))
+
+ (defun ede-make-dist ()
+ "Create a distribution from the current project."
+ (interactive)
+ (let ((ede-object (ede-current-project)))
+ (ede-invoke-method 'project-make-dist)))
+
+ ;;; Customization
+ ;;
+ ;; Routines for customizing projects and targets.
+
+ (defvar eieio-ede-old-variables nil
+ "The old variables for a project.")
+
+ (defalias 'customize-project 'ede-customize-project)
+ (defun ede-customize-project (&optional group)
+ "Edit fields of the current project through EIEIO & Custom.
+ Optional GROUP specifies the subgroup of slots to customize."
+ (interactive "P")
+ (require 'eieio-custom)
+ (let* ((ov (oref (ede-current-project) local-variables))
+ (cp (ede-current-project))
+ (group (if group (eieio-read-customization-group cp))))
+ (eieio-customize-object cp group)
+ (make-local-variable 'eieio-ede-old-variables)
+ (setq eieio-ede-old-variables ov)))
+
+ (defalias 'customize-target 'ede-customize-current-target)
+ (defun ede-customize-current-target(&optional group)
+ "Edit fields of the current target through EIEIO & Custom.
+ Optional argument OBJ is the target object to customize.
+ Optional argument GROUP is the slot group to display."
+ (interactive "P")
+ (require 'eieio-custom)
+ (if (not (obj-of-class-p ede-object ede-target))
+ (error "Current file is not part of a target."))
+ (let ((group (if group (eieio-read-customization-group ede-object))))
+ (ede-customize-target ede-object group)))
+
+ (defun ede-customize-target (obj group)
+ "Edit fields of the current target through EIEIO & Custom.
+ Optional argument OBJ is the target object to customize.
+ Optional argument GROUP is the slot group to display."
+ (require 'eieio-custom)
+ (if (and obj (not (obj-of-class-p obj ede-target)))
+ (error "No logical target to customize"))
+ (eieio-customize-object obj (or group 'default)))
+ ;;; Target Sorting
+ ;;
+ ;; Target order can be important, but custom doesn't support a way
+ ;; to resort items in a list. This function by David Engster allows
+ ;; targets to be re-arranged.
+
+ (defvar ede-project-sort-targets-order nil
+ "Variable for tracking target order in `ede-project-sort-targets'.")
+
+ (defun ede-project-sort-targets ()
+ "Create a custom-like buffer for sorting targets of current project."
+ (interactive)
+ (let ((proj (ede-current-project))
+ (count 1)
+ current order)
+ (switch-to-buffer (get-buffer-create "*EDE sort targets*"))
+ (erase-buffer)
+ (setq ede-object-project proj)
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (let ((targets (oref ede-object-project targets))
+ cur newtargets)
+ (while (setq cur (pop ede-project-sort-targets-order))
+ (setq newtargets (append newtargets
+ (list (nth cur targets)))))
+ (oset ede-object-project targets newtargets))
+ (ede-commit-project ede-object-project)
+ (kill-buffer))
+ " Accept ")
+ (widget-insert " ")
+ (widget-create 'push-button
+ :notify (lambda (&rest ignore)
+ (kill-buffer))
+ " Cancel ")
+ (widget-insert "\n\n")
+ (setq ede-project-sort-targets-order nil)
+ (mapc (lambda (x)
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ x x))
+ (number-sequence 0 (1- (length (oref proj targets)))))
+ (ede-project-sort-targets-list)
+ (use-local-map widget-keymap)
+ (widget-setup)
+ (goto-char (point-min))))
+
+ (defun ede-project-sort-targets-list ()
+ "Sort the target list while using `ede-project-sort-targets'."
+ (save-excursion
+ (let ((count 0)
+ (targets (oref ede-object-project targets))
+ (inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (goto-char (point-min))
+ (forward-line 2)
+ (delete-region (point) (point-max))
+ (while (< count (length targets))
+ (if (> count 0)
+ (widget-create 'push-button
+ :notify `(lambda (&rest ignore)
+ (let ((cur ede-project-sort-targets-order))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth ,count cur)
+ (1- ,count))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth (1- ,count) cur) ,count))
+ (ede-project-sort-targets-list))
+ " Up ")
+ (widget-insert " "))
+ (if (< count (1- (length targets)))
+ (widget-create 'push-button
+ :notify `(lambda (&rest ignore)
+ (let ((cur ede-project-sort-targets-order))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth ,count cur) (1+ ,count))
+ (add-to-ordered-list
+ 'ede-project-sort-targets-order
+ (nth (1+ ,count) cur) ,count))
+ (ede-project-sort-targets-list))
+ " Down ")
+ (widget-insert " "))
+ (widget-insert (concat " " (number-to-string (1+ count)) ".: "
+ (oref (nth (nth count ede-project-sort-targets-order)
+ targets) name) "\n"))
+ (setq count (1+ count))))))
+
+ ;;; Customization hooks
+ ;;
+ ;; These hooks are used when finishing up a customization.
+ (defmethod eieio-done-customizing ((proj ede-project))
+ "Call this when a user finishes customizing PROJ."
+ (let ((ov eieio-ede-old-variables)
+ (nv (oref proj local-variables)))
+ (setq eieio-ede-old-variables nil)
+ (while ov
+ (if (not (assoc (car (car ov)) nv))
+ (save-excursion
+ (mapc (lambda (b)
+ (set-buffer b)
+ (kill-local-variable (car (car ov))))
+ (ede-project-buffers proj))))
+ (setq ov (cdr ov)))
+ (mapc (lambda (b) (ede-set-project-variables proj b))
+ (ede-project-buffers proj))))
+
+ (defmethod eieio-done-customizing ((target ede-target))
+ "Call this when a user finishes customizing TARGET."
+ nil)
+
+ (defmethod ede-commit-project ((proj ede-project))
+ "Commit any change to PROJ to its file."
+ nil
+ )
+
+ \f
+ ;;; EDE project placeholder methods
+ ;;
+ (defmethod ede-project-force-load ((this ede-project-placeholder))
+ "Make sure the placeholder THIS is replaced with the real thing.
+ Return the new object created in its place."
+ this
+ )
+
+ \f
+ ;;; EDE project target baseline methods.
+ ;;
+ ;; If you are developing a new project type, you need to implement
+ ;; all of these methods, unless, of course, they do not make sense
+ ;; for your particular project.
+ ;;
+ ;; Your targets should inherit from `ede-target', and your project
+ ;; files should inherit from `ede-project'. Create the appropriate
+ ;; methods based on those below.
+
+ (defmethod project-interactive-select-target ((this ede-project-placeholder) prompt)
+ ; checkdoc-params: (prompt)
+ "Make sure placeholder THIS is replaced with the real thing, and pass through."
+ (project-interactive-select-target (ede-project-force-load this) prompt))
+
+ (defmethod project-interactive-select-target ((this ede-project) prompt)
+ "Interactively query for a target that exists in project THIS.
+ Argument PROMPT is the prompt to use when querying the user for a target."
+ (let ((ob (object-assoc-list 'name (oref this targets))))
+ (cdr (assoc (completing-read prompt ob nil t) ob))))
+
+ (defmethod project-add-file ((this ede-project-placeholder) file)
+ ; checkdoc-params: (file)
+ "Make sure placeholder THIS is replaced with the real thing, and pass through."
+ (project-add-file (ede-project-force-load this) file))
+
+ (defmethod project-add-file ((ot ede-target) file)
+ "Add the current buffer into project project target OT.
+ Argument FILE is the file to add."
+ (error "add-file not supported by %s" (object-name ot)))
+
+ (defmethod project-remove-file ((ot ede-target) fnnd)
+ "Remove the current buffer from project target OT.
+ Argument FNND is an argument."
+ (error "remove-file not supported by %s" (object-name ot)))
+
+ (defmethod project-edit-file-target ((ot ede-target))
+ "Edit the target OT associated w/ this file."
+ (find-file (oref (ede-current-project) file)))
+
+ (defmethod project-new-target ((proj ede-project) &rest args)
+ "Create a new target. It is up to the project PROJ to get the name."
+ (error "new-target not supported by %s" (object-name proj)))
+
+ (defmethod project-new-target-custom ((proj ede-project))
+ "Create a new target. It is up to the project PROJ to get the name."
+ (error "New-target-custom not supported by %s" (object-name proj)))
+
+ (defmethod project-delete-target ((ot ede-target))
+ "Delete the current target OT from it's parent project."
+ (error "add-file not supported by %s" (object-name ot)))
+
+ (defmethod project-compile-project ((obj ede-project) &optional command)
+ "Compile the entire current project OBJ.
+ Argument COMMAND is the command to use when compiling."
+ (error "compile-project not supported by %s" (object-name obj)))
+
+ (defmethod project-compile-target ((obj ede-target) &optional command)
+ "Compile the current target OBJ.
+ Argument COMMAND is the command to use for compiling the target."
+ (error "compile-target not supported by %s" (object-name obj)))
+
+ (defmethod project-debug-target ((obj ede-target))
+ "Run the current project target OBJ in a debugger."
+ (error "debug-target not supported by %s" (object-name obj)))
+
+ (defmethod project-make-dist ((this ede-project))
+ "Build a distribution for the project based on THIS project."
+ (error "Make-dist not supported by %s" (object-name this)))
+
+ (defmethod project-dist-files ((this ede-project))
+ "Return a list of files that constitutes a distribution of THIS project."
+ (error "Dist-files is not supported by %s" (object-name this)))
+
+ (defmethod project-rescan ((this ede-project))
+ "Rescan the EDE proj project THIS."
+ (error "Rescanning a project is not supported by %s" (object-name this)))
+ \f
+ ;;; Default methods for EDE classes
+ ;;
+ ;; These are methods which you might want to override, but there is
+ ;; no need to in most situations because they are either a) simple, or
+ ;; b) cosmetic.
+
+ (defmethod ede-name ((this ede-target))
+ "Return the name of THIS targt."
+ (oref this name))
+
+ (defmethod ede-target-name ((this ede-target))
+ "Return the name of THIS target, suitable for make or debug style commands."
+ (oref this name))
+
+ (defmethod ede-name ((this ede-project))
+ "Return a short-name for THIS project file.
+ Do this by extracting the lowest directory name."
+ (oref this name))
+
+ (defmethod ede-description ((this ede-project))
+ "Return a description suitable for the minibuffer about THIS."
+ (format "Project %s: %d subprojects, %d targets."
+ (ede-name this) (length (oref this subproj))
+ (length (oref this targets))))
+
+ (defmethod ede-description ((this ede-target))
+ "Return a description suitable for the minibuffer about THIS."
+ (format "Target %s: with %d source files."
+ (ede-name this) (length (oref this source))))
+
+ (defmethod ede-want-file-p ((this ede-target) file)
+ "Return non-nil if THIS target wants FILE."
+ ;; By default, all targets reference the source object, and let it decide.
+ (let ((src (ede-target-sourcecode this)))
+ (while (and src (not (ede-want-file-p (car src) file)))
+ (setq src (cdr src)))
+ src))
+
+ (defmethod ede-want-file-source-p ((this ede-target) file)
+ "Return non-nil if THIS target wants FILE."
+ ;; By default, all targets reference the source object, and let it decide.
+ (let ((src (ede-target-sourcecode this)))
+ (while (and src (not (ede-want-file-source-p (car src) file)))
+ (setq src (cdr src)))
+ src))
+
+ (defun ede-header-file ()
+ "Return the header file for the current buffer.
+ Not all buffers need headers, so return nil if no applicable."
+ (if ede-object
+ (ede-buffer-header-file ede-object (current-buffer))
+ nil))
+
+ (defmethod ede-buffer-header-file ((this ede-project) buffer)
+ "Return nil, projects don't have header files."
+ nil)
+
+ (defmethod ede-buffer-header-file ((this ede-target) buffer)
+ "There are no default header files in EDE.
+ Do a quick check to see if there is a Header tag in this buffer."
+ (save-excursion
+ (set-buffer buffer)
+ (if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t)
+ (buffer-substring-no-properties (match-beginning 1)
+ (match-end 1))
+ (let ((src (ede-target-sourcecode this))
+ (found nil))
+ (while (and src (not found))
+ (setq found (ede-buffer-header-file (car src) (buffer-file-name))
+ src (cdr src)))
+ found))))
+
+ (defun ede-documentation-files ()
+ "Return the documentation files for the current buffer.
+ Not all buffers need documentations, so return nil if no applicable.
+ Some projects may have multiple documentation files, so return a list."
+ (if ede-object
+ (ede-buffer-documentation-files ede-object (current-buffer))
+ nil))
+
+ (defmethod ede-buffer-documentation-files ((this ede-project) buffer)
+ "Return all documentation in project THIS based on BUFFER."
+ ;; Find the info node.
+ (ede-documentation this))
+
+ (defmethod ede-buffer-documentation-files ((this ede-target) buffer)
+ "Check for some documentation files for THIS.
+ Also do a quick check to see if there is a Documentation tag in this BUFFER."
+ (save-excursion
+ (set-buffer buffer)
+ (if (re-search-forward "::Documentation:: \\([a-zA-Z0-9.]+\\)" nil t)
+ (buffer-substring-no-properties (match-beginning 1)
+ (match-end 1))
+ ;; Check the master project
+ (let ((cp (ede-toplevel)))
+ (ede-buffer-documentation-files cp (current-buffer))))))
+
+ (defmethod ede-documentation ((this ede-project))
+ "Return a list of files that provides documentation.
+ Documentation is not for object THIS, but is provided by THIS for other
+ files in the project."
+ (let ((targ (oref this targets))
+ (proj (oref this subproj))
+ (found nil))
+ (while targ
+ (setq found (append (ede-documentation (car targ)) found)
+ targ (cdr targ)))
+ (while proj
+ (setq found (append (ede-documentation (car proj)) found)
+ proj (cdr proj)))
+ found))
+
+ (defmethod ede-documentation ((this ede-target))
+ "Return a list of files that provides documentation.
+ Documentation is not for object THIS, but is provided by THIS for other
+ files in the project."
+ nil)
+
+ (defun ede-html-documentation-files ()
+ "Return a list of HTML documentation files associated with this project."
+ (ede-html-documentation (ede-toplevel))
+ )
+
+ (defmethod ede-html-documentation ((this ede-project))
+ "Return a list of HTML files provided by project THIS."
+
+ )
+
+ (defun ede-ecb-project-paths ()
+ "Return a list of all paths for all active EDE projects.
+ This functions is meant for use with ECB."
+ (let ((p ede-projects)
+ (d nil))
+ (while p
+ (setq d (cons (file-name-directory (oref (car p) file))
+ d)
+ p (cdr p)))
+ d))
+ \f
+ ;;; EDE project-autoload methods
+ ;;
+ (defmethod ede-dir-to-projectfile ((this ede-project-autoload) dir)
+ "Return a full file name of project THIS found in DIR.
+ Return nil if the project file does not exist."
+ (let* ((d (file-name-as-directory dir))
+ (root (ede-project-root-directory this d))
+ (pf (oref this proj-file))
+ (f (cond ((stringp pf)
+ (expand-file-name pf (or root d)))
+ ((and (symbolp pf) (fboundp pf))
+ (funcall pf (or root d)))))
+ )
+ (when (and f (file-exists-p f))
+ f)))
+
+ ;;; EDE basic functions
+ ;;
+ (defun ede-add-project-to-global-list (proj)
+ "Add the project PROJ to the master list of projects.
+ On success, return the added project."
+ (when (not proj)
+ (error "No project created to add to master list"))
+ (when (not (eieio-object-p proj))
+ (error "Attempt to add Non-object to master project list"))
+ (when (not (obj-of-class-p proj ede-project-placeholder))
+ (error "Attempt to add a non-project to the ede projects list"))
+ (add-to-list 'ede-projects proj)
+ proj)
+
+ (defun ede-load-project-file (dir &optional rootreturn)
+ "Project file independent way to read a project in from DIR.
+ Optional ROOTRETURN will return the root project for DIR."
+ ;; Only load if something new is going on. Flush the dirhash.
+ (ede-project-directory-remove-hash dir)
+ ;; Do the load
+ ;;(message "EDE LOAD : %S" file)
+ (let* ((file dir)
+ (path (expand-file-name (file-name-directory file)))
+ (pfc (ede-directory-project-p path))
+ (toppath nil)
+ (o nil))
+ (cond
+ ((not pfc)
+ ;; @TODO - Do we really need to scan? Is this a waste of time?
+ ;; Scan upward for a the next project file style.
+ (let ((p path))
+ (while (and p (not (ede-directory-project-p p)))
+ (setq p (ede-up-directory p)))
+ (if p (ede-load-project-file p)
+ nil)
+ ;; recomment as we go
+ ;nil
+ ))
+ ;; Do nothing if we are buiding an EDE project already
+ (ede-constructing
+ nil)
+ ;; Load in the project in question.
+ (t
+ (setq toppath (ede-toplevel-project path))
+ ;; We found the top-most directory. Check to see if we already
+ ;; have an object defining it's project.
+ (setq pfc (ede-directory-project-p toppath t))
+
+ ;; See if it's been loaded before
+ (setq o (object-assoc (ede-dir-to-projectfile pfc toppath) 'file
+ ede-projects))
+ (if (not o)
+ ;; If not, get it now.
+ (let ((ede-constructing t))
+ (setq o (funcall (oref pfc load-type) toppath))
+ (when (not o)
+ (error "Project type error: :load-type failed to create a project"))
+ (ede-add-project-to-global-list o)))
+
+ ;; Return the found root project.
+ (when rootreturn (set rootreturn o))
+
+ (let (tocheck found)
+ ;; Now find the project file belonging to FILE!
+ (setq tocheck (list o))
+ (setq file (ede-dir-to-projectfile pfc (expand-file-name path)))
+ (while (and tocheck (not found))
+ (let ((newbits nil))
+ (when (car tocheck)
+ (if (string= file (oref (car tocheck) file))
+ (setq found (car tocheck)))
+ (setq newbits (oref (car tocheck) subproj)))
+ (setq tocheck
+ (append (cdr tocheck) newbits))))
+ (if (not found)
+ (message "No project for %s, but passes project-p test" file)
+ ;; Now that the file has been reset inside the project object, do
+ ;; the cache maintenance.
+ (setq ede-project-cache-files
+ (delete (oref found file) ede-project-cache-files)))
+ found)))))
+
+ (defun ede-parent-project (&optional obj)
+ "Return the project belonging to the parent directory.
+ nil if there is no previous directory.
+ Optional argument OBJ is an object to find the parent of."
+ (let* ((proj (or obj ede-object-project)) ;; Current project.
+ (root (if obj (ede-project-root obj)
+ ede-object-root-project)))
+ ;; This case is a SHORTCUT if the project has defined
+ ;; a way to calculate the project root.
+ (if (and root proj (eq root proj))
+ nil ;; we are at the root.
+ ;; Else, we may have a nil proj or root.
+ (let* ((thisdir (if obj (oref obj directory)
+ default-directory))
+ (updir (ede-up-directory thisdir)))
+ (when updir
+ ;; If there was no root, perhaps we can derive it from
+ ;; updir now.
+ (let ((root (or root (ede-directory-get-toplevel-open-project updir))))
+ (or
+ ;; This lets us find a subproject under root based on updir.
+ (and root
+ (ede-find-subproject-for-directory root updir))
+ ;; Try the all structure based search.
+ (ede-directory-get-open-project updir)
+ ;; Load up the project file as a last resort.
+ ;; Last resort since it uses file-truename, and other
+ ;; slow features.
+ (and (ede-directory-project-p updir)
+ (ede-load-project-file
+ (file-name-as-directory updir))))))))))
+
+ (defun ede-current-project (&optional dir)
+ "Return the current project file.
+ If optional DIR is provided, get the project for DIR instead."
+ (let ((ans nil))
+ ;; If it matches the current directory, do we have a pre-existing project?
+ (when (and (or (not dir) (string= dir default-directory))
+ ede-object-project)
+ (setq ans ede-object-project)
+ )
+ ;; No current project.
+ (when (not ans)
+ (let* ((ldir (or dir default-directory)))
+ (setq ans (ede-directory-get-open-project ldir))
+ (or ans
+ ;; No open project, if this dir pass project-p, then load.
+ (when (ede-directory-project-p ldir)
+ (setq ans (ede-load-project-file ldir))))))
+ ;; Return what we found.
+ ans))
+
+ (defun ede-buffer-object (&optional buffer)
+ "Return the target object for BUFFER.
+ This function clears cached values and recalculates."
+ (save-excursion
+ (if (not buffer) (setq buffer (current-buffer)))
+ (set-buffer buffer)
+ (setq ede-object nil)
+ (let ((po (ede-current-project)))
+ (if po (setq ede-object (ede-find-target po buffer))))
+ (if (= (length ede-object) 1)
+ (setq ede-object (car ede-object)))
+ ede-object))
+
+ (defmethod ede-target-in-project-p ((proj ede-project) target)
+ "Is PROJ the parent of TARGET?
+ If TARGET belongs to a subproject, return that project file."
+ (if (and (slot-boundp proj 'targets)
+ (memq target (oref proj targets)))
+ proj
+ (let ((s (oref proj subproj))
+ (ans nil))
+ (while (and s (not ans))
+ (setq ans (ede-target-in-project-p (car s) target))
+ (setq s (cdr s)))
+ ans)))
+
+ (defun ede-target-parent (target)
+ "Return the project which is the parent of TARGET.
+ It is recommended you track the project a different way as this function
+ could become slow in time."
+ ;; @todo - use ede-object-project as a starting point.
+ (let ((ans nil) (projs ede-projects))
+ (while (and (not ans) projs)
+ (setq ans (ede-target-in-project-p (car projs) target)
+ projs (cdr projs)))
+ ans))
+
+ (defun ede-maybe-checkout (&optional buffer)
+ "Check BUFFER out of VC if necessary."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (if (and buffer-read-only vc-mode
+ (y-or-n-p "Checkout Makefile.am from VC? "))
+ (vc-toggle-read-only))))
+
+ (defmethod ede-find-target ((proj ede-project) buffer)
+ "Fetch the target in PROJ belonging to BUFFER or nil."
+ (save-excursion
+ (set-buffer buffer)
+ (or ede-object
+ (if (ede-buffer-mine proj buffer)
+ proj
+ (let ((targets (oref proj targets))
+ (f nil))
+ (while targets
+ (if (ede-buffer-mine (car targets) buffer)
+ (setq f (cons (car targets) f)))
+ (setq targets (cdr targets)))
+ f)))))
+
+ (defmethod ede-target-buffer-in-sourcelist ((this ede-target) buffer source)
+ "Return non-nil if object THIS is in BUFFER to a SOURCE list.
+ Handles complex path issues."
+ (member (ede-convert-path this (buffer-file-name buffer)) source))
+
+ (defmethod ede-buffer-mine ((this ede-project) buffer)
+ "Return non-nil if object THIS lays claim to the file in BUFFER."
+ nil)
+
+ (defmethod ede-buffer-mine ((this ede-target) buffer)
+ "Return non-nil if object THIS lays claim to the file in BUFFER."
+ (condition-case nil
+ (ede-target-buffer-in-sourcelist this buffer (oref this source))
+ ;; An error implies a bad match.
+ (error nil)))
+
+ \f
+ ;;; Project mapping
+ ;;
+ (defun ede-project-buffers (project)
+ "Return a list of all active buffers controlled by PROJECT.
+ This includes buffers controlled by a specific target of PROJECT."
+ (let ((bl (buffer-list))
+ (pl nil))
+ (while bl
+ (save-excursion
+ (set-buffer (car bl))
+ (if (and ede-object (eq (ede-current-project) project))
+ (setq pl (cons (car bl) pl))))
+ (setq bl (cdr bl)))
+ pl))
+
+ (defun ede-target-buffers (target)
+ "Return a list of buffers that are controlled by TARGET."
+ (let ((bl (buffer-list))
+ (pl nil))
+ (while bl
+ (save-excursion
+ (set-buffer (car bl))
+ (if (if (listp ede-object)
+ (memq target ede-object)
+ (eq ede-object target))
+ (setq pl (cons (car bl) pl))))
+ (setq bl (cdr bl)))
+ pl))
+
+ (defun ede-buffers ()
+ "Return a list of all buffers controled by an EDE object."
+ (let ((bl (buffer-list))
+ (pl nil))
+ (while bl
+ (save-excursion
+ (set-buffer (car bl))
+ (if ede-object
+ (setq pl (cons (car bl) pl))))
+ (setq bl (cdr bl)))
+ pl))
+
+ (defun ede-map-buffers (proc)
+ "Execute PROC on all buffers controled by EDE."
+ (mapcar proc (ede-buffers)))
+
+ (defmethod ede-map-project-buffers ((this ede-project) proc)
+ "For THIS, execute PROC on all buffers belonging to THIS."
+ (mapcar proc (ede-project-buffers this)))
+
+ (defmethod ede-map-target-buffers ((this ede-target) proc)
+ "For THIS, execute PROC on all buffers belonging to THIS."
+ (mapcar proc (ede-target-buffers this)))
+
+ ;; other types of mapping
+ (defmethod ede-map-subprojects ((this ede-project) proc)
+ "For object THIS, execute PROC on all direct subprojects.
+ This function does not apply PROC to sub-sub projects.
+ See also `ede-map-all-subprojects'."
+ (mapcar proc (oref this subproj)))
+
+ (defmethod ede-map-all-subprojects ((this ede-project) allproc)
+ "For object THIS, execute PROC on THIS and all subprojects.
+ This function also applies PROC to sub-sub projects.
+ See also `ede-map-subprojects'."
+ (apply 'append
+ (list (funcall allproc this))
+ (ede-map-subprojects
+ this
+ (lambda (sp)
+ (ede-map-all-subprojects sp allproc))
+ )))
+
+ ;; (ede-map-all-subprojects (ede-load-project-file "../semantic/") (lambda (sp) (oref sp file)))
+
+ (defmethod ede-map-targets ((this ede-project) proc)
+ "For object THIS, execute PROC on all targets."
+ (mapcar proc (oref this targets)))
+
+ (defmethod ede-map-any-target-p ((this ede-project) proc)
+ "For project THIS, map PROC to all targets and return if any non-nil.
+ Return the first non-nil value returned by PROC."
-\f
-;;; Lame stuff
-;;
-(defun ede-or (arg)
- "Do `or' like stuff to ARG because you can't apply `or'."
- (while (and arg (not (car arg)))
- (setq arg (cdr arg)))
- arg)
-
++ (eval (cons 'or (ede-map-targets this proc))))
+
+ \f
+ ;;; Some language specific methods.
+ ;;
+ ;; These items are needed by ede-cpp-root to add better support for
+ ;; configuring items for Semantic.
+ (defun ede-apply-preprocessor-map ()
+ "Apply preprocessor tables onto the current buffer."
+ (when (and ede-object (boundp 'semantic-lex-spp-macro-symbol-obarray))
+ (let ((map (ede-preprocessor-map ede-object)))
+ (when map
+ ;; We can't do a require for the below symbol.
+ (setq semantic-lex-spp-macro-symbol-obarray
+ (semantic-lex-make-spp-table map))
+ ))))
+
+ (defmethod ede-system-include-path ((this ede-project))
+ "Get the system include path used by project THIS."
+ nil)
+
+ (defmethod ede-preprocessor-map ((this ede-project))
+ "Get the pre-processor map for project THIS."
+ nil)
+
+ (defmethod ede-system-include-path ((this ede-target))
+ "Get the system include path used by project THIS."
+ nil)
+
+ (defmethod ede-preprocessor-map ((this ede-target))
+ "Get the pre-processor map for project THIS."
+ nil)
+
+ \f
+ ;;; Project-local variables
+ ;;
+ (defun ede-make-project-local-variable (variable &optional project)
+ "Make VARIABLE project-local to PROJECT."
+ (if (not project) (setq project (ede-current-project)))
+ (if (assoc variable (oref project local-variables))
+ nil
+ (oset project local-variables (cons (list variable)
+ (oref project local-variables)))
+ (mapcar (lambda (b) (save-excursion
+ (set-buffer b)
+ (make-local-variable variable)))
+ (ede-project-buffers project))))
+
+ (defmethod ede-set-project-variables ((project ede-project) &optional buffer)
+ "Set variables local to PROJECT in BUFFER."
+ (if (not buffer) (setq buffer (current-buffer)))
+ (save-excursion
+ (set-buffer buffer)
+ (mapcar (lambda (v)
+ (make-local-variable (car v))
+ ;; set it's value here?
+ (set (car v) (cdr v))
+ )
+ (oref project local-variables))))
+
+ (defun ede-set (variable value &optional proj)
+ "Set the project local VARIABLE to VALUE.
+ If VARIABLE is not project local, just use set."
+ (let ((p (or proj (ede-current-project)))
+ a)
+ (if (and p (setq a (assoc variable (oref p local-variables))))
+ (progn
+ (setcdr a value)
+ (mapc (lambda (b) (save-excursion
+ (set-buffer b)
+ (set variable value)))
+ (ede-project-buffers p)))
+ (set variable value))
+ (ede-commit-local-variables p))
+ value)
+
+ (defmethod ede-commit-local-variables ((proj ede-project))
+ "Commit change to local variables in PROJ."
+ nil)
+
+ \f
+ ;;; Accessors for more complex types where oref is inappropriate.
+ ;;
+ (defmethod ede-target-sourcecode ((this ede-target))
+ "Return the sourcecode objects which THIS permits."
+ (let ((sc (oref this sourcetype))
+ (rs nil))
+ (while (and (listp sc) sc)
+ (setq rs (cons (symbol-value (car sc)) rs)
+ sc (cdr sc)))
+ rs))
+
+ \f
+ ;;; Debugging.
+
+ (defun ede-adebug-project ()
+ "Run adebug against the current ede project.
+ Display the results as a debug list."
+ (interactive)
+ (require 'data-debug)
+ (when (ede-current-project)
+ (data-debug-new-buffer "*Analyzer ADEBUG*")
+ (data-debug-insert-object-slots (ede-current-project) "")
+ ))
+
+ (defun ede-adebug-project-parent ()
+ "Run adebug against the current ede parent project.
+ Display the results as a debug list."
+ (interactive)
+ (require 'data-debug)
+ (when (ede-parent-project)
+ (data-debug-new-buffer "*Analyzer ADEBUG*")
+ (data-debug-insert-object-slots (ede-parent-project) "")
+ ))
+
+ (defun ede-adebug-project-root ()
+ "Run adebug against the current ede parent project.
+ Display the results as a debug list."
+ (interactive)
+ (require 'data-debug)
+ (when (ede-toplevel)
+ (data-debug-new-buffer "*Analyzer ADEBUG*")
+ (data-debug-insert-object-slots (ede-toplevel) "")
+ ))
+ \f
+ ;;; Hooks & Autoloads
+ ;;
+ ;; These let us watch various activities, and respond apropriatly.
+
+ ;; (add-hook 'edebug-setup-hook
+ ;; (lambda ()
+ ;; (def-edebug-spec ede-with-projectfile
+ ;; (form def-body))))
+
+ (provide 'ede)
+
+ ;; Include this last because it depends on ede.
+ (require 'ede/files)
+
+ ;; If this does not occur after the provide, we can get a recursive
+ ;; load. Yuck!
+ (if (featurep 'speedbar)
+ (ede-speedbar-file-setup)
+ (add-hook 'speedbar-load-hook 'ede-speedbar-file-setup))
+
+ ;;; ede.el ends here
--- /dev/null
- (io (ede-or (mapcar 'ede-compiler-intermediate-objects-p c)))
+ ;;; ede-pmake.el --- EDE Generic Project Makefile code generator.
+
+ ;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ ;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: project, make
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Code generator for Makefiles.
+ ;;
+ ;; Here is how it should work:
+ ;; 1) Collect information about the project and targets
+ ;; 2) Insert header into the Makefile
+ ;; 3) Insert basic variables (target/source)
+ ;; 4) Conditional
+ ;; a) Makefile
+ ;; 1) Insert support variables (compiler variables, etc)
+ ;; 2) Insert VERSION and DISTDIR
+ ;; 3) Specify top build dir if necessary
+ ;; 4) Specify compile/link commands (c, etc)
+ ;; 5) Specify dependency files
+ ;; 6) Specify all: target
+ ;; 7) Include dependency files
+ ;; 8) Insert commonized target specify rules
+ ;; 9) Insert clean: and dist: rules
+ ;; b) Automake file
+ ;; 1) Insert distribution source variables for targets
+ ;; 2) Insert user requested rules
+
+ (require 'ede/proj)
+ (require 'ede/proj-obj)
+ (require 'ede/proj-comp)
+
+ (declare-function ede-srecode-setup "ede/srecode")
+ (declare-function ede-srecode-insert "ede/srecode")
+
+ ;;; Code:
+ (defmethod ede-proj-makefile-create ((this ede-proj-project) mfilename)
+ "Create a Makefile for all Makefile targets in THIS.
+ MFILENAME is the makefile to generate."
+ (require 'ede/srecode)
+ (let ((mt nil)
+ (isdist (string= mfilename (ede-proj-dist-makefile this)))
+ (depth 0)
+ (orig-buffer nil)
+ (buff-to-kill nil)
+ )
+ ;; Find out how deep this project is.
+ (let ((tmp this))
+ (while (setq tmp (ede-parent-project tmp))
+ (setq depth (1+ depth))))
+ ;; Collect the targets that belong in a makefile.
+ (mapc
+ (lambda (obj)
+ (if (and (obj-of-class-p obj 'ede-proj-target-makefile)
+ (string= (oref obj makefile) mfilename))
+ (setq mt (cons obj mt))))
+ (oref this targets))
+ ;; Fix the order so things compile in the right direction.
+ (setq mt (nreverse mt))
+ ;; Add in the header part of the Makefile*
+ (save-excursion
+ (setq orig-buffer (get-file-buffer mfilename))
+ (set-buffer (setq buff-to-kill (find-file-noselect mfilename)))
+ (goto-char (point-min))
+ (if (and
+ (not (eobp))
+ (not (looking-at "# Automatically Generated \\w+ by EDE.")))
+ (if (not (y-or-n-p (format "Really replace %s? " mfilename)))
+ (error "Not replacing Makefile"))
+ (message "Replace EDE Makefile"))
+ (erase-buffer)
+ (ede-srecode-setup)
+ ;; Insert a giant pile of stuff that is common between
+ ;; one of our Makefiles, and a Makefile.in
+ (ede-srecode-insert
+ "file:ede-empty"
+ "MAKETYPE"
+ (with-slots (makefile-type) this
+ (cond ((eq makefile-type 'Makefile) "make")
+ ((eq makefile-type 'Makefile.in) "autoconf")
+ ((eq makefile-type 'Makefile.am) "automake")
+ (t (error ":makefile-type in project invalid")))))
+
+ ;; Just this project's variables
+ (ede-proj-makefile-insert-variables this)
+
+ ;; Space
+ (insert "\n")
+
+ (cond
+ ((eq (oref this makefile-type) 'Makefile)
+ ;; Make sure the user has the right kind of make
+ (ede-make-check-version)
+
+ (let* ((targ (if isdist (oref this targets) mt))
+ (sp (oref this subproj))
+ (df (apply 'append
+ (mapcar (lambda (tg)
+ (ede-proj-makefile-dependency-files tg))
+ targ))))
+ ;; Distribution variables
+ (ede-compiler-begin-unique
+ (mapc 'ede-proj-makefile-insert-variables targ))
+ ;; Only add the distribution stuff in when depth != 0
+ (let ((top (ede-toplevel this))
+ (tmp this)
+ (subdir ""))
+ (insert "VERSION=" (oref top version) "\n"
+ "DISTDIR=$(top)" (oref top name) "-$(VERSION)")
+ (while (ede-parent-project tmp)
+ (setq subdir
+ (concat
+ "/"
+ (file-name-nondirectory
+ (directory-file-name
+ (file-name-directory (oref tmp file))))
+ subdir)
+ tmp (ede-parent-project tmp)))
+ (insert subdir "\n"))
+ ;; Some built in variables for C code
+ (if df
+ (let ((tc depth))
+ (insert "top_builddir = ")
+ (while (/= 0 tc)
+ (setq tc (1- tc))
+ (insert "..")
+ (if (/= tc 0) (insert "/")))
+ (insert "\n")))
+ (insert "\n")
+ ;; Create a variable with all the dependency files to include
+ ;; These methods borrowed from automake.
+ (if (and (oref this automatic-dependencies) df)
+ (progn
+ (insert "DEP_FILES="
+ (mapconcat (lambda (f)
+ (concat ".deps/"
+ (file-name-nondirectory
+ (file-name-sans-extension
+ f)) ".P"))
+ df " "))))
+ ;;
+ ;; Insert ALL Rule
+ ;;
+ (insert "\n\nall:")
+ (mapc (lambda (c)
+ (if (and (slot-exists-p c 'partofall) (oref c partofall))
+ ;; Only insert this rule if it is a part of ALL.
+ (insert " " (ede-proj-makefile-target-name c))))
+ targ)
+ (mapc (lambda (c)
+ (insert " " (ede-name c))
+ )
+ sp)
+ (insert "\n\n")
+ ;;
+ ;; Add in the include files
+ ;;
+ (mapc (lambda (c)
+ (insert "include " c "\n\n"))
+ (oref this include-file))
+ ;; Some C inference rules
+ ;; Dependency rules borrowed from automake.
+ ;;
+ ;; NOTE: This is GNU Make specific.
+ (if (and (oref this automatic-dependencies) df)
+ (insert "DEPS_MAGIC := $(shell mkdir .deps > /dev/null "
+ "2>&1 || :)\n"
+ "-include $(DEP_FILES)\n\n"))
+ ;;
+ ;; General makefile rules stored in the individual targets
+ ;;
+ (ede-compiler-begin-unique
+ (ede-proj-makefile-insert-rules this)
+ (mapc 'ede-proj-makefile-insert-rules targ))
+ ;;
+ ;; phony targets for sub projects
+ ;;
+ (mapc 'ede-proj-makefile-insert-subproj-rules sp)
+ ;;
+ ;; Distribution rules such as CLEAN and DIST
+ ;;
+ (when isdist
+ (ede-proj-makefile-tags this mt)
+ (ede-proj-makefile-insert-dist-rules this)))
+ (save-buffer))
+ ((eq (oref this makefile-type) 'Makefile.in)
+ (error "Makefile.in is not supported"))
+ ((eq (oref this makefile-type) 'Makefile.am)
+ (require 'ede/pconf)
+ ;; Distribution variables
+ (let ((targ (if isdist (oref this targets) mt)))
+ (ede-compiler-begin-unique
+ (mapc 'ede-proj-makefile-insert-automake-pre-variables targ))
+ (ede-compiler-begin-unique
+ (mapc 'ede-proj-makefile-insert-source-variables targ))
+ (ede-compiler-begin-unique
+ (mapc 'ede-proj-makefile-insert-automake-post-variables targ))
+ (ede-compiler-begin-unique
+ (ede-proj-makefile-insert-user-rules this))
+ (insert "\n# End of Makefile.am\n")
+ (save-buffer))
+ )
+ (t (error "Unknown makefile type when generating Makefile")))
+ ;; Put the cursor in a nice place
+ (goto-char (point-min)))
+ ;; If we have an original buffer, then don't kill it.
+ (when (not orig-buffer)
+ (kill-buffer buff-to-kill))
+ ))
+
+ ;;; VARIABLE insertion
+ ;;
+ (defun ede-pmake-end-of-variable ()
+ "Move to the end of the variable declaration under point."
+ (end-of-line)
+ (while (= (preceding-char) ?\\)
+ (forward-char 1)
+ (end-of-line))
+ )
+
+ (defmacro ede-pmake-insert-variable-shared (varname &rest body)
+ "Add VARNAME into the current Makefile.
+ Execute BODY in a location where a value can be placed."
+ `(let ((addcr t) (v ,varname))
+ (if (re-search-backward (concat "^" v "\\s-*=") nil t)
+ (progn
+ (ede-pmake-end-of-variable)
+ (if (< (current-column) 40)
+ (if (and (/= (preceding-char) ?=)
+ (/= (preceding-char) ? ))
+ (insert " "))
+ (insert "\\\n "))
+ (setq addcr nil))
+ (insert v "="))
+ ,@body
+ (if addcr (insert "\n"))
+ (goto-char (point-max))))
+ (put 'ede-pmake-insert-variable-shared 'lisp-indent-function 1)
+
+ ;;; SOURCE VARIABLE NAME CONSTRUCTION
+
+ (defsubst ede-pmake-varname (obj)
+ "Convert OBJ into a variable name name.
+ Change . to _ in the variable name."
+ (let ((name (oref obj name)))
+ (while (string-match "\\." name)
+ (setq name (replace-match "_" nil t name)))
+ name))
+
+ (defmethod ede-proj-makefile-sourcevar ((this ede-proj-target))
+ "Return the variable name for THIS's sources."
+ (concat (ede-pmake-varname this) "_YOU_FOUND_A_BUG"))
+
+ ;;; DEPENDENCY FILE GENERATOR LISTS
+ ;;
+ (defmethod ede-proj-makefile-dependency-files ((this ede-proj-target))
+ "Return a list of source files to convert to dependencies.
+ Argument THIS is the target to get sources from."
+ nil)
+
+ ;;; GENERIC VARIABLES
+ ;;
+ (defmethod ede-proj-makefile-configuration-variables ((this ede-proj-project)
+ configuration)
+ "Return a list of configuration variables from THIS.
+ Use CONFIGURATION as the current configuration to query."
+ (cdr (assoc configuration (oref this configuration-variables))))
+
+ (defmethod ede-proj-makefile-insert-variables-new ((this ede-proj-project))
+ "Insert variables needed by target THIS.
+
+ NOTE: Not yet in use! This is part of an SRecode conversion of
+ EDE that is in progress."
+ ; (let ((conf-table (ede-proj-makefile-configuration-variables
+ ; this (oref this configuration-default)))
+ ; (conf-done nil))
+ ;
+ ; (ede-srecode-insert-with-dictionary
+ ; "declaration:ede-vars"
+ ;
+ ; ;; Insert all variables, and augment them with details from
+ ; ;; the current configuration.
+ ; (mapc (lambda (c)
+ ;
+ ; (let ((ldict (srecode-dictionary-add-section-dictionary
+ ; dict "VARIABLE"))
+ ; )
+ ; (srecode-dictionary-set-value ldict "NAME" (car c))
+ ; (if (assoc (car c) conf-table)
+ ; (let ((vdict (srecode-dictionary-add-section-dictionary
+ ; ldict "VALUE")))
+ ; (srecode-dictionary-set-value
+ ; vdict "VAL" (cdr (assoc (car c) conf-table)))
+ ; (setq conf-done (cons (car c) conf-done))))
+ ; (let ((vdict (srecode-dictionary-add-section-dictionary
+ ; ldict "VALUE")))
+ ; (srecode-dictionary-set-value vdict "VAL" (cdr c))))
+ ; )
+ ;
+ ; (oref this variables))
+ ;
+ ; ;; Add in all variables from the configuration not allready covered.
+ ; (mapc (lambda (c)
+ ;
+ ; (if (member (car c) conf-done)
+ ; nil
+ ; (let* ((ldict (srecode-dictionary-add-section-dictionary
+ ; dict "VARIABLE"))
+ ; (vdict (srecode-dictionary-add-section-dictionary
+ ; ldict "VALUE"))
+ ; )
+ ; (srecode-dictionary-set-value ldict "NAME" (car c))
+ ; (srecode-dictionary-set-value vdict "VAL" (cdr c))))
+ ; )
+ ;
+ ; conf-table)
+ ;
+
+ ;; @TODO - finish off this function, and replace the below fcn
+
+ ; ))
+ )
+
+ (defmethod ede-proj-makefile-insert-variables ((this ede-proj-project))
+ "Insert variables needed by target THIS."
+ (let ((conf-table (ede-proj-makefile-configuration-variables
+ this (oref this configuration-default)))
+ (conf-done nil))
+ ;; Insert all variables, and augment them with details from
+ ;; the current configuration.
+ (mapc (lambda (c)
+ (insert (car c) "=")
+ (if (assoc (car c) conf-table)
+ (progn
+ (insert (cdr (assoc (car c) conf-table)) " ")
+ (setq conf-done (cons (car c) conf-done))))
+ (insert (cdr c) "\n"))
+ (oref this variables))
+ ;; Add in all variables from the configuration not allready covered.
+ (mapc (lambda (c)
+ (if (member (car c) conf-done)
+ nil
+ (insert (car c) "=" (cdr c) "\n")))
+ conf-table))
+ (let* ((top "")
+ (tmp this))
+ (while (ede-parent-project tmp)
+ (setq tmp (ede-parent-project tmp)
+ top (concat "../" top)))
+ (insert "\ntop=" top))
+ (insert "\nede_FILES=" (file-name-nondirectory (oref this file)) " "
+ (file-name-nondirectory (ede-proj-dist-makefile this)) "\n"))
+
+ (defmethod ede-proj-makefile-insert-source-variables ((this ede-proj-target)
+ &optional
+ moresource)
+ "Insert the source variables needed by THIS.
+ Optional argument MORESOURCE is a list of additional sources to add to the
+ sources variable."
+ (let ((sv (ede-proj-makefile-sourcevar this)))
+ ;; This variable may be shared between targets
+ (ede-pmake-insert-variable-shared (cond ((listp sv) (car sv))
+ (t sv))
+ (insert (mapconcat (lambda (a) a) (oref this source) " "))
+ (if moresource
+ (insert " \\\n " (mapconcat (lambda (a) a) moresource " ") "")))))
+
+ (defmethod ede-proj-makefile-insert-variables ((this ede-proj-target) &optional
+ moresource)
+ "Insert variables needed by target THIS.
+ Optional argument MORESOURCE is a list of additional sources to add to the
+ sources variable."
+ (ede-proj-makefile-insert-source-variables this moresource)
+ )
+
+ (defmethod ede-proj-makefile-configuration-variables ((this ede-proj-target-makefile)
+ configuration)
+ "Return a list of configuration variables from THIS.
+ Use CONFIGURATION as the current configuration to query."
+ (cdr (assoc configuration (oref this configuration-variables))))
+
+ (defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile)
+ &optional moresource)
+ "Insert variables needed by target THIS.
+ Optional argument MORESOURCE is a list of additional sources to add to the
+ sources variable."
+ (call-next-method)
+ (let* ((proj (ede-target-parent this))
+ (conf-table (ede-proj-makefile-configuration-variables
+ this (oref proj configuration-default)))
+ (conf-done nil)
+ )
+ ;; Add in all variables from the configuration not allready covered.
+ (mapc (lambda (c)
+ (if (member (car c) conf-done)
+ nil
+ (insert (car c) "=" (cdr c) "\n")))
+ conf-table))
+ (let ((comp (ede-proj-compilers this))
+ (link (ede-proj-linkers this))
+ (name (ede-proj-makefile-target-name this))
+ (src (oref this source)))
+ (while comp
+ (ede-compiler-only-once (car comp)
+ (ede-proj-makefile-insert-object-variables (car comp) name src)
+ (ede-proj-makefile-insert-variables (car comp)))
+ (setq comp (cdr comp)))
+ (while link
+ (ede-linker-only-once (car link)
+ (ede-proj-makefile-insert-variables (car link)))
+ (setq link (cdr link)))))
+
+ (defmethod ede-proj-makefile-insert-automake-pre-variables
+ ((this ede-proj-target))
+ "Insert variables needed by target THIS in Makefile.am before SOURCES."
+ nil)
+
+ (defmethod ede-proj-makefile-insert-automake-post-variables
+ ((this ede-proj-target))
+ "Insert variables needed by target THIS in Makefile.am after SOURCES."
+ nil)
+
+ ;;; GARBAGE PATTERNS
+ ;;
+ (defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-project))
+ "Return a list of patterns that are considered garbage to THIS.
+ These are removed with make clean."
+ (let ((mc (ede-map-targets
+ this (lambda (c) (ede-proj-makefile-garbage-patterns c))))
+ (uniq nil))
+ (setq mc (sort (apply 'append mc) 'string<))
+ ;; Filter out duplicates from the targets.
+ (while mc
+ (if (and (car uniq) (string= (car uniq) (car mc)))
+ nil
+ (setq uniq (cons (car mc) uniq)))
+ (setq mc (cdr mc)))
+ (nreverse uniq)))
+
+ (defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-target))
+ "Return a list of patterns that are considered garbage to THIS.
+ These are removed with make clean."
+ ;; Get the the source object from THIS, and use the specified garbage.
+ (let ((src (ede-target-sourcecode this))
+ (garb nil))
+ (while src
+ (setq garb (append (oref (car src) garbagepattern) garb)
+ src (cdr src)))
+ garb))
+
+
+ ;;; RULES
+ ;;
+ (defmethod ede-proj-makefile-insert-subproj-rules ((this ede-proj-project))
+ "Insert a rule for the project THIS which should be a subproject."
+ (insert ".PHONY:" (ede-name this))
+ (newline)
+ (insert (ede-name this) ":")
+ (newline)
+ (insert "\t$(MAKE) -C " (directory-file-name (ede-subproject-relative-path this)))
+ (newline)
+ (newline)
+ )
+
+ (defmethod ede-proj-makefile-insert-rules ((this ede-proj-project))
+ "Insert rules needed by THIS target."
+ (mapc 'ede-proj-makefile-insert-rules (oref this inference-rules))
+ )
+
+ (defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-project))
+ "Insert any symbols that the DIST rule should depend on.
+ Argument THIS is the project that should insert stuff."
+ (mapc 'ede-proj-makefile-insert-dist-dependencies (oref this targets))
+ )
+
+ (defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target))
+ "Insert any symbols that the DIST rule should depend on.
+ Argument THIS is the target that should insert stuff."
+ nil)
+
+ (defmethod ede-proj-makefile-insert-dist-filepatterns ((this ede-proj-target))
+ "Insert any symbols that the DIST rule should depend on.
+ Argument THIS is the target that should insert stuff."
+ (ede-proj-makefile-insert-dist-dependencies this)
+ )
+
+ (defmethod ede-proj-makefile-insert-dist-rules ((this ede-proj-project))
+ "Insert distribution rules for THIS in a Makefile, such as CLEAN and DIST."
+ (let ((junk (ede-proj-makefile-garbage-patterns this))
+ tmp)
+ ;; Build CLEAN, DIST, TAG, and other rules here.
+ (if junk
+ (insert "\nclean:\n"
+ "\trm -f "
+ (mapconcat (lambda (c) c) junk " ")
+ "\n\n"))
+ ;; @TODO: ^^^ Clean should also recurse. ^^^
+
+ (insert ".PHONY: dist\n")
+ (insert "\ndist:")
+ (ede-proj-makefile-insert-dist-dependencies this)
+ (insert "\n")
+ (unless (or (ede-subproject-p this)
+ (oref this metasubproject))
+ ;; Only delete if we are the toplevel project.
+ (insert "\trm -rf $(DISTDIR)\n"))
+ (insert "\tmkdir $(DISTDIR)\n") ;We may need a -p, but I think not.
+ (setq tmp (oref this targets))
+ (insert "\tcp")
+ (while tmp
+ (let ((sv (ede-proj-makefile-sourcevar (car tmp))))
+ (if (listp sv)
+ ;; Handle special case variables.
+ (cond ((eq (cdr sv) 'share)
+ ;; This variable may be shared between multiple targets.
+ (if (re-search-backward (concat "\\$(" (car sv) ")")
+ (save-excursion
+ (beginning-of-line)
+ (point))
+ t)
+ ;; If its already in the dist target, then skip it.
+ nil
+ (setq sv (car sv))))
+ (t (setq sv (car sv)))))
+ (if (stringp sv)
+ (insert " $(" sv ")"))
+ (ede-proj-makefile-insert-dist-filepatterns (car tmp))
+ (setq tmp (cdr tmp))))
+ (insert " $(ede_FILES) $(DISTDIR)\n")
+
+ ;; Call our sub projects.
+ (ede-map-subprojects
+ this (lambda (sproj)
+ (let ((rp (directory-file-name (ede-subproject-relative-path sproj))))
+ (insert "\t$(MAKE) -C " rp " $(MFLAGS) DISTDIR=$(DISTDIR)/" rp
+ " dist"
+ "\n"))))
+
+ ;; Tar up the stuff.
+ (unless (or (ede-subproject-p this)
+ (oref this metasubproject))
+ (insert "\ttar -cvzf $(DISTDIR).tar.gz $(DISTDIR)\n"
+ "\trm -rf $(DISTDIR)\n"))
+
+ ;; Make sure the Makefile is ok.
+ (insert "\n"
+ (file-name-nondirectory (buffer-file-name)) ": "
+ (file-name-nondirectory (oref this file)) "\n"
+ ;; "$(EMACS) -batch Project.ede -l ede -f ede-proj-regenerate"
+ "\t@echo Makefile is out of date! "
+ "It needs to be regenerated by EDE.\n"
+ "\t@echo If you have not modified Project.ede, you can"
+ " use 'touch' to update the Makefile time stamp.\n"
+ "\t@false\n\n"
+ "\n\n# End of Makefile\n")))
+
+ (defmethod ede-proj-makefile-insert-rules ((this ede-proj-target))
+ "Insert rules needed by THIS target."
+ nil)
+
+ (defmethod ede-proj-makefile-insert-rules ((this ede-proj-target-makefile))
+ "Insert rules needed by THIS target."
+ (mapc 'ede-proj-makefile-insert-rules (oref this rules))
+ (let ((c (ede-proj-compilers this)))
+ (when c
+ (mapc 'ede-proj-makefile-insert-rules c)
+ (if (oref this phony)
+ (insert ".PHONY: " (ede-proj-makefile-target-name this) "\n"))
+ (insert (ede-proj-makefile-target-name this) ": "
+ (ede-proj-makefile-dependencies this) "\n")
+ (ede-proj-makefile-insert-commands this)
+ )))
+
+ (defmethod ede-proj-makefile-insert-commands ((this ede-proj-target-makefile))
+ "Insert the commands needed by target THIS.
+ For targets, insert the commands needed by the chosen compiler."
+ (mapc 'ede-proj-makefile-insert-commands (ede-proj-compilers this))
+ (when (object-assoc t :uselinker (ede-proj-compilers this))
+ (mapc 'ede-proj-makefile-insert-commands (ede-proj-linkers this))))
+
+
+ (defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-project))
+ "Insert user specified rules needed by THIS target.
+ This is different from `ede-proj-makefile-insert-rules' in that this
+ function won't create the building rules which are auto created with
+ automake."
+ (mapc 'ede-proj-makefile-insert-user-rules (oref this inference-rules)))
+
+ (defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-target))
+ "Insert user specified rules needed by THIS target."
+ (mapc 'ede-proj-makefile-insert-rules (oref this rules)))
+
+ (defmethod ede-proj-makefile-dependencies ((this ede-proj-target-makefile))
+ "Return a string representing the dependencies for THIS.
+ Some compilers only use the first element in the dependencies, others
+ have a list of intermediates (object files), and others don't care.
+ This allows customization of how these elements appear."
+ (let* ((c (ede-proj-compilers this))
++ (io (eval (cons 'or (mapcar 'ede-compiler-intermediate-objects-p c))))
+ (out nil))
+ (if io
+ (progn
+ (while c
+ (setq out
+ (concat out "$(" (ede-compiler-intermediate-object-variable
+ (car c)
+ (ede-proj-makefile-target-name this)) ")")
+ c (cdr c)))
+ out)
+ (let ((sv (ede-proj-makefile-sourcevar this))
+ (aux (oref this auxsource)))
+ (setq out
+ (if (and (stringp sv) (not (string= sv "")))
+ (concat "$(" sv ")")
+ ""))
+ (while aux
+ (setq out (concat out " " (car aux)))
+ (setq aux (cdr aux)))
+ out))))
+
+ ;; Tags
+ (defmethod ede-proj-makefile-tags ((this ede-proj-project) targets)
+ "Insert into the current location rules to make recursive TAGS files.
+ Argument THIS is the project to create tags for.
+ Argument TARGETS are the targets we should depend on for TAGS."
+ (insert "tags: ")
+ (let ((tg targets))
+ ;; Loop over all source variables and insert them
+ (while tg
+ (insert "$(" (ede-proj-makefile-sourcevar (car tg)) ") ")
+ (setq tg (cdr tg)))
+ (insert "\n")
+ (if targets
+ (insert "\tetags $^\n"))
+ ;; Now recurse into all subprojects
+ (setq tg (oref this subproj))
+ (while tg
+ (insert "\t$(MAKE) -C " (ede-subproject-relative-path (car tg)) " $(MFLAGS) $@\n")
+ (setq tg (cdr tg)))
+ (insert "\n")))
+
+
+ (provide 'ede/pmake)
+
+ ;;; ede/pmake.el ends here
--- /dev/null
-;;; ede-proj-comp.el --- EDE Generic Project compiler/rule driver
++;;; ede/proj-comp.el --- EDE Generic Project compiler/rule driver
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2004, 2005, 2007, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: project, make
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; This software handles the maintenance of compiler and rule definitions
+ ;; for different object types.
+ ;;
+ ;; The `ede-compiler' class lets different types of project objects create
+ ;; definitions of compilers that can be swapped in and out for compiling
+ ;; source code. Users can also define new compiler types whenever they
+ ;; some customized behavior.
+ ;;
+ ;; The `ede-makefile-rule' class lets users add customized rules into thier
+ ;; objects, and also lets different compilers add chaining rules to their
+ ;; behaviors.
+ ;;
+ ;; It is important that all new compiler types be registered once. That
+ ;; way the chaining rules and variables are inserted into any given Makefile
+ ;; only once.
+ ;;
+ ;; To insert many compiler elements, wrap them in `ede-compiler-begin-unique'
+ ;; before calling their insert methods.
+ ;; To write a method that inserts a variable or rule for a compiler
+ ;; based object, wrap the body of your call in `ede-compiler-only-once'
+
+ (require 'ede) ;source object
+ (require 'ede/autoconf-edit)
+
+ ;;; Types:
+ (defclass ede-compilation-program (eieio-instance-inheritor)
+ ((name :initarg :name
+ :type string
+ :custom string
+ :documentation "Name of this type of compiler.")
+ (variables :initarg :variables
+ :type list
+ :custom (repeat (cons (string :tag "Variable")
+ (string :tag "Value")))
+ :documentation
+ "Variables needed in the Makefile for this compiler.
+ An assoc list where each element is (VARNAME . VALUE) where VARNAME
+ is a string, and VALUE is either a string, or a list of strings.
+ For example, GCC would define CC=gcc, and emacs would define EMACS=emacs.")
+ (sourcetype :initarg :sourcetype
+ :type list ;; of symbols
+ :documentation
+ "A list of `ede-sourcecode' objects this class will handle.
+ This is used to match target objects with the compilers and linkers
+ they can use, and which files this object is interested in."
+ :accessor ede-object-sourcecode)
+ (rules :initarg :rules
+ :initform nil
+ :type list
+ :custom (repeat (object :objecttype ede-makefile-rule))
+ :documentation
+ "Auxiliary rules needed for this compiler to run.
+ For example, yacc/lex files need additional chain rules, or inferences.")
+ (commands :initarg :commands
+ :type list
+ :custom (repeat string)
+ :documentation
+ "The commands used to execute this compiler.
+ The object which uses this compiler will place these commands after
+ it's rule definition.")
+ (autoconf :initarg :autoconf
+ :initform nil
+ :type list
+ :custom (repeat string)
+ :documentation
+ "Autoconf function to call if this type of compiler is used.
+ When a project is in Automake mode, this defines the autoconf function to
+ call to initialize automake to use this compiler.
+ For example, there may be multiple C compilers, but they all probably
+ use the same autoconf form.")
+ (objectextention :initarg :objectextention
+ :type string
+ :documentation
+ "A string which is the extention used for object files.
+ For example, C code uses .o on unix, and Emacs Lisp uses .elc.")
+ )
+ "A program used to compile or link a program via a Makefile.
+ Contains everything needed to output code into a Makefile, or autoconf
+ file.")
+
+ (defclass ede-compiler (ede-compilation-program)
+ ((makedepends :initarg :makedepends
+ :initform nil
+ :type boolean
+ :documentation
+ "Non-nil if this compiler can make dependencies.")
+ (uselinker :initarg :uselinker
+ :initform nil
+ :type boolean
+ :documentation
+ "Non-nil if this compiler creates code that can be linked.
+ This requires that the containing target also define a list of available
+ linkers that can be used.")
+ )
+ "Definition for a compiler.
+ Different types of objects will provide different compilers for
+ different situations.")
+
+ (defclass ede-linker (ede-compilation-program)
+ ()
+ "Contains information needed to link many generated object files together.")
+
+ (defclass ede-makefile-rule ()
+ ((target :initarg :target
+ :initform ""
+ :type string
+ :custom string
+ :documentation "The target pattern.
+ A pattern of \"%.o\" is used for inference rules, and would match object files.
+ A target of \"foo.o\" explicitly matches the file foo.o.")
+ (dependencies :initarg :dependencies
+ :initform ""
+ :type string
+ :custom string
+ :documentation "Dependencies on this target.
+ A pattern of \"%.o\" would match a file of the same prefix as the target
+ if that target is also an inference rule pattern.
+ A dependency of \"foo.c\" explicitly lists foo.c as a dependency.
+ A variable such as $(name_SOURCES) will list all the source files
+ belonging to the target name.")
+ (rules :initarg :rules
+ :initform nil
+ :type list
+ :custom (repeat string)
+ :documentation "Scripts to execute.
+ These scripst will be executed in sh (Unless the SHELL variable is overriden).
+ Do not prefix with TAB.
+ Each individual element of this list can be either a string, or
+ a lambda function. (The custom element does not yet express that.")
+ (phony :initarg :phony
+ :initform nil
+ :type boolean
+ :custom boolean
+ :documentation "Is this a phony rule?
+ Adds this rule to a .PHONY list."))
+ "A single rule for building some target.")
+
+ ;;; Code:
+ (defvar ede-compiler-list nil
+ "The master list of all EDE compilers.")
+
+ (defvar ede-linker-list nil
+ "The master list of all EDE compilers.")
+
+ (defvar ede-current-build-list nil
+ "List of EDE compilers that have already inserted parts of themselves.
+ This is used when creating a Makefile to prevend duplicate variables and
+ rules from being created.")
+
+ (defmethod initialize-instance :AFTER ((this ede-compiler) &rest fields)
+ "Make sure that all ede compiler objects are cached in
+ `ede-compiler-list'."
+ (add-to-list 'ede-compiler-list this))
+
+ (defmethod initialize-instance :AFTER ((this ede-linker) &rest fields)
+ "Make sure that all ede compiler objects are cached in
+ `ede-linker-list'."
+ (add-to-list 'ede-linker-list this))
+
+ (defmacro ede-compiler-begin-unique (&rest body)
+ "Execute BODY, making sure that `ede-current-build-list' is maintained.
+ This will prevent rules from creating duplicate variables or rules."
+ `(let ((ede-current-build-list nil))
+ ,@body))
+
+ (defmacro ede-compiler-only-once (object &rest body)
+ "Using OBJECT, execute BODY only once per Makefile generation."
+ `(if (not (member ,object ede-current-build-list))
+ (progn
+ (add-to-list 'ede-current-build-list ,object)
+ ,@body)))
+
+ (defmacro ede-linker-begin-unique (&rest body)
+ "Execute BODY, making sure that `ede-current-build-list' is maintained.
+ This will prevent rules from creating duplicate variables or rules."
+ `(let ((ede-current-build-list nil))
+ ,@body))
+
+ (defmacro ede-linker-only-once (object &rest body)
+ "Using OBJECT, execute BODY only once per Makefile generation."
+ `(if (not (member ,object ede-current-build-list))
+ (progn
+ (add-to-list 'ede-current-build-list ,object)
+ ,@body)))
+
+ (add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec ede-compiler-begin-unique def-body)
+ (def-edebug-spec ede-compiler-only-once (form def-body))
+ (def-edebug-spec ede-linker-begin-unique def-body)
+ (def-edebug-spec ede-linker-only-once (form def-body))
+ (def-edebug-spec ede-pmake-insert-variable-shared (form def-body))
+ ))
+
+ ;;; Querys
+ (defun ede-proj-find-compiler (compilers sourcetype)
+ "Return a compiler from the list COMPILERS that will compile SOURCETYPE."
+ (while (and compilers
+ (not (member sourcetype (oref (car compilers) sourcetype))))
+ (setq compilers (cdr compilers)))
+ (car-safe compilers))
+
+ (defun ede-proj-find-linker (linkers sourcetype)
+ "Return a compiler from the list LINKERS to be used with SOURCETYPE."
+ (while (and linkers
+ (slot-boundp (car linkers) 'sourcetype)
+ (not (member sourcetype (oref (car linkers) sourcetype))))
+ (setq linkers (cdr linkers)))
+ (car-safe linkers))
+
+ ;;; Methods:
+ (defmethod ede-proj-tweak-autoconf ((this ede-compilation-program))
+ "Tweak the configure file (current buffer) to accomodate THIS."
+ (mapcar
+ (lambda (obj)
+ (cond ((stringp obj)
+ (autoconf-insert-new-macro obj))
+ ((consp obj)
+ (autoconf-insert-new-macro (car obj) (cdr obj)))
+ (t (error "Autoconf directives must be a string, or cons cell")))
+ )
+ (oref this autoconf)))
+
+ (defmethod ede-proj-flush-autoconf ((this ede-compilation-program))
+ "Flush the configure file (current buffer) to accomodate THIS."
+ nil)
+
+ (defmethod ede-proj-makefile-insert-variables ((this ede-compilation-program))
+ "Insert variables needed by the compiler THIS."
+ (if (eieio-instance-inheritor-slot-boundp this 'variables)
+ (with-slots (variables) this
+ (mapcar
+ (lambda (var)
+ (insert (car var) "=")
+ (let ((cd (cdr var)))
+ (if (listp cd)
+ (mapc (lambda (c) (insert " " c)) cd)
+ (insert cd)))
+ (insert "\n"))
+ variables))))
+
+ (defmethod ede-compiler-intermediate-objects-p ((this ede-compiler))
+ "Return non-nil if THIS has intermediate object files.
+ If this compiler creates code that can be linked together,
+ then the object files created by the compiler are considered intermediate."
+ (oref this uselinker))
+
+ (defmethod ede-compiler-intermediate-object-variable ((this ede-compiler)
+ targetname)
+ "Return a string based on THIS representing a make object variable.
+ TARGETNAME is the name of the target that these objects belong to."
+ (concat targetname "_OBJ"))
+
+ (defmethod ede-proj-makefile-insert-object-variables ((this ede-compiler)
+ targetname sourcefiles)
+ "Insert an OBJ variable to specify object code to be generated for THIS.
+ The name of the target is TARGETNAME as a string. SOURCEFILES is the list of
+ files to be objectified.
+ Not all compilers do this."
+ (if (ede-compiler-intermediate-objects-p this)
+ (progn
+ (insert (ede-compiler-intermediate-object-variable this targetname)
+ "=")
+ (let ((src (oref this sourcetype)))
+ (mapc (lambda (s)
+ (let ((ts src))
+ (while (and ts (not (ede-want-file-source-p
+ (symbol-value (car ts)) s)))
+ (setq ts (cdr ts)))
+ ;; Only insert the object if the given file is a major
+ ;; source-code type.
+ (if ts;; a match as a source file.
+ (insert " " (file-name-sans-extension s)
+ (oref this objectextention)))))
+ sourcefiles)
+ (insert "\n")))))
+
+ (defmethod ede-proj-makefile-insert-rules ((this ede-compilation-program))
+ "Insert rules needed for THIS compiler object."
+ (ede-compiler-only-once this
+ (mapc 'ede-proj-makefile-insert-rules (oref this rules))))
+
+ (defmethod ede-proj-makefile-insert-rules ((this ede-makefile-rule))
+ "Insert rules needed for THIS rule object."
+ (if (oref this phony) (insert ".PHONY: (oref this target)\n"))
+ (insert (oref this target) ": " (oref this dependencies) "\n\t"
+ (mapconcat (lambda (c) c) (oref this rules) "\n\t")
+ "\n\n"))
+
+ (defmethod ede-proj-makefile-insert-commands ((this ede-compilation-program))
+ "Insert the commands needed to use compiler THIS.
+ The object creating makefile rules must call this method for the
+ compiler it decides to use after inserting in the rule."
+ (when (slot-boundp this 'commands)
+ (with-slots (commands) this
+ (mapc
+ (lambda (obj) (insert "\t"
+ (cond ((stringp obj)
+ obj)
+ ((and (listp obj)
+ (eq (car obj) 'lambda))
+ (funcall obj))
+ (t
+ (format "%S" obj)))
+ "\n"))
+ commands))
+ (insert "\n")))
+
+ ;;; Some details about our new macro
+ ;;
+ (add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec ede-compiler-begin-unique def-body)))
+ (put 'ede-compiler-begin-unique 'lisp-indent-function 0)
+ (put 'ede-compiler-only-once 'lisp-indent-function 1)
+ (put 'ede-linker-begin-unique 'lisp-indent-function 0)
+ (put 'ede-linker-only-once 'lisp-indent-function 1)
+
+ (provide 'ede/proj-comp)
+
+ ;;; ede/proj-comp.el ends here
--- /dev/null
-;; Handle Emacs Lisp in and EDE Project file.
+ ;;; ede-proj-elisp.el --- EDE Generic Project Emacs Lisp support
+
+ ;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ ;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: project, make
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
++;; Handle Emacs Lisp in an EDE Project file.
+
+ (require 'ede/proj)
+ (require 'ede/pmake)
+ (require 'ede/pconf)
+
+ (autoload 'semantic-ede-proj-target-grammar "semantic/ede-grammar")
+
+ ;;; Code:
+ (defclass ede-proj-target-elisp (ede-proj-target-makefile)
+ ((menu :initform nil)
+ (keybindings :initform nil)
+ (phony :initform t)
+ (sourcetype :initform (ede-source-emacs))
+ (availablecompilers :initform (ede-emacs-compiler ede-xemacs-compiler))
+ (aux-packages :initarg :aux-packages
+ :initform nil
+ :type list
+ :custom (repeat string)
+ :documentation "Additional packages needed.
+ There should only be one toplevel package per auxiliary tool needed.
+ These packages location is found, and added to the compile time
+ load path."
+ ))
+ "This target consists of a group of lisp files.
+ A lisp target may be one general program with many separate lisp files in it.")
+
+ (defvar ede-source-emacs
+ (ede-sourcecode "ede-emacs-source"
+ :name "Emacs Lisp"
+ :sourcepattern "\\.el$"
+ :garbagepattern '("*.elc"))
+ "Emacs Lisp source code definition.")
+
+ (defvar ede-emacs-compiler
+ (ede-compiler
+ "ede-emacs-compiler"
+ :name "emacs"
+ :variables '(("EMACS" . "emacs")
+ ("EMACSFLAGS" . "-batch --no-site-file"))
+ :commands
+ '("@echo \"(add-to-list 'load-path nil)\" > $@-compile-script"
+ "for loadpath in . ${LOADPATH}; do \\"
+ " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> $@-compile-script; \\"
+ "done;"
+ "@echo \"(setq debug-on-error t)\" >> $@-compile-script"
+ "\"$(EMACS)\" $(EMACSFLAGS) -l $@-compile-script -f batch-byte-compile $^"
+ )
+ :autoconf '("AM_PATH_LISPDIR")
+ :sourcetype '(ede-source-emacs)
+ ; :objectextention ".elc"
+ )
+ "Compile Emacs Lisp programs.")
+
+ (defvar ede-xemacs-compiler
+ (clone ede-emacs-compiler "ede-xemacs-compiler"
+ :name "xemacs"
+ :variables '(("EMACS" . "xemacs")))
+ "Compile Emacs Lisp programs with XEmacs.")
+
+ ;;; Claiming files
+ (defmethod ede-buffer-mine ((this ede-proj-target-elisp) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER.
+ Lays claim to all .elc files that match .el files in this target."
+ (if (string-match "\\.elc$" (buffer-file-name buffer))
+ (let ((fname
+ (concat
+ (file-name-sans-extension (buffer-file-name buffer))
+ ".el")
+ ))
+ ;; Is this in our list.
+ (member fname (oref this auxsource))
+ )
+ (call-next-method) ; The usual thing.
+ ))
+
+ ;;; Emacs Lisp Compiler
+ ;;; Emacs Lisp Target
+ (defun ede-proj-elisp-packages-to-loadpath (packages)
+ "Convert a list of PACKAGES, to a list of load path."
+ (let ((paths nil)
+ (ldir nil))
+ (while packages
+ (or (setq ldir (locate-library (car packages)))
+ (error "Cannot find package %s" (car packages)))
+ (let* ((fnd (file-name-directory ldir))
+ (rel (file-relative-name fnd))
+ (full nil)
+ )
+ ;; Make sure the relative name isn't to far off
+ (when (string-match "^\\.\\./\\.\\./\\.\\./\\.\\." rel)
+ (setq full fnd))
+ ;; Do the setup.
+ (setq paths (cons (or full rel) paths)
+ packages (cdr packages))))
+ paths))
+
+ (defmethod project-compile-target ((obj ede-proj-target-elisp))
+ "Compile all sources in a Lisp target OBJ.
+ Bonus: Return a cons cell: (COMPILED . UPTODATE)."
+ (let* ((proj (ede-target-parent obj))
+ (dir (oref proj directory))
+ (comp 0)
+ (utd 0))
+ (mapc (lambda (src)
+ (let* ((fsrc (expand-file-name src dir))
+ (elc (concat (file-name-sans-extension fsrc) ".elc"))
+ )
+ (if (or (not (file-exists-p elc))
+ (file-newer-than-file-p fsrc elc))
+ (progn
+ (setq comp (1+ comp))
+ (byte-compile-file fsrc))
+ (setq utd (1+ utd)))))
+ (oref obj source))
+ (message "All Emacs Lisp sources are up to date in %s" (object-name obj))
+ (cons comp utd)
+ ))
+
+ (defmethod ede-update-version-in-source ((this ede-proj-target-elisp) version)
+ "In a Lisp file, updated a version string for THIS to VERSION.
+ There are standards in Elisp files specifying how the version string
+ is found, such as a `-version' variable, or the standard header."
+ (if (and (slot-boundp this 'versionsource)
+ (oref this versionsource))
+ (let ((vs (oref this versionsource))
+ (match nil))
+ (while vs
+ (save-excursion
+ (set-buffer (find-file-noselect
+ (ede-expand-filename this (car vs))))
+ (goto-char (point-min))
+ (let ((case-fold-search t))
+ (if (re-search-forward "-version\\s-+\"\\([^\"]+\\)\"" nil t)
+ (progn
+ (setq match t)
+ (delete-region (match-beginning 1)
+ (match-end 1))
+ (goto-char (match-beginning 1))
+ (insert version)))))
+ (setq vs (cdr vs)))
+ (if (not match) (call-next-method)))))
+
+
+ ;;; Makefile generation functions
+ ;;
+ (defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-elisp))
+ "Return the variable name for THIS's sources."
+ (cond ((ede-proj-automake-p) '("lisp_LISP" . share))
+ (t (concat (ede-pmake-varname this) "_LISP"))))
+
+ (defun ede-proj-makefile-insert-loadpath-items (items)
+ "Insert a sequence of ITEMS into the Makefile LOADPATH variable."
+ (when items
+ (ede-pmake-insert-variable-shared "LOADPATH"
+ (let ((begin (save-excursion (re-search-backward "\\s-*="))))
+ (while items
+ (when (not (save-excursion
+ (re-search-backward
+ (concat "\\s-" (regexp-quote (car items)) "[ \n\t\\]")
+ begin t)))
+ (insert " " (car items)))
+ (setq items (cdr items)))))
+ ))
+
+ (defmethod ede-proj-makefile-insert-variables :AFTER ((this ede-proj-target-elisp))
+ "Insert variables needed by target THIS."
+ (let ((newitems (if (oref this aux-packages)
+ (ede-proj-elisp-packages-to-loadpath
+ (oref this aux-packages))))
+ )
+ (ede-proj-makefile-insert-loadpath-items newitems)))
+
+ (defun ede-proj-elisp-add-path (path)
+ "Add path PATH into the file if it isn't already there."
+ (goto-char (point-min))
+ (if (re-search-forward (concat "(cons \\\""
+ (regexp-quote path))
+ nil t)
+ nil;; We have it already
+ (if (re-search-forward "(cons nil" nil t)
+ (progn
+ ;; insert stuff here
+ (end-of-line)
+ (insert "\n"
+ " echo \"(setq load-path (cons \\\""
+ path
+ "\\\" load-path))\" >> script")
+ )
+ (error "Don't know how to update load path"))))
+
+ (defmethod ede-proj-tweak-autoconf ((this ede-proj-target-elisp))
+ "Tweak the configure file (current buffer) to accomodate THIS."
+ (call-next-method)
+ ;; Ok, now we have to tweak the autoconf provided `elisp-comp' program.
+ (let ((ec (ede-expand-filename this "elisp-comp" 'newfile)))
+ (if (or (not ec) (not (file-exists-p ec)))
+ (message "No elisp-comp file. There may be compile errors? Rerun a second time.")
+ (save-excursion
+ (if (file-symlink-p ec)
+ (progn
+ ;; Desymlinkafy
+ (rename-file ec (concat ec ".tmp"))
+ (copy-file (concat ec ".tmp") ec)
+ (delete-file (concat ec ".tmp"))))
+ (set-buffer (find-file-noselect ec t))
+ (ede-proj-elisp-add-path "..")
+ (let ((paths (ede-proj-elisp-packages-to-loadpath
+ (oref this aux-packages))))
+ ;; Add in the current list of paths
+ (while paths
+ (ede-proj-elisp-add-path (car paths))
+ (setq paths (cdr paths))))
+ (save-buffer)) )))
+
+ (defmethod ede-proj-flush-autoconf ((this ede-proj-target-elisp))
+ "Flush the configure file (current buffer) to accomodate THIS."
+ ;; Remove crufty old paths from elisp-compile
+ (let ((ec (ede-expand-filename this "elisp-comp" 'newfile))
+ )
+ (if (and ec (file-exists-p ec))
+ (save-excursion
+ (set-buffer (find-file-noselect ec t))
+ (goto-char (point-min))
+ (while (re-search-forward "(cons \\([^ ]+\\) load-path)"
+ nil t)
+ (let ((path (match-string 1)))
+ (if (string= path "nil")
+ nil
+ (delete-region (save-excursion (beginning-of-line) (point))
+ (save-excursion (end-of-line)
+ (forward-char 1)
+ (point))))))))))
+
+ ;;;
+ ;; Autoload generators
+ ;;
+ (defclass ede-proj-target-elisp-autoloads (ede-proj-target-elisp)
+ ((availablecompilers :initform (ede-emacs-cedet-autogen-compiler))
+ (aux-packages :initform ("cedet-autogen"))
+ (phony :initform t)
+ (autoload-file :initarg :autoload-file
+ :initform "loaddefs.el"
+ :type string
+ :custom string
+ :documentation "The file that autoload definitions are placed in.
+ There should be one load defs file for a given package. The load defs are created
+ for all Emacs Lisp sources that exist in the directory of the created target.")
+ (autoload-dirs :initarg :autoload-dirs
+ :initform nil
+ :type list
+ :custom (repeat string)
+ :documentation "The directories to scan for autoload definitions.
+ If nil defaults to the current directory.")
+ )
+ "Target that builds an autoload file.
+ Files do not need to be added to this target.")
+
+
+ ;;; Claiming files
+ (defmethod ede-buffer-mine ((this ede-proj-target-elisp-autoloads) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER.
+ Lays claim to all .elc files that match .el files in this target."
+ (if (string-match
+ (concat (regexp-quote (oref this autoload-file)) "$")
+ (buffer-file-name buffer))
+ t
+ (call-next-method) ; The usual thing.
+ ))
+
+ ;; Compilers
+ (defvar ede-emacs-cedet-autogen-compiler
+ (ede-compiler
+ "ede-emacs-autogen-compiler"
+ :name "emacs"
+ :variables '(("EMACS" . "emacs"))
+ :commands
+ '("@echo \"(add-to-list 'load-path nil)\" > $@-compile-script"
+ "for loadpath in . ${LOADPATH}; do \\"
+ " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> $@-compile-script; \\"
+ "done;"
+ "@echo \"(require 'cedet-autogen)\" >> $@-compile-script"
+ "\"$(EMACS)\" -batch --no-site-file -l $@-compile-script -f cedet-batch-update-autoloads $(LOADDEFS) $(LOADDIRS)"
+ )
+ :sourcetype '(ede-source-emacs)
+ )
+ "Build an autoloads file.")
+
+ (defmethod ede-proj-compilers ((obj ede-proj-target-elisp-autoloads))
+ "List of compilers being used by OBJ.
+ If the `compiler' slot is empty, get the car of the compilers list."
+ (let ((comp (oref obj compiler)))
+ (if comp
+ (if (listp comp)
+ (setq comp (mapcar 'symbol-value comp))
+ (setq comp (list (symbol-value comp))))
+ ;; Get the first element from our list of compilers.
+ (let ((avail (mapcar 'symbol-value (oref obj availablecompilers))))
+ (setq comp (list (car avail)))))
+ comp))
+
+ (defmethod ede-proj-makefile-insert-source-variables ((this ede-proj-target-elisp-autoloads)
+ &optional
+ moresource)
+ "Insert the source variables needed by THIS.
+ Optional argument MORESOURCE is a list of additional sources to add to the
+ sources variable."
+ nil)
+
+ (defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-elisp-autoloads))
+ "Return the variable name for THIS's sources."
+ nil) ; "LOADDEFS")
+
+ (defmethod ede-proj-makefile-dependencies ((this ede-proj-target-elisp-autoloads))
+ "Return a string representing the dependencies for THIS.
+ Always return an empty string for an autoloads generator."
+ "")
+
+ (defmethod ede-proj-makefile-insert-variables :AFTER ((this ede-proj-target-elisp-autoloads))
+ "Insert variables needed by target THIS."
+ (ede-pmake-insert-variable-shared "LOADDEFS"
+ (insert (oref this autoload-file)))
+ (ede-pmake-insert-variable-shared "LOADDIRS"
+ (insert (mapconcat 'identity
+ (or (oref this autoload-dirs) '("."))
+ " ")))
+ )
+
+ (defmethod project-compile-target ((obj ede-proj-target-elisp-autoloads))
+ "Create or update the autoload target."
+ (require 'cedet-autogen)
+ (let ((default-directory (ede-expand-filename obj ".")))
+ (apply 'cedet-update-autoloads
+ (oref obj autoload-file)
+ (oref obj autoload-dirs))
+ ))
+
+ (defmethod ede-update-version-in-source ((this ede-proj-target-elisp-autoloads) version)
+ "In a Lisp file, updated a version string for THIS to VERSION.
+ There are standards in Elisp files specifying how the version string
+ is found, such as a `-version' variable, or the standard header."
+ nil)
+
+ (defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target-elisp-autoloads))
+ "Insert any symbols that the DIST rule should depend on.
+ Emacs Lisp autoload files ship the generated .el files.
+ Argument THIS is the target which needs to insert an info file."
+ ;; In some cases, this is ONLY the index file. That should generally
+ ;; be ok.
+ (insert " " (ede-proj-makefile-target-name this))
+ )
+
+ (defmethod ede-proj-makefile-insert-dist-filepatterns ((this ede-proj-target-elisp-autoloads))
+ "Insert any symbols that the DIST rule should distribute.
+ Emacs Lisp autoload files ship the generated .el files.
+ Argument THIS is the target which needs to insert an info file."
+ (insert " " (oref this autoload-file))
+ )
+
+ (defmethod ede-proj-tweak-autoconf ((this ede-proj-target-elisp-autoloads))
+ "Tweak the configure file (current buffer) to accomodate THIS."
+ (error "Autoloads not supported in autoconf yet."))
+
+ (defmethod ede-proj-flush-autoconf ((this ede-proj-target-elisp-autoloads))
+ "Flush the configure file (current buffer) to accomodate THIS."
+ nil)
+
+ (provide 'ede/proj-elisp)
+
+ ;;; ede/proj-elisp.el ends here
--- /dev/null
-;;; ede-proj.el --- EDE Generic Project file driver
++;;; ede/proj.el --- EDE Generic Project file driver
+
+ ;;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2007, 2008, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: project, make
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; EDE defines a method for managing a project. EDE-PROJ aims to be a
+ ;; generic project file format based on the EIEIO object stream
+ ;; methods. Changes in the project structure will require Makefile
+ ;; rebuild. The targets provided in ede-proj can be augmented with
+ ;; additional target types inherited directly from `ede-proj-target'.
+
+ ;; (eval-and-compile '(require 'ede))
+ (require 'ede/proj-comp)
+ (require 'ede/make)
+
+ (declare-function ede-proj-makefile-create "ede/pmake")
+ (declare-function ede-proj-configure-synchronize "ede/pconf")
+
+ (autoload 'ede-proj-target-aux "ede/proj-aux"
+ "Target class for a group of lisp files." nil nil)
+ (autoload 'ede-proj-target-elisp "ede/proj-elisp"
+ "Target class for a group of lisp files." nil nil)
+ (autoload 'ede-proj-target-elisp-autoloads "ede/proj-elisp"
+ "Target class for generating autoload files." nil nil)
+ (autoload 'ede-proj-target-scheme "ede/proj-scheme"
+ "Target class for a group of lisp files." nil nil)
+ (autoload 'ede-proj-target-makefile-miscelaneous "ede/proj-misc"
+ "Target class for a group of miscelaneous w/ a special makefile." nil nil)
+ (autoload 'ede-proj-target-makefile-program "ede/proj-prog"
+ "Target class for building a program." nil nil)
+ (autoload 'ede-proj-target-makefile-archive "ede/proj-archive"
+ "Target class for building an archive of object code." nil nil)
+ (autoload 'ede-proj-target-makefile-shared-object "ede/proj-shared"
+ "Target class for building a shared object." nil nil)
+ (autoload 'ede-proj-target-makefile-info "ede/proj-info"
+ "Target class for info files." nil nil)
+
+ ;;; Class Definitions:
+ (defclass ede-proj-target (ede-target)
+ ((auxsource :initarg :auxsource
+ :initform nil
+ :type list
+ :custom (repeat (string :tag "File"))
+ :label "Auxiliary Source Files"
+ :group (default source)
+ :documentation "Auxilliary source files included in this target.
+ Each of these is considered equivalent to a source file, but it is not
+ distributed, and each should have a corresponding rule to build it.")
+ (dirty :initform nil
+ :type boolean
+ :documentation "Non-nil when generated files needs updating.")
+ (compiler :initarg :compiler
+ :initform nil
+ :type (or null symbol)
+ :custom (choice (const :tag "None" nil)
+ :slotofchoices availablecompilers)
+ :label "Compiler for building sources"
+ :group make
+ :documentation
+ "The compiler to be used to compile this object.
+ This should be a symbol, which contains the object defining the compiler.
+ This enables save/restore to do so by name, permitting the sharing
+ of these compiler resources, and global customization thereof.")
+ (linker :initarg :linker
+ :initform nil
+ :type (or null symbol)
+ :custom (choice (const :tag "None" nil)
+ :slotofchoices availablelinkers)
+ :label "Linker for combining intermediate object files."
+ :group make
+ :documentation
+ "The linker to be used to link compiled sources for this object.
+ This should be a symbol, which contains the object defining the linker.
+ This enables save/restore to do so by name, permitting the sharing
+ of these linker resources, and global customization thereof.")
+ ;; Class allocated slots
+ (phony :allocation :class
+ :initform nil
+ :type boolean
+ :documentation
+ "A phony target is one where the build target does not relate to a file.
+ Such targets are always built, but make knows how to deal with them..")
+ (availablecompilers :allocation :class
+ :initform nil
+ :type (or null list)
+ :documentation
+ "A list of `ede-compiler' objects.
+ These are the compilers the user can choose from when setting the
+ `compiler' slot.")
+ (availablelinkers :allocation :class
+ :initform nil
+ :type (or null list)
+ :documentation
+ "A list of `ede-linker' objects.
+ These are the linkers the user can choose from when setting the
+ `linker' slot.")
+ )
+ "Abstract class for ede-proj targets.")
+
+ (defclass ede-proj-target-makefile (ede-proj-target)
+ ((makefile :initarg :makefile
+ :initform "Makefile"
+ :type string
+ :custom string
+ :label "Parent Makefile"
+ :group make
+ :documentation "File name of generated Makefile.")
+ (partofall :initarg :partofall
+ :initform t
+ :type boolean
+ :custom boolean
+ :label "Part of `all:' target"
+ :group make
+ :documentation
+ "Non nil means the rule created is part of the all target.
+ Setting this to nil creates the rule to build this item, but does not
+ include it in the ALL`all:' rule.")
+ (configuration-variables
+ :initarg :configuration-variables
+ :initform nil
+ :type list
+ :custom (repeat (cons (string :tag "Configuration")
+ (repeat
+ (cons (string :tag "Name")
+ (string :tag "Value")))))
+ :label "Environment Variables for configurations"
+ :group make
+ :documentation "Makefile variables appended to use in different configurations.
+ These variables are used in the makefile when a configuration becomes active.
+ Target variables are always renamed such as foo_CFLAGS, then included into
+ commands where the variable would usually appear.")
+ (rules :initarg :rules
+ :initform nil
+ :type list
+ :custom (repeat (object :objecttype ede-makefile-rule))
+ :label "Additional Rules"
+ :group (make)
+ :documentation
+ "Arbitrary rules and dependencies needed to make this target.
+ It is safe to leave this blank.")
+ )
+ "Abstract class for Makefile based targets.")
+
+ (defvar ede-proj-target-alist
+ '(("program" . ede-proj-target-makefile-program)
+ ("archive" . ede-proj-target-makefile-archive)
+ ("sharedobject" . ede-proj-target-makefile-shared-object)
+ ("emacs lisp" . ede-proj-target-elisp)
+ ("emacs lisp autoloads" . ede-proj-target-elisp-autoloads)
+ ("info" . ede-proj-target-makefile-info)
+ ("auxiliary" . ede-proj-target-aux)
+ ("scheme" . ede-proj-target-scheme)
+ ("miscellaneous" . ede-proj-target-makefile-miscelaneous)
+ )
+ "Alist of names to class types for available project target classes.")
+
+ (defun ede-proj-register-target (name class)
+ "Register a new target class with NAME and class symbol CLASS.
+ This enables the creation of your target type."
+ (let ((a (assoc name ede-proj-target-alist)))
+ (if a
+ (setcdr a class)
+ (setq ede-proj-target-alist
+ (cons (cons name class) ede-proj-target-alist)))))
+
+ (defclass ede-proj-project (ede-project)
+ ((makefile-type :initarg :makefile-type
+ :initform Makefile
+ :type symbol
+ :custom (choice (const Makefile)
+ ;(const Makefile.in)
+ (const Makefile.am)
+ ;(const cook)
+ )
+ :documentation "The type of Makefile to generate.
+ Can be one of 'Makefile, 'Makefile.in, or 'Makefile.am.
+ If this value is NOT 'Makefile, then that overrides the :makefile slot
+ in targets.")
+ (variables :initarg :variables
+ :initform nil
+ :type list
+ :custom (repeat (cons (string :tag "Name")
+ (string :tag "Value")))
+ :group (settings)
+ :documentation "Variables to set in this Makefile.")
+ (configuration-variables
+ :initarg :configuration-variables
+ :initform ("debug" (("DEBUG" . "1")))
+ :type list
+ :custom (repeat (cons (string :tag "Configuration")
+ (repeat
+ (cons (string :tag "Name")
+ (string :tag "Value")))))
+ :group (settings)
+ :documentation "Makefile variables to use in different configurations.
+ These variables are used in the makefile when a configuration becomes active.")
+ (inference-rules :initarg :inference-rules
+ :initform nil
+ :custom (repeat
+ (object :objecttype ede-makefile-rule))
+ :documentation "Inference rules to add to the makefile.")
+ (include-file :initarg :include-file
+ :initform nil
+ :custom (repeat
+ (string :tag "Include File"))
+ :documentation "Additional files to include.
+ These files can contain additional rules, variables, and customizations.")
+ (automatic-dependencies
+ :initarg :automatic-dependencies
+ :initform t
+ :type boolean
+ :custom boolean
+ :group (default settings)
+ :documentation
+ "Non-nil to do implement automatic dependencies in the Makefile.")
+ (menu :initform
+ (
+ [ "Regenerate Makefiles" ede-proj-regenerate t ]
+ [ "Upload Distribution" ede-upload-distribution t ]
+ )
+ )
+ (metasubproject
+ :initarg :metasubproject
+ :initform nil
+ :type boolean
+ :custom boolean
+ :group (default settings)
+ :documentation
+ "Non-nil if this is a metasubproject.
+ Usually, a subproject is determined by a parent project. If multiple top level
+ projects are grouped into a large project not maintained by EDE, then you need
+ to set this to non-nil. The only effect is that the `dist' rule will then avoid
+ making a tar file.")
+ )
+ "The EDE-PROJ project definition class.")
+
+ ;;; Code:
+ (defun ede-proj-load (project &optional rootproj)
+ "Load a project file from PROJECT directory.
+ If optional ROOTPROJ is provided then ROOTPROJ is the root project
+ for the tree being read in. If ROOTPROJ is nil, then assume that
+ the PROJECT being read in is the root project."
+ (save-excursion
+ (let ((ret nil)
+ (subdirs (directory-files project nil "[^.].*" nil)))
+ (set-buffer (get-buffer-create " *tmp proj read*"))
+ (unwind-protect
+ (progn
+ (insert-file-contents (concat project "Project.ede")
+ nil nil nil t)
+ (goto-char (point-min))
+ (setq ret (read (current-buffer)))
+ (if (not (eq (car ret) 'ede-proj-project))
+ (error "Corrupt project file"))
+ (setq ret (eval ret))
+ (oset ret file (concat project "Project.ede"))
+ (oset ret directory project)
+ (oset ret rootproject rootproj)
+ )
+ (kill-buffer " *tmp proj read*"))
+ (while subdirs
+ (let ((sd (file-name-as-directory
+ (expand-file-name (car subdirs) project))))
+ (if (and (file-directory-p sd)
+ (ede-directory-project-p sd))
+ (oset ret subproj
+ (cons (ede-proj-load sd (or rootproj ret))
+ (oref ret subproj))))
+ (setq subdirs (cdr subdirs))))
+ ret)))
+
+ (defun ede-proj-save (&optional project)
+ "Write out object PROJECT into its file."
+ (save-excursion
+ (if (not project) (setq project (ede-current-project)))
+ (let ((b (set-buffer (get-buffer-create " *tmp proj write*")))
+ (cfn (oref project file))
+ (cdir (oref project directory)))
+ (unwind-protect
+ (save-excursion
+ (erase-buffer)
+ (let ((standard-output (current-buffer)))
+ (oset project file (file-name-nondirectory cfn))
+ (slot-makeunbound project :directory)
+ (object-write project ";; EDE project file."))
+ (write-file cfn nil)
+ )
+ ;; Restore the :file on exit.
+ (oset project file cfn)
+ (oset project directory cdir)
+ (kill-buffer b)))))
+
+ (defmethod ede-commit-local-variables ((proj ede-proj-project))
+ "Commit change to local variables in PROJ."
+ (ede-proj-save proj))
+
+ (defmethod eieio-done-customizing ((proj ede-proj-project))
+ "Call this when a user finishes customizing this object.
+ Argument PROJ is the project to save."
+ (call-next-method)
+ (ede-proj-save proj))
+
+ (defmethod eieio-done-customizing ((target ede-proj-target))
+ "Call this when a user finishes customizing this object.
+ Argument TARGET is the project we are completing customization on."
+ (call-next-method)
+ (ede-proj-save (ede-current-project)))
+
+ (defmethod ede-commit-project ((proj ede-proj-project))
+ "Commit any change to PROJ to its file."
+ (ede-proj-save proj))
+
+ (defmethod ede-buffer-mine ((this ede-proj-project) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER."
+ (let ((f (ede-convert-path this (buffer-file-name buffer))))
+ (or (string= (file-name-nondirectory (oref this file)) f)
+ (string= (ede-proj-dist-makefile this) f)
+ (string-match "Makefile\\(\\.\\(in\\|am\\)\\)?$" f)
+ (string-match "config\\(ure\\.in\\|\\.stutus\\)?$" f)
+ )))
+
+ (defmethod ede-buffer-mine ((this ede-proj-target) buffer)
+ "Return t if object THIS lays claim to the file in BUFFER."
+ (or (call-next-method)
+ (ede-target-buffer-in-sourcelist this buffer (oref this auxsource))))
+
+ \f
+ ;;; EDE command functions
+ ;;
+ (defvar ede-proj-target-history nil
+ "History when querying for a target type.")
+
+ (defmethod project-new-target ((this ede-proj-project)
+ &optional name type autoadd)
+ "Create a new target in THIS based on the current buffer."
+ (let* ((name (or name (read-string "Name: " "")))
+ (type (or type
+ (completing-read "Type: " ede-proj-target-alist
+ nil t nil '(ede-proj-target-history . 1))))
+ (ot nil)
+ (src (if (and (buffer-file-name)
+ (if (and autoadd (stringp autoadd))
+ (string= autoadd "y")
+ (y-or-n-p (format "Add %s to %s? " (buffer-name) name))))
+ (buffer-file-name)))
+ (fcn (cdr (assoc type ede-proj-target-alist)))
+ )
+
+ (when (not fcn)
+ (error "Unknown target type %s for EDE Project." type))
+
+ (setq ot (funcall fcn name :name name
+ :path (ede-convert-path this default-directory)
+ :source (if src
+ (list (file-name-nondirectory src))
+ nil)))
+ ;; If we added it, set the local buffer's object.
+ (if src (progn
+ (setq ede-object ot)
+ (ede-apply-object-keymap)))
+ ;; Add it to the project object
+ ;;(oset this targets (cons ot (oref this targets)))
+ ;; New form: Add to the end using fancy eieio function.
+ ;; @todone - Some targets probably want to be in the front.
+ ;; How to do that?
+ ;; @ans - See elisp autoloads for answer
+ (object-add-to-list this 'targets ot t)
+ ;; And save
+ (ede-proj-save this)))
+
+ (defmethod project-new-target-custom ((this ede-proj-project))
+ "Create a new target in THIS for custom."
+ (let* ((name (read-string "Name: " ""))
+ (type (completing-read "Type: " ede-proj-target-alist
+ nil t nil '(ede-proj-target-history . 1))))
+ (funcall (cdr (assoc type ede-proj-target-alist)) name :name name
+ :path (ede-convert-path this default-directory)
+ :source nil)))
+
+ (defmethod project-delete-target ((this ede-proj-target))
+ "Delete the current target THIS from it's parent project."
+ (let ((p (ede-current-project))
+ (ts (oref this source)))
+ ;; Loop across all sources. If it exists in a buffer,
+ ;; clear it's object.
+ (while ts
+ (let* ((default-directory (oref this path))
+ (b (get-file-buffer (car ts))))
+ (if b
+ (save-excursion
+ (set-buffer b)
+ (if (eq ede-object this)
+ (progn
+ (setq ede-object nil)
+ (ede-apply-object-keymap))))))
+ (setq ts (cdr ts)))
+ ;; Remove THIS from it's parent.
+ ;; The two vectors should be pointer equivalent.
+ (oset p targets (delq this (oref p targets)))
+ (ede-proj-save (ede-current-project))))
+
+ (defmethod project-add-file ((this ede-proj-target) file)
+ "Add to target THIS the current buffer represented as FILE."
+ (let ((file (ede-convert-path this file))
+ (src (ede-target-sourcecode this)))
+ (while (and src (not (ede-want-file-p (car src) file)))
+ (setq src (cdr src)))
+ (when src
+ (setq src (car src))
+ (cond ((ede-want-file-source-p this file)
+ (object-add-to-list this 'source file t))
+ ((ede-want-file-auxiliary-p this file)
+ (object-add-to-list this 'auxsource file t))
+ (t (error "`project-add-file(ede-target)' source mismatch error")))
+ (ede-proj-save))))
+
+ (defmethod project-remove-file ((target ede-proj-target) file)
+ "For TARGET, remove FILE.
+ FILE must be massaged by `ede-convert-path'."
+ ;; Speedy delete should be safe.
+ (object-remove-from-list target 'source (ede-convert-path target file))
+ (object-remove-from-list target 'auxsource (ede-convert-path target file))
+ (ede-proj-save))
+
+ (defmethod project-update-version ((this ede-proj-project))
+ "The :version of project THIS has changed."
+ (ede-proj-save))
+
+ (defmethod project-make-dist ((this ede-proj-project))
+ "Build a distribution for the project based on THIS target."
+ ;; I'm a lazy bum, so I'll make a makefile for doing this sort
+ ;; of thing, and rely only on that small section of code.
+ (let ((pm (ede-proj-dist-makefile this))
+ (df (project-dist-files this)))
+ (if (and (file-exists-p (car df))
+ (not (y-or-n-p "Dist file already exists. Rebuild? ")))
+ (error "Try `ede-update-version' before making a distribution"))
+ (ede-proj-setup-buildenvironment this)
+ (if (string= pm "Makefile.am") (setq pm "Makefile"))
+ (compile (concat ede-make-command " -f " pm " dist"))
+ ))
+
+ (defmethod project-dist-files ((this ede-proj-project))
+ "Return a list of files that constitutes a distribution of THIS project."
+ (list
+ ;; Note to self, keep this first for the above fn to check against.
+ (concat (oref this name) "-" (oref this version) ".tar.gz")
+ ))
+
+ (defmethod project-compile-project ((proj ede-proj-project) &optional command)
+ "Compile the entire current project PROJ.
+ Argument COMMAND is the command to use when compiling."
+ (let ((pm (ede-proj-dist-makefile proj))
+ (default-directory (file-name-directory (oref proj file))))
+ (ede-proj-setup-buildenvironment proj)
+ (if (string= pm "Makefile.am") (setq pm "Makefile"))
+ (compile (concat ede-make-command" -f " pm " all"))))
+
+ ;;; Target type specific compilations/debug
+ ;;
+ (defmethod project-compile-target ((obj ede-proj-target) &optional command)
+ "Compile the current target OBJ.
+ Argument COMMAND is the command to use for compiling the target."
+ (project-compile-project (ede-current-project) command))
+
+ (defmethod project-compile-target ((obj ede-proj-target-makefile)
+ &optional command)
+ "Compile the current target program OBJ.
+ Optional argument COMMAND is the s the alternate command to use."
+ (ede-proj-setup-buildenvironment (ede-current-project))
+ (compile (concat ede-make-command " -f " (oref obj makefile) " "
+ (ede-proj-makefile-target-name obj))))
+
+ (defmethod project-debug-target ((obj ede-proj-target))
+ "Run the current project target OBJ in a debugger."
+ (error "Debug-target not supported by %s" (object-name obj)))
+
+ (defmethod ede-proj-makefile-target-name ((this ede-proj-target))
+ "Return the name of the main target for THIS target."
+ (ede-name this))
+ \f
+ ;;; Compiler and source code generators
+ ;;
+ (defmethod ede-want-file-auxiliary-p ((this ede-target) file)
+ "Return non-nil if THIS target wants FILE."
+ ;; By default, all targets reference the source object, and let it decide.
+ (let ((src (ede-target-sourcecode this)))
+ (while (and src (not (ede-want-file-auxiliary-p (car src) file)))
+ (setq src (cdr src)))
+ src))
+
+ (defmethod ede-proj-compilers ((obj ede-proj-target))
+ "List of compilers being used by OBJ.
+ If the `compiler' slot is empty, concoct one on a first match found
+ basis for any given type from the `availablecompilers' slot.
+ Otherwise, return the `compiler' slot.
+ Converts all symbols into the objects to be used."
+ (when (slot-exists-p obj 'compiler)
+ (let ((comp (oref obj compiler)))
+ (if comp
+ ;; Now that we have a pre-set compilers to use, convert tye symbols
+ ;; into objects for ease of use
+ (if (listp comp)
+ (setq comp (mapcar 'symbol-value comp))
+ (setq comp (list (symbol-value comp))))
+ (let* ((acomp (oref obj availablecompilers))
+ (avail (mapcar 'symbol-value acomp))
+ (st (oref obj sourcetype))
+ (sources (oref obj source)))
+ ;; COMP is not specified, so generate a list from the available
+ ;; compilers list.
+ (while st
+ (if (ede-want-any-source-files-p (symbol-value (car st)) sources)
+ (let ((c (ede-proj-find-compiler avail (car st))))
+ (if c (setq comp (cons c comp)))))
+ (setq st (cdr st)))))
+ ;; Return the disovered compilers
+ comp)))
+
+ (defmethod ede-proj-linkers ((obj ede-proj-target))
+ "List of linkers being used by OBJ.
+ If the `linker' slot is empty, concoct one on a first match found
+ basis for any given type from the `availablelinkers' slot.
+ Otherwise, return the `linker' slot.
+ Converts all symbols into the objects to be used."
+ (when (slot-exists-p obj 'linker)
+ (let ((link (oref obj linker)))
+ (if link
+ ;; Now that we have a pre-set linkers to use, convert type symbols
+ ;; into objects for ease of use
+ (if (symbolp link)
+ (setq link (list (symbol-value link)))
+ (error ":linker is not a symbol. Howd you do that?"))
+ (let* ((alink (oref obj availablelinkers))
+ (avail (mapcar 'symbol-value alink))
+ (st (oref obj sourcetype))
+ (sources (oref obj source)))
+ ;; LINKER is not specified, so generate a list from the available
+ ;; compilers list.
+ (while st
+ (if (ede-want-any-source-files-p (symbol-value (car st)) sources)
+ (let ((c (ede-proj-find-linker avail (car st))))
+ (if c (setq link (cons c link)))))
+ (setq st (cdr st)))
+ (unless link
+ ;; No linker stands out! Loop over our linkers and pull out
+ ;; the first that has no source type requirement.
+ (while (and avail (not (eieio-instance-inheritor-slot-boundp (car avail) 'sourcetype)))
+ (setq avail (cdr avail)))
+ (setq link (cdr avail)))))
+ ;; Return the disovered linkers
+ link)))
+
+ \f
+ ;;; Target type specific autogenerating gobbldegook.
+ ;;
+
+ (defun ede-proj-makefile-type (&optional proj)
+ "Makefile type of the current project PROJ."
+ (oref (or proj (ede-current-project)) makefile-type))
+
+ (defun ede-proj-automake-p (&optional proj)
+ "Return non-nil if the current project PROJ is automake mode."
+ (eq (ede-proj-makefile-type proj) 'Makefile.am))
+
+ (defun ede-proj-autoconf-p (&optional proj)
+ "Return non-nil if the current project PROJ is automake mode."
+ (eq (ede-proj-makefile-type proj) 'Makefile.in))
+
+ (defun ede-proj-make-p (&optional proj)
+ "Return non-nil if the current project PROJ is automake mode."
+ (eq (ede-proj-makefile-type proj) 'Makefile))
+
+ (defmethod ede-proj-dist-makefile ((this ede-proj-project))
+ "Return the name of the Makefile with the DIST target in it for THIS."
+ (cond ((eq (oref this makefile-type) 'Makefile.am)
+ (concat (file-name-directory (oref this file))
+ "Makefile.am"))
+ ((eq (oref this makefile-type) 'Makefile.in)
+ (concat (file-name-directory (oref this file))
+ "Makefile.in"))
+ ((object-assoc "Makefile" 'makefile (oref this targets))
+ (concat (file-name-directory (oref this file))
+ "Makefile"))
+ (t
+ (let ((targets (oref this targets)))
+ (while (and targets
+ (not (obj-of-class-p
+ (car targets)
+ 'ede-proj-target-makefile)))
+ (setq targets (cdr targets)))
+ (if targets (oref (car targets) makefile)
+ (concat (file-name-directory (oref this file))
+ "Makefile"))))))
+
+ (defun ede-proj-regenerate ()
+ "Regenerate Makefiles for and edeproject project."
+ (interactive)
+ (ede-proj-setup-buildenvironment (ede-current-project) t))
+
+ (defmethod ede-proj-makefile-create-maybe ((this ede-proj-project) mfilename)
+ "Create a Makefile for all Makefile targets in THIS if needed.
+ MFILENAME is the makefile to generate."
+ ;; For now, pass through until dirty is implemented.
+ (require 'ede/pmake)
+ (if (or (not (file-exists-p mfilename))
+ (file-newer-than-file-p (oref this file) mfilename))
+ (ede-proj-makefile-create this mfilename)))
+
+ (defmethod ede-proj-setup-buildenvironment ((this ede-proj-project)
+ &optional force)
+ "Setup the build environment for project THIS.
+ Handles the Makefile, or a Makefile.am configure.in combination.
+ Optional argument FORCE will force items to be regenerated."
+ (if (not force)
+ (ede-proj-makefile-create-maybe this (ede-proj-dist-makefile this))
+ (require 'ede/pmake)
+ (ede-proj-makefile-create this (ede-proj-dist-makefile this)))
+ ;; Rebuild all subprojects
+ (ede-map-subprojects
+ this (lambda (sproj) (ede-proj-setup-buildenvironment sproj force)))
+ ;; Autoconf projects need to do other kinds of initializations.
+ (when (and (ede-proj-automake-p this)
+ (eq this (ede-toplevel this)))
+ (require 'ede/pconf)
+ ;; If the user wants to force this, do it some other way?
+ (ede-proj-configure-synchronize this)
+ ;; Now run automake to fill in the blanks, autoconf, and other
+ ;; auto thingies so that we can just say "make" when done.
+ )
+ )
+
+ \f
+ ;;; Lower level overloads
+ ;;
+ (defmethod project-rescan ((this ede-proj-project))
+ "Rescan the EDE proj project THIS."
+ (let ((root (or (ede-project-root this) this))
+ )
+ (setq ede-projects (delq root ede-projects))
+ (ede-proj-load (ede-project-root-directory root))
+ ))
+
+ (defmethod project-rescan ((this ede-proj-target) readstream)
+ "Rescan target THIS from the read list READSTREAM."
+ (setq readstream (cdr (cdr readstream))) ;; constructor/name
+ (while readstream
+ (let ((tag (car readstream))
+ (val (car (cdr readstream))))
+ (eieio-oset this tag val))
+ (setq readstream (cdr (cdr readstream)))))
+
+ (provide 'ede/proj)
+
+ ;;; ede/proj.el ends here
--- /dev/null
-(require 'assoc)
+ ;;; semantic.el --- Semantic buffer evaluator.
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+ ;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; API for providing the semantic content of a buffer.
+ ;;
+ ;; The semantic API provides an interface to a series of different parser
+ ;; implementations. Each parser outputs a parse tree in a similar format
+ ;; designed to handle typical functional and object oriented languages.
+
+ (require 'cedet)
+ (require 'semantic/tag)
+ (require 'semantic/lex)
+
+ (defvar semantic-version "2.0pre7"
+ "Current version of Semantic.")
+
+ (declare-function inversion-test "inversion")
+ (declare-function semanticdb-load-ebrowse-caches "semantic/db-ebrowse")
+
+ (defun semantic-require-version (major minor &optional beta)
+ "Non-nil if this version of semantic does not satisfy a specific version.
+ Arguments can be:
+
+ (MAJOR MINOR &optional BETA)
+
+ Values MAJOR and MINOR must be integers. BETA can be an integer, or
+ excluded if a released version is required.
+
+ It is assumed that if the current version is newer than that specified,
+ everything passes. Exceptions occur when known incompatibilities are
+ introduced."
+ (require 'inversion)
+ (inversion-test 'semantic
+ (concat major "." minor
+ (when beta (concat "beta" beta)))))
+
+ (defgroup semantic nil
+ "Parser Generator and parser framework."
+ :group 'lisp)
+
+ (defgroup semantic-faces nil
+ "Faces used for Semantic enabled tools."
+ :group 'semantic)
+
+ (require 'semantic/fw)
+
+ ;;; Code:
+ ;;
+
+ ;;; Variables and Configuration
+ ;;
+ (defvar semantic--parse-table nil
+ "Variable that defines how to parse top level items in a buffer.
+ This variable is for internal use only, and its content depends on the
+ external parser used.")
+ (make-variable-buffer-local 'semantic--parse-table)
+ (semantic-varalias-obsolete 'semantic-toplevel-bovine-table
+ 'semantic--parse-table)
+
+ (defvar semantic-symbol->name-assoc-list
+ '((type . "Types")
+ (variable . "Variables")
+ (function . "Functions")
+ (include . "Dependencies")
+ (package . "Provides"))
+ "Association between symbols returned, and a string.
+ The string is used to represent a group of objects of the given type.
+ It is sometimes useful for a language to use a different string
+ in place of the default, even though that language will still
+ return a symbol. For example, Java return's includes, but the
+ string can be replaced with `Imports'.")
+ (make-variable-buffer-local 'semantic-symbol->name-assoc-list)
+
+ (defvar semantic-symbol->name-assoc-list-for-type-parts nil
+ "Like `semantic-symbol->name-assoc-list' for type parts.
+ Some tags that have children (see `semantic-tag-children-compatibility')
+ will want to define the names of classes of tags differently than at
+ the top level. For example, in C++, a Function may be called a
+ Method. In addition, there may be new types of tags that exist only
+ in classes, such as protection labels.")
+ (make-variable-buffer-local 'semantic-symbol->name-assoc-list-for-type-parts)
+
+ (defvar semantic-case-fold nil
+ "Value for `case-fold-search' when parsing.")
+ (make-variable-buffer-local 'semantic-case-fold)
+
+ (defvar semantic-expand-nonterminal nil
+ "Function to call for each nonterminal production.
+ Return a list of non-terminals derived from the first argument, or nil
+ if it does not need to be expanded.
+ Languages with compound definitions should use this function to expand
+ from one compound symbol into several. For example, in C the definition
+ int a, b;
+ is easily parsed into one tag. This function should take this
+ compound tag and turn it into two tags, one for A, and the other for B.")
+ (make-variable-buffer-local 'semantic-expand-nonterminal)
+
+ (defvar semantic--buffer-cache nil
+ "A cache of the fully parsed buffer.
+ If no significant changes have been made (based on the state) then
+ this is returned instead of re-parsing the buffer.
+
+ DO NOT USE THIS VARIABLE IN PROGRAMS.
+
+ If you need a tag list, use `semantic-fetch-tags'. If you need the
+ cached values for some reason, chances are you can, add a hook to
+ `semantic-after-toplevel-cache-change-hook'.")
+ (make-variable-buffer-local 'semantic--buffer-cache)
+ (semantic-varalias-obsolete 'semantic-toplevel-bovine-cache
+ 'semantic--buffer-cache)
+
+ (defvar semantic-unmatched-syntax-cache nil
+ "A cached copy of unmatched syntax tokens.")
+ (make-variable-buffer-local 'semantic-unmatched-syntax-cache)
+
+ (defvar semantic-unmatched-syntax-cache-check nil
+ "Non nil if the unmatched syntax cache is out of date.
+ This is tracked with `semantic-change-function'.")
+ (make-variable-buffer-local 'semantic-unmatched-syntax-cache-check)
+
+ (defvar semantic-edits-are-safe nil
+ "When non-nil, modifications do not require a reparse.
+ This prevents tags from being marked dirty, and it prevents top level
+ edits from causing a cache check.
+ Use this when writing programs that could cause a full reparse, but
+ will not change the tag structure, such as adding or updating
+ `top-level' comments.")
+
+ (defvar semantic-unmatched-syntax-hook nil
+ "Hooks run when semantic detects syntax not matched in a grammar.
+ Each individual piece of syntax (such as a symbol or punctuation
+ character) is called with this hook when it doesn't match in the
+ grammar, and multiple unmatched syntax elements are not grouped
+ together. Each hook is called with one argument, which is a list of
+ syntax tokens created by the semantic lexer. Use the functions
+ `semantic-lex-token-start', `semantic-lex-token-end' and
+ `semantic-lex-token-text' to get information about these tokens. The
+ current buffer is the buffer these tokens are derived from.")
+
+ (defvar semantic--before-fetch-tags-hook nil
+ "Hooks run before a buffer is parses for tags.
+ It is called before any request for tags is made via the function
+ `semantic-fetch-tags' by an application.
+ If any hook returns a nil value, the cached value is returned
+ immediately, even if it is empty.")
+ (semantic-varalias-obsolete 'semantic-before-toplevel-bovination-hook
+ 'semantic--before-fetch-tags-hook)
+
+ (defvar semantic-after-toplevel-bovinate-hook nil
+ "Hooks run after a toplevel parse.
+ It is not run if the toplevel parse command is called, and buffer does
+ not need to be fully reparsed.
+ For language specific hooks, make sure you define this as a local hook.
+
+ This hook should not be used any more.
+ Use `semantic-after-toplevel-cache-change-hook' instead.")
+ (make-obsolete-variable 'semantic-after-toplevel-bovinate-hook nil)
+
+ (defvar semantic-after-toplevel-cache-change-hook nil
+ "Hooks run after the buffer tag list has changed.
+ This list will change when a buffer is reparsed, or when the tag list
+ in a buffer is cleared. It is *NOT* called if the current tag list is
+ partially reparsed.
+
+ Hook functions must take one argument, which is the new list of tags
+ associated with this buffer.
+
+ For language specific hooks, make sure you define this as a local hook.")
+
+ (defvar semantic-before-toplevel-cache-flush-hook nil
+ "Hooks run before the toplevel tag cache is flushed.
+ For language specific hooks, make sure you define this as a local
+ hook. This hook is called before a corresponding
+ `semantic-after-toplevel-cache-change-hook' which is also called
+ during a flush when the cache is given a new value of nil.")
+
+ (defcustom semantic-dump-parse nil
+ "When non-nil, dump parsing information."
+ :group 'semantic
+ :type 'boolean)
+
+ (defvar semantic-parser-name "LL"
+ "Optional name of the parser used to parse input stream.")
+ (make-variable-buffer-local 'semantic-parser-name)
+
+ (defvar semantic--completion-cache nil
+ "Internal variable used by `semantic-complete-symbol'.")
+ (make-variable-buffer-local 'semantic--completion-cache)
+ \f
+ ;;; Parse tree state management API
+ ;;
+ (defvar semantic-parse-tree-state 'needs-rebuild
+ "State of the current parse tree.")
+ (make-variable-buffer-local 'semantic-parse-tree-state)
+
+ (defmacro semantic-parse-tree-unparseable ()
+ "Indicate that the current buffer is unparseable.
+ It is also true that the parse tree will need either updating or
+ a rebuild. This state will be changed when the user edits the buffer."
+ `(setq semantic-parse-tree-state 'unparseable))
+
+ (defmacro semantic-parse-tree-unparseable-p ()
+ "Return non-nil if the current buffer has been marked unparseable."
+ `(eq semantic-parse-tree-state 'unparseable))
+
+ (defmacro semantic-parse-tree-set-needs-update ()
+ "Indicate that the current parse tree needs to be updated.
+ The parse tree can be updated by `semantic-parse-changes'."
+ `(setq semantic-parse-tree-state 'needs-update))
+
+ (defmacro semantic-parse-tree-needs-update-p ()
+ "Return non-nil if the current parse tree needs to be updated."
+ `(eq semantic-parse-tree-state 'needs-update))
+
+ (defmacro semantic-parse-tree-set-needs-rebuild ()
+ "Indicate that the current parse tree needs to be rebuilt.
+ The parse tree must be rebuilt by `semantic-parse-region'."
+ `(setq semantic-parse-tree-state 'needs-rebuild))
+
+ (defmacro semantic-parse-tree-needs-rebuild-p ()
+ "Return non-nil if the current parse tree needs to be rebuilt."
+ `(eq semantic-parse-tree-state 'needs-rebuild))
+
+ (defmacro semantic-parse-tree-set-up-to-date ()
+ "Indicate that the current parse tree is up to date."
+ `(setq semantic-parse-tree-state nil))
+
+ (defmacro semantic-parse-tree-up-to-date-p ()
+ "Return non-nil if the current parse tree is up to date."
+ `(null semantic-parse-tree-state))
+
+ ;;; Interfacing with the system
+ ;;
+ (defcustom semantic-inhibit-functions nil
+ "List of functions to call with no arguments before Semantic is setup.
+ If any of these functions returns non-nil, the current buffer is not
+ setup to use Semantic."
+ :group 'semantic
+ :type 'hook)
+
+ (defvar semantic-init-hook nil
+ "Hook run when a buffer is initialized with a parsing table.")
+
+ (defvar semantic-init-mode-hook nil
+ "Hook run when a buffer of a particular mode is initialized.")
+ (make-variable-buffer-local 'semantic-init-mode-hook)
+
+ (defvar semantic-init-db-hook nil
+ "Hook run when a buffer is initialized with a parsing table for DBs.
+ This hook is for database functions which intend to swap in a tag table.
+ This guarantees that the DB will go before other modes that require
+ a parse of the buffer.")
+
+ (semantic-varalias-obsolete 'semantic-init-hooks
+ 'semantic-init-hook)
+ (semantic-varalias-obsolete 'semantic-init-mode-hooks
+ 'semantic-init-mode-hook)
+ (semantic-varalias-obsolete 'semantic-init-db-hooks
+ 'semantic-init-db-hook)
+
+ (defvar semantic-new-buffer-fcn-was-run nil
+ "Non nil after `semantic-new-buffer-fcn' has been executed.")
+ (make-variable-buffer-local 'semantic-new-buffer-fcn-was-run)
+
+ (defsubst semantic-active-p ()
+ "Return non-nil if the current buffer was set up for parsing."
+ semantic-new-buffer-fcn-was-run)
+
+ (defsubst semantic--umatched-syntax-needs-refresh-p ()
+ "Return non-nil if the unmatched syntax cache needs a refresh.
+ That is if it is dirty or if the current parse tree isn't up to date."
+ (or semantic-unmatched-syntax-cache-check
+ (not (semantic-parse-tree-up-to-date-p))))
+
+ (defun semantic-new-buffer-fcn ()
+ "Setup the current buffer to use Semantic.
+ If the major mode is ready for Semantic, and no
+ `semantic-inhibit-functions' disabled it, the current buffer is setup
+ to use Semantic, and `semantic-init-hook' is run."
+ ;; Do stuff if semantic was activated by a mode hook in this buffer,
+ ;; and not afterwards disabled.
+ (when (and semantic--parse-table
+ (not (semantic-active-p))
+ (not (run-hook-with-args-until-success
+ 'semantic-inhibit-functions)))
+ ;; Make sure that if this buffer is cloned, our tags and overlays
+ ;; don't go along for the ride.
+ (add-hook 'clone-indirect-buffer-hook 'semantic-clear-toplevel-cache
+ nil t)
+ ;; Specify that this function has done it's work. At this point
+ ;; we can consider that semantic is active in this buffer.
+ (setq semantic-new-buffer-fcn-was-run t)
+ ;; Here are some buffer local variables we can initialize ourselves
+ ;; of a mode does not choose to do so.
+ (semantic-lex-init)
+ ;; Force this buffer to have its cache refreshed.
+ (semantic-clear-toplevel-cache)
+ ;; Call DB hooks before regular init hooks
+ (run-hooks 'semantic-init-db-hook)
+ ;; Set up semantic modes
+ (run-hooks 'semantic-init-hook)
+ ;; Set up major-mode specific semantic modes
+ (run-hooks 'semantic-init-mode-hook)))
+
+ (defun semantic-fetch-tags-fast ()
+ "For use in a hook. When only a partial reparse is needed, reparse."
+ (condition-case nil
+ (if (semantic-parse-tree-needs-update-p)
+ (semantic-fetch-tags))
+ (error nil))
+ semantic--buffer-cache)
+ \f
+ ;;; Parsing Commands
+ ;;
+ (eval-when-compile
+ (condition-case nil (require 'pp) (error nil)))
+
+ (defvar semantic-edebug nil
+ "When non-nil, activate the interactive parsing debugger.
+ Do not set this yourself. Call `semantic-debug'.")
+
+ (defun semantic-elapsed-time (start end)
+ "Copied from elp.el. Was elp-elapsed-time.
+ Argument START and END bound the time being calculated."
+ (+ (* (- (car end) (car start)) 65536.0)
+ (- (car (cdr end)) (car (cdr start)))
+ (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0)))
+
+ (defun bovinate (&optional clear)
+ "Parse the current buffer. Show output in a temp buffer.
+ Optional argument CLEAR will clear the cache before parsing.
+ If CLEAR is negative, it will do a full reparse, and also not display
+ the output buffer."
+ (interactive "P")
+ (if clear (semantic-clear-toplevel-cache))
+ (if (eq clear '-) (setq clear -1))
+ (let* ((start (current-time))
+ (out (semantic-fetch-tags))
+ (end (current-time)))
+ (message "Retrieving tags took %.2f seconds."
+ (semantic-elapsed-time start end))
+ (when (or (null clear) (not (listp clear)))
+ (pop-to-buffer "*Parser Output*")
+ (require 'pp)
+ (erase-buffer)
+ (insert (pp-to-string out))
+ (goto-char (point-min)))))
+ \f
+ ;;; Functions of the parser plug-in API
+ ;;
+ ;; Overload these functions to create new types of parsers.
+ ;;
+ (define-overloadable-function semantic-parse-stream (stream nonterminal)
+ "Parse STREAM, starting at the first NONTERMINAL rule.
+ For bovine and wisent based parsers, STREAM is from the output of
+ `semantic-lex', and NONTERMINAL is a rule in the apropriate language
+ specific rules file.
+ The default parser table used for bovine or wisent based parsers is
+ `semantic--parse-table'.
+
+ Must return a list: (STREAM TAGS) where STREAM is the unused elements
+ from STREAM, and TAGS is the list of semantic tags found, usually only
+ one tag is returned with the exception of compound statements")
+
+ (define-overloadable-function semantic-parse-changes ()
+ "Reparse changes in the current buffer.
+ The list of changes are tracked as a series of overlays in the buffer.
+ When overloading this function, use `semantic-changes-in-region' to
+ analyze.")
+
+ (define-overloadable-function semantic-parse-region
+ (start end &optional nonterminal depth returnonerror)
+ "Parse the area between START and END, and return any tags found.
+ If END needs to be extended due to a lexical token being too large, it
+ will be silently ignored.
+
+ Optional arguments:
+ NONTERMINAL is the rule to start parsing at.
+ DEPTH specifies the lexical depth to decend for parser that use
+ lexical analysis as their first step.
+ RETURNONERROR specifies that parsing should stop on the first
+ unmatched syntax encountered. When nil, parsing skips the syntax,
+ adding it to the unmatched syntax cache.
+
+ Must return a list of semantic tags wich have been cooked
+ \(repositioned properly) but which DO NOT HAVE OVERLAYS associated
+ with them. When overloading this function, use `semantic--tag-expand'
+ to cook raw tags.")
+
+ (defun semantic-parse-region-default
+ (start end &optional nonterminal depth returnonerror)
+ "Parse the area between START and END, and return any tags found.
+ If END needs to be extended due to a lexical token being too large, it
+ will be silently ignored.
+ Optional arguments:
+ NONTERMINAL is the rule to start parsing at if it is known.
+ DEPTH specifies the lexical depth to scan.
+ RETURNONERROR specifies that parsing should end when encountering
+ unterminated syntax."
+ (when (or (null semantic--parse-table) (eq semantic--parse-table t))
+ ;; If there is no table, or it was set to t, then we are here by
+ ;; some other mistake. Do not throw an error deep in the parser.
+ (error "No support found to parse buffer %S" (buffer-name)))
+ (save-restriction
+ (widen)
+ (when (or (< end start) (> end (point-max)))
+ (error "Invalid parse region bounds %S, %S" start end))
+ (nreverse
+ (semantic-repeat-parse-whole-stream
+ (or (cdr (assq start semantic-lex-block-streams))
+ (semantic-lex start end depth))
+ nonterminal returnonerror))))
+ \f
+ ;;; Parsing functions
+ ;;
+ (defun semantic-set-unmatched-syntax-cache (unmatched-syntax)
+ "Set the unmatched syntax cache.
+ Argument UNMATCHED-SYNTAX is the syntax to set into the cache."
+ ;; This function is not actually called by the main parse loop.
+ ;; This is intended for use by semanticdb.
+ (setq semantic-unmatched-syntax-cache unmatched-syntax
+ semantic-unmatched-syntax-cache-check nil)
+ ;; Refresh the display of unmatched syntax tokens if enabled
+ (run-hook-with-args 'semantic-unmatched-syntax-hook
+ semantic-unmatched-syntax-cache))
+
+ (defun semantic-clear-unmatched-syntax-cache ()
+ "Clear the cache of unmatched syntax tokens."
+ (setq semantic-unmatched-syntax-cache nil
+ semantic-unmatched-syntax-cache-check t))
+
+ (defun semantic-unmatched-syntax-tokens ()
+ "Return the list of unmatched syntax tokens."
+ ;; If the cache need refresh then do a full re-parse.
+ (if (semantic--umatched-syntax-needs-refresh-p)
+ ;; To avoid a recursive call, temporarily disable
+ ;; `semantic-unmatched-syntax-hook'.
+ (let (semantic-unmatched-syntax-hook)
+ (condition-case nil
+ (progn
+ (semantic-clear-toplevel-cache)
+ (semantic-fetch-tags))
+ (quit
+ (message "semantic-unmatched-syntax-tokens:\
+ parsing of buffer canceled"))
+ )))
+ semantic-unmatched-syntax-cache)
+
+ (defun semantic-clear-toplevel-cache ()
+ "Clear the toplevel tag cache for the current buffer.
+ Clearing the cache will force a complete reparse next time a tag list
+ is requested."
+ (interactive)
+ (run-hooks 'semantic-before-toplevel-cache-flush-hook)
+ (setq semantic--buffer-cache nil)
+ (semantic-clear-unmatched-syntax-cache)
+ (semantic-clear-parser-warnings)
+ ;; Nuke all semantic overlays. This is faster than deleting based
+ ;; on our data structure.
+ (let ((l (semantic-overlay-lists)))
+ (mapc 'semantic-delete-overlay-maybe (car l))
+ (mapc 'semantic-delete-overlay-maybe (cdr l))
+ )
+ (semantic-parse-tree-set-needs-rebuild)
+ ;; Remove this hook which tracks if a buffer is up to date or not.
+ (remove-hook 'after-change-functions 'semantic-change-function t)
+ ;; Old model. Delete someday.
+ ;;(run-hooks 'semantic-after-toplevel-bovinate-hook)
+
+ (run-hook-with-args 'semantic-after-toplevel-cache-change-hook
+ semantic--buffer-cache)
+
+ (setq semantic--completion-cache nil))
+
+ (defvar semantic-bovinate-nonterminal-check-obarray)
+
+ (defun semantic--set-buffer-cache (tagtable)
+ "Set the toplevel cache cache to TAGTABLE."
+ (setq semantic--buffer-cache tagtable
+ semantic-unmatched-syntax-cache-check nil)
+ ;; This is specific to the bovine parser.
+ (set (make-local-variable 'semantic-bovinate-nonterminal-check-obarray)
+ nil)
+ (semantic-parse-tree-set-up-to-date)
+ (semantic-make-local-hook 'after-change-functions)
+ (add-hook 'after-change-functions 'semantic-change-function nil t)
+ (run-hook-with-args 'semantic-after-toplevel-cache-change-hook
+ semantic--buffer-cache)
+ (setq semantic--completion-cache nil)
+ ;; Refresh the display of unmatched syntax tokens if enabled
+ (run-hook-with-args 'semantic-unmatched-syntax-hook
+ semantic-unmatched-syntax-cache)
+ ;; Old Semantic 1.3 hook API. Maybe useful forever?
+ (run-hooks 'semantic-after-toplevel-bovinate-hook)
+ )
+
+ (defvar semantic-working-type 'percent
+ "*The type of working message to use when parsing.
+ 'percent means we are doing a linear parse through the buffer.
+ 'dynamic means we are reparsing specific tags.")
+ (semantic-varalias-obsolete 'semantic-bovination-working-type
+ 'semantic-working-type)
+
+ (defvar semantic-minimum-working-buffer-size (* 1024 5)
+ "*The minimum size of a buffer before working messages are displayed.
+ Buffers smaller than will parse silently.
+ Bufferse larger than this will display the working progress bar.")
+
+ (defsubst semantic-parser-working-message (&optional arg)
+ "Return the message string displayed while parsing.
+ If optional argument ARG is non-nil it is appended to the message
+ string."
+ (concat "Parsing"
+ (if arg (format " %s" arg))
+ (if semantic-parser-name (format " (%s)" semantic-parser-name))
+ "..."))
+ \f
+ ;;; Application Parser Entry Points
+ ;;
+ ;; The best way to call the parser from programs is via
+ ;; `semantic-fetch-tags'. This, in turn, uses other internal
+ ;; API functions which plug-in parsers can take advantage of.
+
+ (defun semantic-fetch-tags ()
+ "Fetch semantic tags from the current buffer.
+ If the buffer cache is up to date, return that.
+ If the buffer cache is out of date, attempt an incremental reparse.
+ If the buffer has not been parsed before, or if the incremental reparse
+ fails, then parse the entire buffer.
+ If a lexcial error had been previously discovered and the buffer
+ was marked unparseable, then do nothing, and return the cache."
+ (and
+ ;; Is this a semantic enabled buffer?
+ (semantic-active-p)
+ ;; Application hooks say the buffer is safe for parsing
+ (run-hook-with-args-until-failure
+ 'semantic-before-toplevel-bovination-hook)
+ (run-hook-with-args-until-failure
+ 'semantic--before-fetch-tags-hook)
+ ;; If the buffer was previously marked unparseable,
+ ;; then don't waste our time.
+ (not (semantic-parse-tree-unparseable-p))
+ ;; The parse tree actually needs to be refreshed
+ (not (semantic-parse-tree-up-to-date-p))
+ ;; So do it!
+ (let* ((gc-cons-threshold (max gc-cons-threshold 10000000))
+ (semantic-lex-block-streams nil)
+ (res nil))
+ (garbage-collect)
+ (cond
+
+ ;;;; Try the incremental parser to do a fast update.
+ ((semantic-parse-tree-needs-update-p)
+ (setq res (semantic-parse-changes))
+ (if (semantic-parse-tree-needs-rebuild-p)
+ ;; If the partial reparse fails, jump to a full reparse.
+ (semantic-fetch-tags)
+ ;; Clear the cache of unmatched syntax tokens
+ ;;
+ ;; NOTE TO SELF:
+ ;;
+ ;; Move this into the incremental parser. This is a bug.
+ ;;
+ (semantic-clear-unmatched-syntax-cache)
+ (run-hook-with-args ;; Let hooks know the updated tags
+ 'semantic-after-partial-cache-change-hook res))
+ (setq semantic--completion-cache nil))
+
+ ;;;; Parse the whole system.
+ ((semantic-parse-tree-needs-rebuild-p)
+ ;; Use Emacs' built-in progress-reporter
+ (let ((semantic--progress-reporter
+ (and (>= (point-max) semantic-minimum-working-buffer-size)
+ (eq semantic-working-type 'percent)
+ (make-progress-reporter
+ (semantic-parser-working-message (buffer-name))
+ 0 100))))
+ (setq res (semantic-parse-region (point-min) (point-max)))
+ (if semantic--progress-reporter
+ (progress-reporter-done semantic--progress-reporter)))
+
+ ;; Clear the caches when we see there were no errors.
+ ;; But preserve the unmatched syntax cache and warnings!
+ (let (semantic-unmatched-syntax-cache
+ semantic-unmatched-syntax-cache-check
+ semantic-parser-warnings)
+ (semantic-clear-toplevel-cache))
+ ;; Set up the new overlays
+ (semantic--tag-link-list-to-buffer res)
+ ;; Set up the cache with the new results
+ (semantic--set-buffer-cache res)
+ ))))
+
+ ;; Always return the current parse tree.
+ semantic--buffer-cache)
+
+ (defun semantic-refresh-tags-safe ()
+ "Refreshes the current buffer's tags safely.
+
+ Return non-nil if the refresh was successful.
+ Return nil if there is some sort of syntax error preventing a reparse.
+
+ Does nothing if the current buffer doesn't need reparsing."
+
+ ;; These checks actually occur in `semantic-fetch-tags', but if we
+ ;; do them here, then all the bovination hooks are not run, and
+ ;; we save lots of time.
+ (cond
+ ;; If the buffer was previously marked unparseable,
+ ;; then don't waste our time.
+ ((semantic-parse-tree-unparseable-p)
+ nil)
+ ;; The parse tree is already ok.
+ ((semantic-parse-tree-up-to-date-p)
+ t)
+ (t
+ (let* ((inhibit-quit nil)
+ (lexically-safe t)
+ )
+
+ (unwind-protect
+ ;; Perform the parsing.
+ (progn
+ (when (semantic-lex-catch-errors safe-refresh
+ (save-excursion (semantic-fetch-tags))
+ nil)
+ ;; If we are here, it is because the lexical step failed,
+ ;; proably due to unterminated lists or something like that.
+
+ ;; We do nothing, and just wait for the next idle timer
+ ;; to go off. In the meantime, remember this, and make sure
+ ;; no other idle services can get executed.
+ (setq lexically-safe nil))
+ )
+ )
+ ;; Return if we are lexically safe
+ lexically-safe))))
+
+ (defun semantic-bovinate-toplevel (&optional ignored)
+ "Backward Compatibility Function."
+ (semantic-fetch-tags))
+ (make-obsolete 'semantic-bovinate-toplevel 'semantic-fetch-tags)
+
+ ;; Another approach is to let Emacs call the parser on idle time, when
+ ;; needed, use `semantic-fetch-available-tags' to only retrieve
+ ;; available tags, and setup the `semantic-after-*-hook' hooks to
+ ;; synchronize with new tags when they become available.
+
+ (defsubst semantic-fetch-available-tags ()
+ "Fetch available semantic tags from the current buffer.
+ That is, return tags currently in the cache without parsing the
+ current buffer.
+ Parse operations happen asynchronously when needed on Emacs idle time.
+ Use the `semantic-after-toplevel-cache-change-hook' and
+ `semantic-after-partial-cache-change-hook' hooks to synchronize with
+ new tags when they become available."
+ semantic--buffer-cache)
+ \f
+ ;;; Iterative parser helper function
+ ;;
+ ;; Iterative parsers are better than rule-based iterative functions
+ ;; in that they can handle obscure errors more cleanly.
+ ;;
+ ;; `semantic-repeat-parse-whole-stream' abstracts this action for
+ ;; other parser centric routines.
+ ;;
+ (defun semantic-repeat-parse-whole-stream
+ (stream nonterm &optional returnonerror)
+ "Iteratively parse the entire stream STREAM starting with NONTERM.
+ Optional argument RETURNONERROR indicates that the parser should exit
+ with the current results on a parse error.
+ This function returns semantic tags without overlays."
+ (let ((result nil)
+ (case-fold-search semantic-case-fold)
+ nontermsym tag)
+ (while stream
+ (setq nontermsym (semantic-parse-stream stream nonterm)
+ tag (car (cdr nontermsym)))
+ (if (not nontermsym)
+ (error "Parse error @ %d" (car (cdr (car stream)))))
+ (if (eq (car nontermsym) stream)
+ (error "Parser error: Infinite loop?"))
+ (if tag
+ (if (car tag)
+ (setq tag (mapcar
+ #'(lambda (tag)
+ ;; Set the 'reparse-symbol property to
+ ;; NONTERM unless it was already setup
+ ;; by a tag expander
+ (or (semantic--tag-get-property
+ tag 'reparse-symbol)
+ (semantic--tag-put-property
+ tag 'reparse-symbol nonterm))
+ tag)
+ (semantic--tag-expand tag))
+ result (append tag result))
+ ;; No error in this case, a purposeful nil means don't
+ ;; store anything.
+ )
+ (if returnonerror
+ (setq stream nil)
+ ;; The current item in the stream didn't match, so add it to
+ ;; the list of syntax items which didn't match.
+ (setq semantic-unmatched-syntax-cache
+ (cons (car stream) semantic-unmatched-syntax-cache))
+ ))
+ ;; Designated to ignore.
+ (setq stream (car nontermsym))
+ (if stream
+ ;; Use Emacs' built-in progress reporter:
+ (and (boundp 'semantic--progress-reporter)
+ semantic--progress-reporter
+ (eq semantic-working-type 'percent)
+ (progress-reporter-update
+ semantic--progress-reporter
+ (/ (* 100 (semantic-lex-token-start (car stream)))
+ (point-max))))))
+ result))
+ \f
+ ;;; Parsing Warnings:
+ ;;
+ ;; Parsing a buffer may result in non-critical things that we should
+ ;; alert the user to without interrupting the normal flow.
+ ;;
+ ;; Any parser can use this API to provide a list of warnings during a
+ ;; parse which a user may want to investigate.
+ (defvar semantic-parser-warnings nil
+ "A list of parser warnings since the last full reparse.")
+ (make-variable-buffer-local 'semantic-parser-warnings)
+
+ (defun semantic-clear-parser-warnings ()
+ "Clear the current list of parser warnings for this buffer."
+ (setq semantic-parser-warnings nil))
+
+ (defun semantic-push-parser-warning (warning start end)
+ "Add a parser WARNING that covers text from START to END."
+ (setq semantic-parser-warnings
+ (cons (cons warning (cons start end))
+ semantic-parser-warnings)))
+
+ (defun semantic-dump-parser-warnings ()
+ "Dump any parser warnings."
+ (interactive)
+ (if semantic-parser-warnings
+ (let ((pw semantic-parser-warnings))
+ (pop-to-buffer "*Parser Warnings*")
+ (require 'pp)
+ (erase-buffer)
+ (insert (pp-to-string pw))
+ (goto-char (point-min)))
+ (message "No parser warnings.")))
+
+
+ \f
+ ;;; Compatibility:
+ ;;
+ ;; Semantic 1.x parser action helper functions, used by some parsers.
+ ;; Please move away from these functions, and try using semantic 2.x
+ ;; interfaces instead.
+ ;;
+ (defsubst semantic-bovinate-region-until-error
+ (start end nonterm &optional depth)
+ "NOTE: Use `semantic-parse-region' instead.
+
+ Bovinate between START and END starting with NONTERM.
+ Optional DEPTH specifies how many levels of parenthesis to enter.
+ This command will parse until an error is encountered, and return
+ the list of everything found until that moment.
+ This is meant for finding variable definitions at the beginning of
+ code blocks in methods. If `bovine-inner-scope' can also support
+ commands, use `semantic-bovinate-from-nonterminal-full'."
+ (semantic-parse-region start end nonterm depth t))
+ (make-obsolete 'semantic-bovinate-region-until-error
+ 'semantic-parse-region)
+
+ (defsubst semantic-bovinate-from-nonterminal
+ (start end nonterm &optional depth length)
+ "Bovinate from within a nonterminal lambda from START to END.
+ Argument NONTERM is the nonterminal symbol to start with.
+ Optional argument DEPTH is the depth of lists to dive into. When used
+ in a `lambda' of a MATCH-LIST, there is no need to include a START and
+ END part.
+ Optional argument LENGTH specifies we are only interested in LENGTH
+ tokens."
+ (car-safe (cdr (semantic-parse-stream
+ (semantic-lex start end (or depth 1) length)
+ nonterm))))
+
+ (defsubst semantic-bovinate-from-nonterminal-full
+ (start end nonterm &optional depth)
+ "NOTE: Use `semantic-parse-region' instead.
+
+ Bovinate from within a nonterminal lambda from START to END.
+ Iterates until all the space between START and END is exhausted.
+ Argument NONTERM is the nonterminal symbol to start with.
+ If NONTERM is nil, use `bovine-block-toplevel'.
+ Optional argument DEPTH is the depth of lists to dive into.
+ When used in a `lambda' of a MATCH-LIST, there is no need to include
+ a START and END part."
+ (semantic-parse-region start end nonterm (or depth 1)))
+ (make-obsolete 'semantic-bovinate-from-nonterminal-full
+ 'semantic-parse-region)
+
+ ;;; User interface
+
+ (defun semantic-force-refresh ()
+ "Force a full refresh of the current buffer's tags.
+ Throw away all the old tags, and recreate the tag database."
+ (interactive)
+ (semantic-clear-toplevel-cache)
+ (semantic-fetch-tags)
+ (message "Buffer reparsed."))
+
+ (defvar semantic-mode-map
+ (let ((map (make-sparse-keymap)))
+ ;; Key bindings:
+ ;; (define-key km "f" 'senator-search-set-tag-class-filter)
+ ;; (define-key km "i" 'senator-isearch-toggle-semantic-mode)
+ (define-key map "\C-c,j" 'semantic-complete-jump-local)
+ (define-key map "\C-c,J" 'semantic-complete-jump)
+ (define-key map "\C-c,g" 'semantic-symref-symbol)
+ (define-key map "\C-c,G" 'semantic-symref)
+ (define-key map "\C-c,p" 'senator-previous-tag)
+ (define-key map "\C-c,n" 'senator-next-tag)
+ (define-key map "\C-c,u" 'senator-go-to-up-reference)
+ (define-key map "\C-c, " 'semantic-complete-analyze-inline)
+ (define-key map "\C-c,\C-w" 'senator-kill-tag)
+ (define-key map "\C-c,\M-w" 'senator-copy-tag)
+ (define-key map "\C-c,\C-y" 'senator-yank-tag)
+ (define-key map "\C-c,r" 'senator-copy-tag-to-register)
+ (define-key map [?\C-c ?, up] 'senator-transpose-tags-up)
+ (define-key map [?\C-c ?, down] 'senator-transpose-tags-down)
+ (define-key map "\C-c,l" 'semantic-analyze-possible-completions)
+ ;; This hack avoids showing the CEDET menu twice if ede-minor-mode
+ ;; and Semantic are both enabled. Is there a better way?
+ (define-key map [menu-bar cedet-menu]
+ (list 'menu-item "Development" cedet-menu-map
+ :enable (quote (not (bound-and-true-p global-ede-mode)))))
+ ;; (define-key km "-" 'senator-fold-tag)
+ ;; (define-key km "+" 'senator-unfold-tag)
+ map))
+
+ ;; Activate the Semantic items in cedet-menu-map
+ (let ((navigate-menu (make-sparse-keymap "Navigate Tags"))
+ (edit-menu (make-sparse-keymap "Edit Tags")))
+
+ ;; Edit Tags submenu:
+ (define-key edit-menu [semantic-analyze-possible-completions]
+ '(menu-item "List Completions" semantic-analyze-possible-completions
+ :help "Display a list of completions for the tag at point"))
+ (define-key edit-menu [semantic-complete-analyze-inline]
+ '(menu-item "Complete Tag Inline" semantic-complete-analyze-inline
+ :help "Display inline completion for the tag at point"))
+ (define-key edit-menu [semantic-completion-separator]
+ '("--"))
+ (define-key edit-menu [senator-transpose-tags-down]
+ '(menu-item "Transpose Tags Down" senator-transpose-tags-down
+ :active (semantic-current-tag)
+ :help "Transpose the current tag and the next tag"))
+ (define-key edit-menu [senator-transpose-tags-up]
+ '(menu-item "Transpose Tags Up" senator-transpose-tags-up
+ :active (semantic-current-tag)
+ :help "Transpose the current tag and the previous tag"))
+ (define-key edit-menu [semantic-edit-separator]
+ '("--"))
+ (define-key edit-menu [senator-yank-tag]
+ '(menu-item "Yank Tag" senator-yank-tag
+ :active (not (ring-empty-p senator-tag-ring))
+ :help "Yank the head of the tag ring into the buffer"))
+ (define-key edit-menu [senator-copy-tag-to-register]
+ '(menu-item "Copy Tag To Register" senator-copy-tag-to-register
+ :active (semantic-current-tag)
+ :help "Yank the head of the tag ring into the buffer"))
+ (define-key edit-menu [senator-copy-tag]
+ '(menu-item "Copy Tag" senator-copy-tag
+ :active (semantic-current-tag)
+ :help "Copy the current tag to the tag ring"))
+ (define-key edit-menu [senator-kill-tag]
+ '(menu-item "Kill Tag" senator-kill-tag
+ :active (semantic-current-tag)
+ :help "Kill the current tag, and copy it to the tag ring"))
+
+ ;; Navigate Tags submenu:
+ (define-key navigate-menu [senator-narrow-to-defun]
+ '(menu-item "Narrow to Tag" senator-narrow-to-defun
+ :active (semantic-current-tag)
+ :help "Narrow the buffer to the bounds of the current tag"))
+ (define-key navigate-menu [semantic-narrow-to-defun-separator]
+ '("--"))
+ (define-key navigate-menu [semantic-symref-symbol]
+ '(menu-item "Find Tag References..." semantic-symref-symbol
+ :help "Read a tag and list the references to it"))
+ (define-key navigate-menu [semantic-complete-jump]
+ '(menu-item "Find Tag Globally..." semantic-complete-jump
+ :help "Read a tag name and find it in the current project"))
+ (define-key navigate-menu [semantic-complete-jump-local]
+ '(menu-item "Find Tag in This Buffer..." semantic-complete-jump-local
+ :help "Read a tag name and find it in this buffer"))
+ (define-key navigate-menu [semantic-navigation-separator]
+ '("--"))
+ (define-key navigate-menu [senator-go-to-up-reference]
+ '(menu-item "Parent Tag" senator-go-to-up-reference
+ :help "Navigate up one reference by tag."))
+ (define-key navigate-menu [senator-next-tag]
+ '(menu-item "Next Tag" senator-next-tag
+ :help "Go to the next tag"))
+ (define-key navigate-menu [senator-previous-tag]
+ '(menu-item "Previous Tag" senator-previous-tag
+ :help "Go to the previous tag"))
+
+ ;; Top level menu items:
+ (define-key cedet-menu-map [semantic-force-refresh]
+ '(menu-item "Reparse Buffer" semantic-force-refresh
+ :help "Force a full reparse of the current buffer."
+ :visible semantic-mode))
+ (define-key cedet-menu-map [semantic-edit-menu]
+ `(menu-item "Edit Tags" ,edit-menu
+ :visible semantic-mode))
+ (define-key cedet-menu-map [navigate-menu]
+ `(menu-item "Navigate Tags" ,navigate-menu
+ :visible semantic-mode))
+ (define-key cedet-menu-map [semantic-options-separator]
+ '("--"))
+ (define-key cedet-menu-map [global-semantic-highlight-func-mode]
+ '(menu-item "Highlight Current Function" global-semantic-highlight-func-mode
+ :help "Highlight the tag at point"
+ :visible semantic-mode
+ :button (:toggle . global-semantic-highlight-func-mode)))
+ (define-key cedet-menu-map [global-semantic-decoration-mode]
+ '(menu-item "Decorate Tags" global-semantic-decoration-mode
+ :help "Decorate tags based on tag attributes"
+ :visible semantic-mode
+ :button (:toggle . (bound-and-true-p
+ global-semantic-decoration-mode))))
+ (define-key cedet-menu-map [global-semantic-idle-completions-mode]
+ '(menu-item "Show Tag Completions" global-semantic-idle-completions-mode
+ :help "Show tag completions when idle"
+ :visible semantic-mode
+ :button (:toggle . global-semantic-idle-completions-mode)))
+ (define-key cedet-menu-map [global-semantic-idle-summary-mode]
+ '(menu-item "Show Tag Summaries" global-semantic-idle-summary-mode
+ :help "Show tag summaries when idle"
+ :visible semantic-mode
+ :button (:toggle . global-semantic-idle-summary-mode)))
+ (define-key cedet-menu-map [global-semanticdb-minor-mode]
+ '(menu-item "Semantic Database" global-semanticdb-minor-mode
+ :help "Store tag information in a database"
+ :visible semantic-mode
+ :button (:toggle . global-semanticdb-minor-mode)))
+ (define-key cedet-menu-map [global-semantic-idle-scheduler-mode]
+ '(menu-item "Reparse When Idle" global-semantic-idle-scheduler-mode
+ :help "Keep a buffer's parse tree up to date when idle"
+ :visible semantic-mode
+ :button (:toggle . global-semantic-idle-scheduler-mode)))
+ (define-key cedet-menu-map [ede-menu-separator] 'undefined)
+ (define-key cedet-menu-map [cedet-menu-separator] 'undefined)
+ (define-key cedet-menu-map [semantic-menu-separator] '("--")))
+
+ ;; The `semantic-mode' command, in conjuction with the
+ ;; `semantic-default-submodes' variable, toggles Semantic's various
+ ;; auxilliary minor modes.
+
+ (defvar semantic-load-system-cache-loaded nil
+ "Non nil when the Semantic system caches have been loaded.
+ Prevent this load system from loading files in twice.")
+
+ (defconst semantic-submode-list
+ '(global-semantic-highlight-func-mode
+ global-semantic-decoration-mode
+ global-semantic-stickyfunc-mode
+ global-semantic-idle-completions-mode
+ global-semantic-idle-scheduler-mode
+ global-semanticdb-minor-mode
+ global-semantic-idle-summary-mode
+ global-semantic-mru-bookmark-mode)
+ "List of auxilliary minor modes in the Semantic package.")
+
+ ;;;###autoload
+ (defcustom semantic-default-submodes
+ '(global-semantic-idle-scheduler-mode global-semanticdb-minor-mode)
+ "List of auxilliary Semantic minor modes enabled by `semantic-mode'.
+ The possible elements of this list include the following:
+
+ `semantic-highlight-func-mode' - Highlight the current tag.
+ `semantic-decoration-mode' - Decorate tags based on various attributes.
+ `semantic-stickyfunc-mode' - Track current function in the header-line.
+ `semantic-idle-completions-mode' - Provide smart symbol completion
+ automatically when idle.
+ `semantic-idle-scheduler-mode' - Keep a buffer's parse tree up to date.
+ `semanticdb-minor-mode' - Store tags when a buffer is not in memory.
+ `semantic-idle-summary-mode' - Show a summary for the code at point.
+ `semantic-mru-bookmark-mode' - Provide `switch-to-buffer'-like
+ keybinding for tag names."
+ :group 'semantic
+ :type `(set ,@(mapcar (lambda (c) (list 'const c))
+ semantic-submode-list)))
+
+ ;;;###autoload
+ (define-minor-mode semantic-mode
+ "Toggle Semantic mode.
+ With ARG, turn Semantic mode on if ARG is positive, off otherwise.
+
+ In Semantic mode, Emacs parses the buffers you visit for their
+ semantic content. This information is used by a variety of
+ auxilliary minor modes, listed in `semantic-default-submodes';
+ all the minor modes in this list are also enabled when you enable
+ Semantic mode.
+
+ \\{semantic-mode-map}"
+ :global t
+ :group 'semantic
+ (if semantic-mode
+ ;; Turn on Semantic mode
+ (progn
+ ;; Enable all the global auxilliary minor modes in
+ ;; `semantic-submode-list'.
+ (dolist (mode semantic-submode-list)
+ (if (memq mode semantic-default-submodes)
+ (funcall mode 1)))
+ (unless semantic-load-system-cache-loaded
+ (setq semantic-load-system-cache-loaded t)
+ (when (and (boundp 'semanticdb-default-system-save-directory)
+ (stringp semanticdb-default-system-save-directory)
+ (file-exists-p semanticdb-default-system-save-directory))
+ (require 'semantic/db-ebrowse)
+ (semanticdb-load-ebrowse-caches)))
+ (add-hook 'mode-local-init-hook 'semantic-new-buffer-fcn)
+ ;; Add mode-local hooks
+ (add-hook 'javascript-mode-hook 'wisent-javascript-setup-parser)
+ (add-hook 'ecmascript-mode-hook 'wisent-javascript-setup-parser)
+ (add-hook 'java-mode-hook 'wisent-java-default-setup)
+ (add-hook 'scheme-mode-hook 'semantic-default-scheme-setup)
+ (add-hook 'makefile-mode-hook 'semantic-default-make-setup)
+ (add-hook 'c-mode-hook 'semantic-default-c-setup)
+ (add-hook 'c++-mode-hook 'semantic-default-c-setup)
+ (add-hook 'html-mode-hook 'semantic-default-html-setup))
+ ;; Disable all Semantic features.
+ (remove-hook 'mode-local-init-hook 'semantic-new-buffer-fcn)
+ (remove-hook 'javascript-mode-hook 'wisent-javascript-setup-parser)
+ (remove-hook 'ecmascript-mode-hook 'wisent-javascript-setup-parser)
+ (remove-hook 'java-mode-hook 'wisent-java-default-setup)
+ (remove-hook 'scheme-mode-hook 'semantic-default-scheme-setup)
+ (remove-hook 'makefile-mode-hook 'semantic-default-make-setup)
+ (remove-hook 'c-mode-hook 'semantic-default-c-setup)
+ (remove-hook 'c++-mode-hook 'semantic-default-c-setup)
+ (remove-hook 'html-mode-hook 'semantic-default-html-setup)
+
+ ;; FIXME: handle semanticdb-load-ebrowse-caches
+ (dolist (mode semantic-submode-list)
+ (if (and (boundp mode) (eval mode))
+ (funcall mode -1)))))
+
+ ;;; Autoload some functions that are not in semantic/loaddefs
+
+ (autoload 'global-semantic-idle-completions-mode "semantic/idle"
+ "Toggle global use of `semantic-idle-completions-mode'.
+ If ARG is positive, enable, if it is negative, disable.
+ If ARG is nil, then toggle." t nil)
+
+ (autoload 'semantic-idle-completions-mode "semantic/idle"
+ "Display a list of possible completions in a tooltip.
+
+ This is a minor mode which performs actions during idle time.
+ 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." t nil)
+
+ (autoload 'global-semantic-idle-summary-mode "semantic/idle"
+ "Toggle global use of `semantic-idle-summary-mode'.
+ If ARG is positive, enable, if it is negative, disable.
+ If ARG is nil, then toggle." t nil)
+
+ (autoload 'semantic-idle-summary-mode "semantic/idle"
+ "Display a tag summary of the lexical token under the cursor.
+ Call `semantic-idle-summary-current-symbol-info' for getting the
+ current tag to display information.
+
+ This is a minor mode which performs actions during idle time.
+ 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." t nil)
+
+ (provide 'semantic)
+
+ ;; Semantic-util is a part of the semantic API. Include it last
+ ;; because it depends on semantic.
+ (require 'semantic/util)
+
+ ;; (require 'semantic/load)
+
+ ;;; semantic.el ends here
--- /dev/null
-;;
+ ;;; semantic/analyze.el --- Analyze semantic tags against local context
+
+ ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Semantic, as a tool, provides a nice list of searchable tags.
+ ;; That information can provide some very accurate answers if the current
+ ;; context of a position is known.
+ ;;
+ ;; Semantic-ctxt provides ways of analyzing, and manipulating the
+ ;; semantic context of a language in code.
+ ;;
+ ;; This library provides routines for finding intelligent answers to
+ ;; tough problems, such as if an argument to a function has the correct
+ ;; return type, or all possible tags that fit in a given local context.
+ ;;
+
+ ;;; Vocabulary:
+ ;;
+ ;; Here are some words used to describe different things in the analyzer:
+ ;;
+ ;; tag - A single entity
+ ;; prefix - The beginning of a symbol, usually used to look up something
+ ;; incomplete.
+ ;; type - The name of a datatype in the langauge.
+ ;; metatype - If a type is named in a declaration like:
+ ;; struct moose somevariable;
+ ;; that name "moose" can be turned into a concrete type.
+ ;; tag sequence - In C code, a list of dereferences, such as:
+ ;; this.that.theother();
+ ;; parent - For a datatype in an OO language, another datatype
+ ;; inherited from. This excludes interfaces.
+ ;; scope - A list of tags that can be dereferenced that cannot
+ ;; be found from the global namespace.
+ ;; scopetypes - A list of tags which are datatype that contain
+ ;; the scope. The scopetypes need to have the scope extracted
+ ;; in a way that honors the type of inheritance.
+ ;; nest/nested - When one tag is contained entirely in another.
+ ;;
+ ;; context - A semantic datatype representing a point in a buffer.
+ ;;
+ ;; constriant - If a context specifies a specific datatype is needed,
+ ;; that is a constraint.
+ ;; constants - Some datatypes define elements of themselves as a
+ ;; constant. These need to be returned as there would be no
+ ;; other possible completions.
-(require 'semantic/sort)
-(eval-when-compile (require 'semantic/find))
++
+ (require 'semantic)
+ (require 'semantic/format)
+ (require 'semantic/ctxt)
- "*Function to use when creating items in Imenu.
+ (require 'semantic/scope)
++(require 'semantic/sort)
+ (require 'semantic/analyze/fcn)
+
++(eval-when-compile (require 'semantic/find))
++
+ (declare-function data-debug-new-buffer "data-debug")
+ (declare-function data-debug-insert-object-slots "eieio-datadebug")
+
+ ;;; Code:
+ (defvar semantic-analyze-error-stack nil
+ "Collection of any errors thrown during analysis.")
+
+ (defun semantic-analyze-push-error (err)
+ "Push the error in ERR-DATA onto the error stack.
+ Argument ERR"
+ (push err semantic-analyze-error-stack))
+
+ ;;; Analysis Classes
+ ;;
+ ;; These classes represent what a context is. Different types
+ ;; of contexts provide differing amounts of information to help
+ ;; provide completions.
+ ;;
+ (defclass semantic-analyze-context ()
+ ((bounds :initarg :bounds
+ :type list
+ :documentation "The bounds of this context.
+ Usually bound to the dimension of a single symbol or command.")
+ (prefix :initarg :prefix
+ :type list
+ :documentation "List of tags defining local text.
+ This can be nil, or a list where the last element can be a string
+ representing text that may be incomplete. Preceeding elements
+ must be semantic tags representing variables or functions
+ called in a dereference sequence.")
+ (prefixclass :initarg :prefixclass
+ :type list
+ :documentation "Tag classes expected at this context.
+ These are clases for tags, such as 'function, or 'variable.")
+ (prefixtypes :initarg :prefixtypes
+ :type list
+ :documentation "List of tags defining types for :prefix.
+ This list is one shorter than :prefix. Each element is a semantic
+ tag representing a type matching the semantic tag in the same
+ position in PREFIX.")
+ (scope :initarg :scope
+ :type (or null semantic-scope-cache)
+ :documentation "List of tags available in scopetype.
+ See `semantic-analyze-scoped-tags' for details.")
+ (buffer :initarg :buffer
+ :type buffer
+ :documentation "The buffer this context is derived from.")
+ (errors :initarg :errors
+ :documentation "Any errors thrown an caught during analysis.")
+ )
+ "Base analysis data for a any context.")
+
+ (defclass semantic-analyze-context-assignment (semantic-analyze-context)
+ ((assignee :initarg :assignee
+ :type list
+ :documentation "A sequence of tags for an assignee.
+ This is a variable into which some value is being placed. The last
+ item in the list is the variable accepting the value. Earlier
+ tags represent the variables being derefernece to get to the
+ assignee."))
+ "Analysis class for a value in an assignment.")
+
+ (defclass semantic-analyze-context-functionarg (semantic-analyze-context)
+ ((function :initarg :function
+ :type list
+ :documentation "A sequence of tags for a function.
+ This is a function being called. The cursor will be in the position
+ of an argument.
+ The last tag in :function is the function being called. Earlier
+ tags represent the variables being dereferenced to get to the
+ function.")
+ (index :initarg :index
+ :type integer
+ :documentation "The index of the argument for this context.
+ If a function takes 4 arguments, this value should be bound to
+ the values 1 through 4.")
+ (argument :initarg :argument
+ :type list
+ :documentation "A sequence of tags for the :index argument.
+ The argument can accept a value of some type, and this contains the
+ tag for that definition. It should be a tag, but might
+ be just a string in some circumstances.")
+ )
+ "Analysis class for a value as a function argument.")
+
+ (defclass semantic-analyze-context-return (semantic-analyze-context)
+ () ; No extra data.
+ "Analysis class for return data.
+ Return data methods identify the requred type by the return value
+ of the parent function.")
+
+ ;;; METHODS
+ ;;
+ ;; Simple methods against the context classes.
+ ;;
+ (defmethod semantic-analyze-type-constraint
+ ((context semantic-analyze-context) &optional desired-type)
+ "Return a type constraint for completing :prefix in CONTEXT.
+ Optional argument DESIRED-TYPE may be a non-type tag to analyze."
+ (when (semantic-tag-p desired-type)
+ ;; Convert the desired type if needed.
+ (if (not (eq (semantic-tag-class desired-type) 'type))
+ (setq desired-type (semantic-tag-type desired-type)))
+ ;; Protect against plain strings
+ (cond ((stringp desired-type)
+ (setq desired-type (list desired-type 'type)))
+ ((and (stringp (car desired-type))
+ (not (semantic-tag-p desired-type)))
+ (setq desired-type (list (car desired-type) 'type)))
+ ((semantic-tag-p desired-type)
+ ;; We have a tag of some sort. Yay!
+ nil)
+ (t (setq desired-type nil))
+ )
+ desired-type))
+
+ (defmethod semantic-analyze-type-constraint
+ ((context semantic-analyze-context-functionarg))
+ "Return a type constraint for completing :prefix in CONTEXT."
+ (call-next-method context (car (oref context argument))))
+
+ (defmethod semantic-analyze-type-constraint
+ ((context semantic-analyze-context-assignment))
+ "Return a type constraint for completing :prefix in CONTEXT."
+ (call-next-method context (car (reverse (oref context assignee)))))
+
+ (defmethod semantic-analyze-interesting-tag
+ ((context semantic-analyze-context))
+ "Return a tag from CONTEXT that would be most interesting to a user."
+ (let ((prefix (reverse (oref context :prefix))))
+ ;; Go back through the prefix until we find a tag we can return.
+ (while (and prefix (not (semantic-tag-p (car prefix))))
+ (setq prefix (cdr prefix)))
+ ;; Return the found tag, or nil.
+ (car prefix)))
+
+ (defmethod semantic-analyze-interesting-tag
+ ((context semantic-analyze-context-functionarg))
+ "Try the base, and if that fails, return what we are assigning into."
+ (or (call-next-method) (car-safe (oref context :function))))
+
+ (defmethod semantic-analyze-interesting-tag
+ ((context semantic-analyze-context-assignment))
+ "Try the base, and if that fails, return what we are assigning into."
+ (or (call-next-method) (car-safe (oref context :assignee))))
+
+ ;;; ANALYSIS
+ ;;
+ ;; Start out with routines that will calculate useful parts of
+ ;; the general analyzer function. These could be used directly
+ ;; by an application that doesn't need to calculate the full
+ ;; context.
+
+ (define-overloadable-function semantic-analyze-find-tag-sequence (sequence &optional
+ scope typereturn throwsym)
+ "Attempt to find all tags in SEQUENCE.
+ Optional argument LOCALVAR is the list of local variables to use when
+ finding the details on the first element of SEQUENCE in case
+ it is not found in the global set of tables.
+ Optional argument SCOPE are additional terminals to search which are currently
+ scoped. These are not local variables, but symbols available in a structure
+ which doesn't need to be dereferneced.
+ Optional argument TYPERETURN is a symbol in which the types of all found
+ will be stored. If nil, that data is thrown away.
+ Optional argument THROWSYM specifies a symbol the throw on non-recoverable error.")
+
+ (defun semantic-analyze-find-tag-sequence-default (sequence &optional
+ scope typereturn
+ throwsym)
+ "Attempt to find all tags in SEQUENCE.
+ SCOPE are extra tags which are in scope.
+ TYPERETURN is a symbol in which to place a list of tag classes that
+ are found in SEQUENCE.
+ Optional argument THROWSYM specifies a symbol the throw on non-recoverable error."
+ (let ((s sequence) ; copy of the sequence
+ (tmp nil) ; tmp find variable
+ (tag nil) ; tag return list
+ (tagtype nil) ; tag types return list
+ (fname nil)
+ (miniscope (clone scope))
+ )
+ ;; First order check. Is this wholely contained in the typecache?
+ (setq tmp (semanticdb-typecache-find sequence))
+
+ (if tmp
+ (progn
+ ;; We are effectively done...
+ (setq s nil)
+ (setq tag (list tmp)))
+
+ ;; For the first entry, it better be a variable, but it might
+ ;; be in the local context too.
+ ;; NOTE: Don't forget c++ namespace foo::bar.
+ (setq tmp (or
+ ;; Is this tag within our scope. Scopes can sometimes
+ ;; shadow other things, so it goes first.
+ (and scope (semantic-scope-find (car s) nil scope))
+ ;; Find the tag out there... somewhere, but not in scope
+ (semantic-analyze-find-tag (car s))
+ ))
+
+ (if (and (listp tmp) (semantic-tag-p (car tmp)))
+ (setq tmp (semantic-analyze-select-best-tag tmp)))
+ (if (not (semantic-tag-p tmp))
+ (if throwsym
+ (throw throwsym "Cannot find definition")
+ (error "Cannot find definition for \"%s\"" (car s))))
+ (setq s (cdr s))
+ (setq tag (cons tmp tag)) ; tag is nil here...
+ (setq fname (semantic-tag-file-name tmp))
+ )
+
+ ;; For the middle entries
+ (while s
+ ;; Using the tag found in TMP, lets find the tag
+ ;; representing the full typeographic information of its
+ ;; type, and use that to determine the search context for
+ ;; (car s)
+ (let* ((tmptype
+ ;; In some cases the found TMP is a type,
+ ;; and we can use it directly.
+ (cond ((semantic-tag-of-class-p tmp 'type)
+ ;; update the miniscope when we need to analyze types directly.
+ (let ((rawscope
+ (apply 'append
+ (mapcar 'semantic-tag-type-members
+ tagtype))))
+ (oset miniscope fullscope rawscope))
+ ;; Now analayze the type to remove metatypes.
+ (or (semantic-analyze-type tmp miniscope)
+ tmp))
+ (t
+ (semantic-analyze-tag-type tmp scope))))
+ (typefile
+ (when tmptype
+ (semantic-tag-file-name tmptype)))
+ (slots nil))
+
+ ;; Get the children
+ (setq slots (semantic-analyze-scoped-type-parts tmptype scope))
+
+ ;; find (car s) in the list o slots
+ (setq tmp (semantic-find-tags-by-name (car s) slots))
+
+ ;; If we have lots
+ (if (and (listp tmp) (semantic-tag-p (car tmp)))
+ (setq tmp (semantic-analyze-select-best-tag tmp)))
+
+ ;; Make sure we have a tag.
+ (if (not (semantic-tag-p tmp))
+ (if (cdr s)
+ ;; In the middle, we need to keep seeking our types out.
+ (error "Cannot find definition for \"%s\"" (car s))
+ ;; Else, it's ok to end with a non-tag
+ (setq tmp (car s))))
+
+ (setq fname (or typefile fname))
+ (when (and fname (semantic-tag-p tmp)
+ (not (semantic-tag-in-buffer-p tmp)))
+ (semantic--tag-put-property tmp :filename fname))
+ (setq tag (cons tmp tag))
+ (setq tagtype (cons tmptype tagtype))
+ )
+ (setq s (cdr s)))
+
+ (if typereturn (set typereturn (nreverse tagtype)))
+ ;; Return the mess
+ (nreverse tag)))
+
+ (defun semantic-analyze-find-tag (name &optional tagclass scope)
+ "Return the first tag found with NAME or nil if not found.
+ Optional argument TAGCLASS specifies the class of tag to return, such
+ as 'function or 'variable.
+ Optional argument SCOPE specifies a scope object which has
+ additional tags which are in SCOPE and do not need prefixing to
+ find.
+
+ This is a wrapper on top of semanticdb, semanticdb-typecache,
+ semantic-scope, and semantic search functions. Almost all
+ searches use the same arguments."
+ (let ((namelst (if (consp name) name ;; test if pre-split.
+ (semantic-analyze-split-name name))))
+ (cond
+ ;; If the splitter gives us a list, use the sequence finder
+ ;; to get the list. Since this routine is expected to return
+ ;; only one tag, return the LAST tag found from the sequence
+ ;; which is supposedly the nested reference.
+ ;;
+ ;; Of note, the SEQUENCE function below calls this function
+ ;; (recursively now) so the names that we get from the above
+ ;; fcn better not, in turn, be splittable.
+ ((listp namelst)
+ ;; If we had a split, then this is likely a c++ style namespace::name sequence,
+ ;; so take a short-cut through the typecache.
+ (or (semanticdb-typecache-find namelst)
+ ;; Ok, not there, try the usual...
+ (let ((seq (semantic-analyze-find-tag-sequence
+ namelst scope nil)))
+ (semantic-analyze-select-best-tag seq tagclass)
+ )))
+ ;; If NAME is solo, then do our searches for it here.
+ ((stringp namelst)
+ (let ((retlist (and scope (semantic-scope-find name tagclass scope))))
+ (if retlist
+ (semantic-analyze-select-best-tag
+ retlist tagclass)
+ (if (eq tagclass 'type)
+ (semanticdb-typecache-find name)
+ ;; Search in the typecache. First entries in a sequence are
+ ;; often there.
+ (setq retlist (semanticdb-typecache-find name))
+ (if retlist
+ retlist
+ (semantic-analyze-select-best-tag
+ (semanticdb-strip-find-results
+ (semanticdb-find-tags-by-name name)
+ 'name)
+ tagclass)
+ )))))
+ )))
+
+ ;;; SHORT ANALYSIS
+ ;;
+ ;; Create a mini-analysis of just the symbol under point.
+ ;;
+ (define-overloadable-function semantic-analyze-current-symbol
+ (analyzehookfcn &optional position)
+ "Call ANALYZEHOOKFCN after analyzing the symbol under POSITION.
+ The ANALYZEHOOKFCN is called with the current symbol bounds, and the
+ analyzed prefix. It should take the arguments (START END PREFIX).
+ The ANALYZEHOOKFCN is only called if some sort of prefix with bounds was
+ found under POSITION.
+
+ The results of ANALYZEHOOKFCN is returned, or nil if there was nothing to
+ call it with.
+
+ For regular analysis, you should call `semantic-analyze-current-context'
+ to calculate the context information. The purpose for this function is
+ to provide a large number of non-cached analysis for filtering symbols."
+ ;; Only do this in a Semantic enabled buffer.
+ (when (not (semantic-active-p))
+ (error "Cannot analyze buffers not supported by Semantic."))
+ ;; Always refresh out tags in a safe way before doing the
+ ;; context.
+ (semantic-refresh-tags-safe)
+ ;; Do the rest of the analysis.
+ (save-match-data
+ (save-excursion
+ (:override)))
+ )
+
+ (defun semantic-analyze-current-symbol-default (analyzehookfcn position)
+ "Call ANALYZEHOOKFCN on the analyzed symbol at POSITION."
+ (let* ((semantic-analyze-error-stack nil)
+ (LLstart (current-time))
+ (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point))))
+ (prefix (car prefixandbounds))
+ (bounds (nth 2 prefixandbounds))
+ (scope (semantic-calculate-scope position))
+ (end nil)
+ )
+ ;; Only do work if we have bounds (meaning a prefix to complete)
+ (when bounds
+
+ (if debug-on-error
+ (catch 'unfindable
+ ;; If debug on error is on, allow debugging in this fcn.
+ (setq prefix (semantic-analyze-find-tag-sequence
+ prefix scope 'prefixtypes 'unfindable)))
+ ;; Debug on error is off. Capture errors and move on
+ (condition-case err
+ ;; NOTE: This line is duplicated in
+ ;; semantic-analyzer-debug-global-symbol
+ ;; You will need to update both places.
+ (setq prefix (semantic-analyze-find-tag-sequence
+ prefix scope 'prefixtypes))
+ (error (semantic-analyze-push-error err))))
+
+ (setq end (current-time))
+ ;;(message "Analysis took %.2f sec" (semantic-elapsed-time LLstart end))
+
+ )
+ (when prefix
+ (prog1
+ (funcall analyzehookfcn (car bounds) (cdr bounds) prefix)
+ ;;(setq end (current-time))
+ ;;(message "hookfcn took %.5f sec" (semantic-elapsed-time LLstart end))
+ )
+
+ )))
+
+ ;;; MAIN ANALYSIS
+ ;;
+ ;; Create a full-up context analysis.
+ ;;
+ ;;;###autoload
+ (define-overloadable-function semantic-analyze-current-context (&optional position)
+ "Analyze the current context at optional POSITION.
+ If called interactively, display interesting information about POSITION
+ in a separate buffer.
+ Returns an object based on symbol `semantic-analyze-context'.
+
+ This function can be overriden with the symbol `analyze-context'.
+ When overriding this function, your override will be called while
+ cursor is at POSITION. In addition, your function will not be called
+ if a cached copy of the return object is found."
+ (interactive "d")
+ ;; Only do this in a Semantic enabled buffer.
+ (when (not (semantic-active-p))
+ (error "Cannot analyze buffers not supported by Semantic."))
+ ;; Always refresh out tags in a safe way before doing the
+ ;; context.
+ (semantic-refresh-tags-safe)
+ ;; Do the rest of the analysis.
+ (if (not position) (setq position (point)))
+ (save-excursion
+ (goto-char position)
+ (let* ((answer (semantic-get-cache-data 'current-context)))
+ (with-syntax-table semantic-lex-syntax-table
+ (when (not answer)
+ (setq answer (:override))
+ (when (and answer (oref answer bounds))
+ (with-slots (bounds) answer
+ (semantic-cache-data-to-buffer (current-buffer)
+ (car bounds)
+ (cdr bounds)
+ answer
+ 'current-context
+ 'exit-cache-zone)))
+ ;; Check for interactivity
+ (when (interactive-p)
+ (if answer
+ (semantic-analyze-pop-to-context answer)
+ (message "No Context."))
+ ))
+
+ answer))))
+
+ (defun semantic-analyze-current-context-default (position)
+ "Analyze the current context at POSITION.
+ Returns an object based on symbol `semantic-analyze-context'."
+ (let* ((semantic-analyze-error-stack nil)
+ (context-return nil)
+ (prefixandbounds (semantic-ctxt-current-symbol-and-bounds (or position (point))))
+ (prefix (car prefixandbounds))
+ (bounds (nth 2 prefixandbounds))
+ ;; @todo - vv too early to really know this answer! vv
+ (prefixclass (semantic-ctxt-current-class-list))
+ (prefixtypes nil)
+ (scope (semantic-calculate-scope position))
+ (function nil)
+ (fntag nil)
+ arg fntagend argtag
+ assign asstag
+ )
+
+ ;; Pattern for Analysis:
+ ;;
+ ;; Step 1: Calculate DataTypes in Scope:
+ ;;
+ ;; a) Calculate the scope (above)
+ ;;
+ ;; Step 2: Parse context
+ ;;
+ ;; a) Identify function being called, or variable assignment,
+ ;; and find source tags for those references
+ ;; b) Identify the prefix (text cursor is on) and find the source
+ ;; tags for those references.
+ ;;
+ ;; Step 3: Assemble an object
+ ;;
+
+ ;; Step 2 a:
+
+ (setq function (semantic-ctxt-current-function))
+
+ (when function
+ ;; Calculate the argument for the function if there is one.
+ (setq arg (semantic-ctxt-current-argument))
+
+ ;; Find a tag related to the function name.
+ (condition-case err
+ (setq fntag
+ (semantic-analyze-find-tag-sequence function scope))
+ (error (semantic-analyze-push-error err)))
+
+ ;; fntag can have the last entry as just a string, meaning we
+ ;; could not find the core datatype. In this case, the searches
+ ;; below will not work.
+ (when (stringp (car (last fntag)))
+ ;; Take a wild guess!
+ (setcar (last fntag) (semantic-tag (car (last fntag)) 'function))
+ )
+
+ (when fntag
+ (let ((fcn (semantic-find-tags-by-class 'function fntag)))
+ (when (not fcn)
+ (let ((ty (semantic-find-tags-by-class 'type fntag)))
+ (when ty
+ ;; We might have a constructor with the same name as
+ ;; the found datatype.
+ (setq fcn (semantic-find-tags-by-name
+ (semantic-tag-name (car ty))
+ (semantic-tag-type-members (car ty))))
+ (if fcn
+ (let ((lp fcn))
+ (while lp
+ (when (semantic-tag-get-attribute (car lp)
+ :constructor)
+ (setq fcn (cons (car lp) fcn)))
+ (setq lp (cdr lp))))
+ ;; Give up, go old school
+ (setq fcn fntag))
+ )))
+ (setq fntagend (car (reverse fcn))
+ argtag
+ (when (semantic-tag-p fntagend)
+ (nth (1- arg) (semantic-tag-function-arguments fntagend)))
+ fntag fcn))))
+
+ ;; Step 2 b:
+
+ ;; Only do work if we have bounds (meaning a prefix to complete)
+ (when bounds
+
+ (if debug-on-error
+ (catch 'unfindable
+ ;; If debug on error is on, allow debugging in this fcn.
+ (setq prefix (semantic-analyze-find-tag-sequence
+ prefix scope 'prefixtypes 'unfindable)))
+ ;; Debug on error is off. Capture errors and move on
+ (condition-case err
+ ;; NOTE: This line is duplicated in
+ ;; semantic-analyzer-debug-global-symbol
+ ;; You will need to update both places.
+ (setq prefix (semantic-analyze-find-tag-sequence
+ prefix scope 'prefixtypes))
+ (error (semantic-analyze-push-error err))))
+ )
+
+ ;; Step 3:
+
+ (cond
+ (fntag
+ ;; If we found a tag for our function, we can go into
+ ;; functional context analysis mode, meaning we have a type
+ ;; for the argument.
+ (setq context-return
+ (semantic-analyze-context-functionarg
+ "functionargument"
+ :buffer (current-buffer)
+ :function fntag
+ :index arg
+ :argument (list argtag)
+ :scope scope
+ :prefix prefix
+ :prefixclass prefixclass
+ :bounds bounds
+ :prefixtypes prefixtypes
+ :errors semantic-analyze-error-stack)))
+
+ ;; No function, try assignment
+ ((and (setq assign (semantic-ctxt-current-assignment))
+ ;; We have some sort of an assignment
+ (condition-case err
+ (setq asstag (semantic-analyze-find-tag-sequence
+ assign scope))
+ (error (semantic-analyze-push-error err)
+ nil)))
+
+ (setq context-return
+ (semantic-analyze-context-assignment
+ "assignment"
+ :buffer (current-buffer)
+ :assignee asstag
+ :scope scope
+ :bounds bounds
+ :prefix prefix
+ :prefixclass prefixclass
+ :prefixtypes prefixtypes
+ :errors semantic-analyze-error-stack)))
+
+ ;; TODO: Identify return value condition.
+ ;;((setq return .... what to do?)
+ ;; ...)
+
+ (bounds
+ ;; Nothing in particular
+ (setq context-return
+ (semantic-analyze-context
+ "context"
+ :buffer (current-buffer)
+ :scope scope
+ :bounds bounds
+ :prefix prefix
+ :prefixclass prefixclass
+ :prefixtypes prefixtypes
+ :errors semantic-analyze-error-stack)))
+
+ (t (setq context-return nil))
+ )
+
+ ;; Return our context.
+ context-return))
+
+ \f
+ (defun semantic-adebug-analyze (&optional ctxt)
+ "Perform `semantic-analyze-current-context'.
+ Display the results as a debug list.
+ Optional argument CTXT is the context to show."
+ (interactive)
+ (require 'data-debug)
+ (let ((start (current-time))
+ (ctxt (or ctxt (semantic-analyze-current-context)))
+ (end (current-time)))
+ (if (not ctxt)
+ (message "No Analyzer Results")
+ (message "Analysis took %.2f seconds."
+ (semantic-elapsed-time start end))
+ (semantic-analyze-pulse ctxt)
+ (if ctxt
+ (progn
+ (data-debug-new-buffer "*Analyzer ADEBUG*")
+ (data-debug-insert-object-slots ctxt "]"))
+ (message "No Context to analyze here.")))))
+
+ \f
+ ;;; DEBUG OUTPUT
+ ;;
+ ;; Friendly output of a context analysis.
+ ;;
+ (declare-function pulse-momentary-highlight-region "pulse")
+
+ (defmethod semantic-analyze-pulse ((context semantic-analyze-context))
+ "Pulse the region that CONTEXT affects."
+ (require 'pulse)
+ (save-excursion
+ (set-buffer (oref context :buffer))
+ (let ((bounds (oref context :bounds)))
+ (when bounds
+ (pulse-momentary-highlight-region (car bounds) (cdr bounds))))))
+
+ (defcustom semantic-analyze-summary-function 'semantic-format-tag-prototype
++ "Function to use when creating items in Imenu.
+ Some useful functions are found in `semantic-format-tag-functions'."
+ :group 'semantic
+ :type semantic-format-tag-custom-list)
+
+ (defun semantic-analyze-princ-sequence (sequence &optional prefix buff)
+ "Send the tag SEQUENCE to standard out.
+ Use PREFIX as a label.
+ Use BUFF as a source of override methods."
+ (while sequence
+ (princ prefix)
+ (cond
+ ((semantic-tag-p (car sequence))
+ (princ (funcall semantic-analyze-summary-function
+ (car sequence))))
+ ((stringp (car sequence))
+ (princ "\"")
+ (princ (semantic--format-colorize-text (car sequence) 'variable))
+ (princ "\""))
+ (t
+ (princ (format "'%S" (car sequence)))))
+ (princ "\n")
+ (setq sequence (cdr sequence))
+ (setq prefix (make-string (length prefix) ? ))
+ ))
+
+ (defmethod semantic-analyze-show ((context semantic-analyze-context))
+ "Insert CONTEXT into the current buffer in a nice way."
+ (semantic-analyze-princ-sequence (oref context prefix) "Prefix: " )
+ (semantic-analyze-princ-sequence (oref context prefixclass) "Prefix Classes: ")
+ (semantic-analyze-princ-sequence (oref context prefixtypes) "Prefix Types: ")
+ (semantic-analyze-princ-sequence (oref context errors) "Encountered Errors: ")
+ (princ "--------\n")
+ ;(semantic-analyze-princ-sequence (oref context scopetypes) "Scope Types: ")
+ ;(semantic-analyze-princ-sequence (oref context scope) "Scope: ")
+ ;(semantic-analyze-princ-sequence (oref context localvariables) "LocalVars: ")
+ (when (oref context scope)
+ (semantic-analyze-show (oref context scope)))
+ )
+
+ (defmethod semantic-analyze-show ((context semantic-analyze-context-assignment))
+ "Insert CONTEXT into the current buffer in a nice way."
+ (semantic-analyze-princ-sequence (oref context assignee) "Assignee: ")
+ (call-next-method))
+
+ (defmethod semantic-analyze-show ((context semantic-analyze-context-functionarg))
+ "Insert CONTEXT into the current buffer in a nice way."
+ (semantic-analyze-princ-sequence (oref context function) "Function: ")
+ (princ "Argument Index: ")
+ (princ (oref context index))
+ (princ "\n")
+ (semantic-analyze-princ-sequence (oref context argument) "Argument: ")
+ (call-next-method))
+
+ (defun semantic-analyze-pop-to-context (context)
+ "Display CONTEXT in a temporary buffer.
+ CONTEXT's content is described in `semantic-analyze-current-context'."
+ (semantic-analyze-pulse context)
+ (with-output-to-temp-buffer "*Semantic Context Analysis*"
+ (princ "Context Type: ")
+ (princ (object-name context))
+ (princ "\n")
+ (princ "Bounds: ")
+ (princ (oref context bounds))
+ (princ "\n")
+ (semantic-analyze-show context)
+ )
+ (shrink-window-if-larger-than-buffer
+ (get-buffer-window "*Semantic Context Analysis*"))
+ )
+
+ (provide 'semantic/analyze)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/analyze"
+ ;; End:
+
+ ;;; semantic/analyze.el ends here
--- /dev/null
-;; Old impl of the above. I'm not sure what the issue is
-; (let ((ans
-; (:override-with-args
-; ((semantic-analyze-find-tag (semantic-tag-name type)))
-; ;; Be default, we don't know.
-; nil))
-; (out nil))
-; (dolist (elt ans)
-; (cond
-; ((stringp elt)
-; (push (semantic-tag-new-variable
-; elt (semantic-tag-name type) nil)
-; out))
-; ((semantic-tag-p elt)
-; (push elt out))
-; (t nil)))
-; (nreverse out)))
-
+ ;;; semantic/analyze/complete.el --- Smart Completions
+
+ ;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Caclulate smart completions.
+ ;;
+ ;; Uses the analyzer context routine to determine the best possible
+ ;; list of completions.
+ ;;
+ ;;; History:
+ ;;
+ ;; Code was moved here from semantic-analyze.el
+
+ (require 'semantic/analyze)
+
+ ;; For semantic-find-* macros:
+ (eval-when-compile (require 'semantic/find))
+
+ ;;; Code:
+
+ ;;; Helper Fcns
+ ;;
+ ;;
+ ;;;###autoload
+ (define-overloadable-function semantic-analyze-type-constants (type)
+ "For the tag TYPE, return any constant symbols of TYPE.
+ Used as options when completing.")
+
+ (defun semantic-analyze-type-constants-default (type)
+ "Do nothing with TYPE."
+ nil)
+
+ (defun semantic-analyze-tags-of-class-list (tags classlist)
+ "Return the tags in TAGS that are of classes in CLASSLIST."
+ (let ((origc tags))
+ ;; Accept only tags that are of the datatype specified by
+ ;; the desired classes.
+ (setq tags (apply 'nconc ;; All input lists are permutable.
+ (mapcar (lambda (class)
+ (semantic-find-tags-by-class class origc))
+ classlist)))
+ tags))
+
+ ;;; MAIN completion calculator
+ ;;
+ ;;;###autoload
+ (define-overloadable-function semantic-analyze-possible-completions (context)
+ "Return a list of semantic tags which are possible completions.
+ CONTEXT is either a position (such as point), or a precalculated
+ context. Passing in a context is useful if the caller also needs
+ to access parts of the analysis.
+ Completions run through the following filters:
+ * Elements currently in scope
+ * Constants currently in scope
+ * Elements match the :prefix in the CONTEXT.
+ * Type of the completion matches the type of the context.
+ Context type matching can identify the following:
+ * No specific type
+ * Assignment into a variable of some type.
+ * Argument to a function with type constraints.
+ When called interactively, displays the list of possible completions
+ in a buffer."
+ (interactive "d")
+ ;; In theory, we don't need the below since the context will
+ ;; do it for us.
+ ;;(semantic-refresh-tags-safe)
+ (with-syntax-table semantic-lex-syntax-table
+ (let* ((context (if (semantic-analyze-context-child-p context)
+ context
+ (semantic-analyze-current-context context)))
+ (ans (if (not context)
+ (error "Nothing to Complete.")
+ (:override))))
+ ;; If interactive, display them.
+ (when (interactive-p)
+ (with-output-to-temp-buffer "*Possible Completions*"
+ (semantic-analyze-princ-sequence ans "" (current-buffer)))
+ (shrink-window-if-larger-than-buffer
+ (get-buffer-window "*Possible Completions*")))
+ ans)))
+
+ (defun semantic-analyze-possible-completions-default (context)
+ "Default method for producing smart completions.
+ Argument CONTEXT is an object specifying the locally derived context."
+ (let* ((a context)
+ (desired-type (semantic-analyze-type-constraint a))
+ (desired-class (oref a prefixclass))
+ (prefix (oref a prefix))
+ (prefixtypes (oref a prefixtypes))
+ (completetext nil)
+ (completetexttype nil)
+ (scope (oref a scope))
+ (localvar (oref scope localvar))
+ (c nil))
+
+ ;; Calculate what our prefix string is so that we can
+ ;; find all our matching text.
+ (setq completetext (car (reverse prefix)))
+ (if (semantic-tag-p completetext)
+ (setq completetext (semantic-tag-name completetext)))
+
+ (if (and (not completetext) (not desired-type))
+ (error "Nothing to complete"))
+
+ (if (not completetext) (setq completetext ""))
+
+ ;; This better be a reasonable type, or we should fry it.
+ ;; The prefixtypes should always be at least 1 less than
+ ;; the prefix since the type is never looked up for the last
+ ;; item when calculating a sequence.
+ (setq completetexttype (car (reverse prefixtypes)))
+ (when (or (not completetexttype)
+ (not (and (semantic-tag-p completetexttype)
+ (eq (semantic-tag-class completetexttype) 'type))))
+ ;; What should I do here? I think this is an error condition.
+ (setq completetexttype nil)
+ ;; If we had something that was a completetexttype but it wasn't
+ ;; valid, then express our dismay!
+ (when (> (length prefix) 1)
+ (let* ((errprefix (car (cdr (reverse prefix)))))
+ (error "Cannot find types for `%s'"
+ (cond ((semantic-tag-p errprefix)
+ (semantic-format-tag-prototype errprefix))
+ (t
+ (format "%S" errprefix)))))
+ ))
+
+ ;; There are many places to get our completion stream for.
+ ;; Here we go.
+ (if completetexttype
+
+ (setq c (semantic-find-tags-for-completion
+ completetext
+ (semantic-analyze-scoped-type-parts completetexttype scope)
+ ))
+
+ ;; No type based on the completetext. This is a free-range
+ ;; var or function. We need to expand our search beyond this
+ ;; scope into semanticdb, etc.
+ (setq c (nconc
+ ;; Argument list and local variables
+ (semantic-find-tags-for-completion completetext localvar)
+ ;; The current scope
+ (semantic-find-tags-for-completion completetext (oref scope fullscope))
+ ;; The world
+ (semantic-analyze-find-tags-by-prefix completetext))
+ )
+ )
+
+ (let ((origc c)
+ (dtname (semantic-tag-name desired-type)))
+
+ ;; Reset c.
+ (setq c nil)
+
+ ;; Loop over all the found matches, and catagorize them
+ ;; as being possible features.
+ (while origc
+
+ (cond
+ ;; Strip operators
+ ((semantic-tag-get-attribute (car origc) :operator-flag)
+ nil
+ )
+
+ ;; If we are completing from within some prefix,
+ ;; then we want to exclude constructors and destructors
+ ((and completetexttype
+ (or (semantic-tag-get-attribute (car origc) :constructor-flag)
+ (semantic-tag-get-attribute (car origc) :destructor-flag)))
+ nil
+ )
+
+ ;; If there is a desired type, we need a pair of restrictions
+ (desired-type
+
+ (cond
+ ;; Ok, we now have a completion list based on the text we found
+ ;; we want to complete on. Now filter that stream against the
+ ;; type we want to search for.
+ ((string= dtname (semantic-analyze-type-to-name (semantic-tag-type (car origc))))
+ (setq c (cons (car origc) c))
+ )
+
+ ;; Now anything that is a compound type which could contain
+ ;; additional things which are of the desired type
+ ((semantic-tag-type (car origc))
+ (let ((att (semantic-analyze-tag-type (car origc) scope))
+ )
+ (if (and att (semantic-tag-type-members att))
+ (setq c (cons (car origc) c))))
+ )
+
+ ) ; cond
+ ); desired type
+
+ ;; No desired type, no other restrictions. Just add.
+ (t
+ (setq c (cons (car origc) c)))
+
+ ); cond
+
+ (setq origc (cdr origc)))
+
+ (when desired-type
+ ;; Some types, like the enum in C, have special constant values that
+ ;; we could complete with. Thus, if the target is an enum, we can
+ ;; find possible symbol values to fill in that value.
+ (let ((constants
+ (semantic-analyze-type-constants desired-type)))
+ (if constants
+ (progn
+ ;; Filter
+ (setq constants
+ (semantic-find-tags-for-completion
+ completetext constants))
+ ;; Add to the list
+ (setq c (nconc c constants)))
+ )))
+ )
+
+ (when desired-class
+ (setq c (semantic-analyze-tags-of-class-list c desired-class)))
+
+ ;; Pull out trash.
+ ;; NOTE TO SELF: Is this too slow?
+ ;; OTHER NOTE: Do we not want to strip duplicates by name and
+ ;; only by position? When are duplicate by name but not by tag
+ ;; useful?
+ (setq c (semantic-unique-tag-table-by-name c))
+
+ ;; All done!
+
+ c))
+
+ (provide 'semantic/analyze/complete)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "../loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/analyze/complete"
+ ;; End:
+
+ ;;; semantic/analyze/complete.el ends here
--- /dev/null
-(require 'mode-local)
+ ;;; semantic/analyze/fcn.el --- Analyzer support functions.
+
+ ;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Analyzer support functions.
+
+ ;;; Code:
+
-(require 'semantic/tag)
-
+ (require 'semantic)
+ (eval-when-compile (require 'semantic/find))
+
+ (declare-function semanticdb-typecache-merge-streams "semantic/db-typecache")
+ (declare-function semantic-scope-find name "semantic/scope")
+ (declare-function semantic-scope-set-typecache "semantic/scope")
+ (declare-function semantic-scope-tag-get-scope "semantic/scope")
+
+ ;;; Small Mode Specific Options
+ ;;
+ ;; These queries allow a major mode to help the analyzer make decisions.
+ ;;
+ (define-overloadable-function semantic-analyze-tag-prototype-p (tag)
+ "Non-nil if TAG is a prototype."
+ )
+
+ (defun semantic-analyze-tag-prototype-p-default (tag)
+ "Non-nil if TAG is a prototype."
+ (let ((p (semantic-tag-get-attribute tag :prototype-flag)))
+ (cond
+ ;; Trust the parser author.
+ (p p)
+ ;; Empty types might be a prototype.
+ ((eq (semantic-tag-class tag) 'type)
+ (not (semantic-tag-type-members tag)))
+ ;; No other heuristics.
+ (t nil))
+ ))
+
+ ;;------------------------------------------------------------
+
+ (define-overloadable-function semantic-analyze-split-name (name)
+ "Split a tag NAME into a sequence.
+ Sometimes NAMES are gathered from the parser that are compounded,
+ such as in C++ where foo::bar means:
+ \"The class BAR in the namespace FOO.\"
+ Return the string NAME for no change, or a list if it needs to be split.")
+
+ (defun semantic-analyze-split-name-default (name)
+ "Don't split up NAME by default."
+ name)
+
+ (define-overloadable-function semantic-analyze-unsplit-name (namelist)
+ "Assemble a NAMELIST into a string representing a compound name.
+ Return the string representing the compound name.")
+
+ (defun semantic-analyze-unsplit-name-default (namelist)
+ "Concatenate the names in NAMELIST with a . between."
+ (mapconcat 'identity namelist "."))
+
+ ;;; SELECTING
+ ;;
+ ;; If you narrow things down to a list of tags that all mean
+ ;; the same thing, how to you pick one? Select or merge.
+ ;;
+
+ (defun semantic-analyze-select-best-tag (sequence &optional tagclass)
+ "For a SEQUENCE of tags, all with good names, pick the best one.
+ If SEQUENCE is made up of namespaces, merge the namespaces together.
+ If SEQUENCE has several prototypes, find the non-prototype.
+ If SEQUENCE has some items w/ no type information, find the one with a type.
+ If SEQUENCE is all prototypes, or has no prototypes, get the first one.
+ Optional TAGCLASS indicates to restrict the return to only
+ tags of TAGCLASS."
+
+ ;; If there is a srew up and we get just one tag.. massage over it.
+ (when (semantic-tag-p sequence)
+ (setq sequence (list sequence)))
+
+ ;; Filter out anything not of TAGCLASS
+ (when tagclass
+ (setq sequence (semantic-find-tags-by-class tagclass sequence)))
+
+ (if (< (length sequence) 2)
+ ;; If the remaining sequence is 1 tag or less, just return it
+ ;; and skip the rest of this mumbo-jumbo.
+ (car sequence)
+
+ ;; 1)
+ ;; This step will eliminate a vast majority of the types,
+ ;; in addition to merging namespaces together.
+ ;;
+ ;; 2)
+ ;; It will also remove prototypes.
+ (require 'semantic/db-typecache)
+ (setq sequence (semanticdb-typecache-merge-streams sequence nil))
+
+ (if (< (length sequence) 2)
+ ;; If the remaining sequence after the merge is 1 tag or less,
+ ;; just return it and skip the rest of this mumbo-jumbo.
+ (car sequence)
+
+ (let ((best nil)
+ (notypeinfo nil)
+ )
+ (while (and (not best) sequence)
+
+ ;; 3) select a non-prototype.
+ (if (not (semantic-tag-type (car sequence)))
+ (setq notypeinfo (car sequence))
+
+ (setq best (car sequence))
+ )
+
+ (setq sequence (cdr sequence)))
+
+ ;; Select the best, or at least the prototype.
+ (or best notypeinfo)))))
+
+ ;;; Tag Finding
+ ;;
+ ;; Mechanism for lookup up tags by name.
+ ;;
+ (defun semantic-analyze-find-tags-by-prefix (prefix)
+ ;; @todo - only used in semantic-complete. Find something better?
+ "Attempt to find a tag with PREFIX.
+ This is a wrapper on top of semanticdb, and semantic search functions.
+ Almost all searches use the same arguments."
+ (if (and (fboundp 'semanticdb-minor-mode-p)
+ (semanticdb-minor-mode-p))
+ ;; Search the database & concatenate all matches together.
+ (semanticdb-strip-find-results
+ (semanticdb-find-tags-for-completion prefix)
+ 'name)
+ ;; Search just this file because there is no DB available.
+ (semantic-find-tags-for-completion
+ prefix (current-buffer))))
+
+ ;;; Finding Datatypes
+ ;;
+
+ (define-overloadable-function semantic-analyze-dereference-metatype (type scope &optional type-declaration)
+ ;; todo - move into typecahe!!
+ "Return a concrete type tag based on input TYPE tag.
+ A concrete type is an actual declaration of a memory description,
+ such as a structure, or class. A meta type is an alias,
+ or a typedef in C or C++. If TYPE is concrete, it
+ is returned. If it is a meta type, it will return the concrete
+ type defined by TYPE.
+ The default behavior always returns TYPE.
+ Override functions need not return a real semantic tag.
+ Just a name, or short tag will be ok. It will be expanded here.
+ SCOPE is the scope object with additional items in which to search for names."
+ (catch 'default-behavior
+ (let* ((ans-tuple (:override
+ ;; Nothing fancy, just return type by default.
+ (throw 'default-behavior (list type type-declaration))))
+ (ans-type (car ans-tuple))
+ (ans-type-declaration (cadr ans-tuple)))
+ (list (semantic-analyze-dereference-metatype-1 ans-type scope) ans-type-declaration))))
+
+ ;; Finding a data type by name within a project.
+ ;;
+ (defun semantic-analyze-type-to-name (type)
+ "Get the name of TAG's type.
+ The TYPE field in a tag can be nil (return nil)
+ or a string, or a non-positional tag."
+ (cond ((semantic-tag-p type)
+ (semantic-tag-name type))
+ ((stringp type)
+ type)
+ ((listp type)
+ (car type))
+ (t nil)))
+
+ (defun semantic-analyze-tag-type (tag &optional scope nometaderef)
+ "Return the semantic tag for a type within the type of TAG.
+ TAG can be a variable, function or other type of tag.
+ The behavior of TAG's type is defined by `semantic-analyze-type'.
+ Optional SCOPE represents a calculated scope in which the
+ types might be found. This can be nil.
+ If NOMETADEREF, then do not dereference metatypes. This is
+ used by the analyzer debugger."
+ (semantic-analyze-type (semantic-tag-type tag) scope nometaderef))
+
+ (defun semantic-analyze-type (type-declaration &optional scope nometaderef)
+ "Return the semantic tag for TYPE-DECLARATION.
+ TAG can be a variable, function or other type of tag.
+ The type of tag (such as a class or struct) is a name.
+ Lookup this name in database, and return all slots/fields
+ within that types field. Also handles anonymous types.
+ Optional SCOPE represents a calculated scope in which the
+ types might be found. This can be nil.
+ If NOMETADEREF, then do not dereference metatypes. This is
+ used by the analyzer debugger."
+ (require 'semantic/scope)
+ (let ((name nil)
+ (typetag nil)
+ )
+
+ ;; Is it an anonymous type?
+ (if (and type-declaration
+ (semantic-tag-p type-declaration)
+ (semantic-tag-of-class-p type-declaration 'type)
+ (not (semantic-analyze-tag-prototype-p type-declaration))
+ )
+ ;; We have an anonymous type for TAG with children.
+ ;; Use this type directly.
+ (if nometaderef
+ type-declaration
+ (semantic-analyze-dereference-metatype-stack
+ type-declaration scope type-declaration))
+
+ ;; Not an anonymous type. Look up the name of this type
+ ;; elsewhere, and report back.
+ (setq name (semantic-analyze-type-to-name type-declaration))
+
+ (if (and name (not (string= name "")))
+ (progn
+ ;; Find a type of that name in scope.
+ (setq typetag (and scope (semantic-scope-find name 'type scope)))
+ ;; If no typetag, try the typecache
+ (when (not typetag)
+ (setq typetag (semanticdb-typecache-find name))))
+
+ ;; No name to look stuff up with.
+ (error "Semantic tag %S has no type information"
+ (semantic-tag-name type-declaration)))
+
+ ;; Handle lists of tags.
+ (when (and (consp typetag) (semantic-tag-p (car typetag)))
+ (setq typetag (semantic-analyze-select-best-tag typetag 'type))
+ )
+
+ ;; We now have a tag associated with the type. We need to deref it.
+ ;;
+ ;; If we were asked not to (ie - debugger) push the typecache anyway.
+ (if nometaderef
+ typetag
+ (unwind-protect
+ (progn
+ (semantic-scope-set-typecache
+ scope (semantic-scope-tag-get-scope typetag))
+ (semantic-analyze-dereference-metatype-stack typetag scope type-declaration)
+ )
+ (semantic-scope-set-typecache scope nil)
+ )))))
+
+ (defun semantic-analyze-dereference-metatype-stack (type scope &optional type-declaration)
+ "Dereference metatypes repeatedly until we hit a real TYPE.
+ Uses `semantic-analyze-dereference-metatype'.
+ Argument SCOPE is the scope object with additional items in which to search.
+ Optional argument TYPE-DECLARATION is how TYPE was found referenced."
+ (let ((lasttype type)
+ (lasttypedeclaration type-declaration)
+ (nexttype (semantic-analyze-dereference-metatype type scope type-declaration))
+ (idx 0))
+ (catch 'metatype-recursion
+ (while (and nexttype (not (eq (car nexttype) lasttype)))
+ (setq lasttype (car nexttype)
+ lasttypedeclaration (cadr nexttype))
+ (setq nexttype (semantic-analyze-dereference-metatype lasttype scope lasttypedeclaration))
+ (setq idx (1+ idx))
+ (when (> idx 20) (message "Possible metatype recursion for %S"
+ (semantic-tag-name lasttype))
+ (throw 'metatype-recursion nil))
+ ))
+ lasttype))
+
+ ;; @ TODO - the typecache can also return a stack of scope names.
+
+ (defun semantic-analyze-dereference-metatype-1 (ans scope)
+ "Do extra work after dereferencing a metatype.
+ ANS is the answer from the the language specific query.
+ SCOPE is the current scope."
+ (require 'semantic/scope)
+ ;; If ANS is a string, or if ANS is a short tag, we
+ ;; need to do some more work to look it up.
+ (if (stringp ans)
+ ;; The metatype is just a string... look it up.
+ (or (and scope (car-safe
+ ;; @todo - should this be `find the best one'?
+ (semantic-scope-find ans 'type scope)))
+ (let ((tcsans nil))
+ (prog1
+ (setq tcsans
+ (semanticdb-typecache-find ans))
+ ;; While going through the metatype, if we have
+ ;; a scope, push our new cache in.
+ (when scope
+ (semantic-scope-set-typecache
+ scope (semantic-scope-tag-get-scope tcsans))
+ ))
+ ))
+ (when (and (semantic-tag-p ans)
+ (eq (semantic-tag-class ans) 'type))
+ ;; We have a tag.
+ (if (semantic-analyze-tag-prototype-p ans)
+ ;; It is a prototype.. find the real one.
+ (or (and scope
+ (car-safe
+ (semantic-scope-find (semantic-tag-name ans)
+ 'type scope)))
+ (let ((tcsans nil))
+ (prog1
+ (setq tcsans
+ (semanticdb-typecache-find (semantic-tag-name ans)))
+ ;; While going through the metatype, if we have
+ ;; a scope, push our new cache in.
+ (when scope
+ (semantic-scope-set-typecache
+ scope (semantic-scope-tag-get-scope tcsans))
+ ))))
+ ;; We have a tag, and it is not a prototype.
+ ans))
+ ))
+
+ (provide 'semantic/analyze/fcn)
+
+ ;;; semantic/analyze/fcn.el ends here
--- /dev/null
-(require 'semantic/bovine/debug)
+ ;;; semantic/bovine.el --- LL Parser/Analyzer core.
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Semantix 1.x uses an LL parser named the "bovinator". This parser
+ ;; had several conveniences in it which made for parsing tags out of
+ ;; languages with list characters easy. This parser lives on as one
+ ;; of many available parsers for semantic the tool.
+ ;;
+ ;; This parser should be used when the language is simple, such as
+ ;; makefiles or other data-declaritive langauges.
+
+ ;;; Code:
+ (require 'semantic)
- (if semantic-debug-enabled
++
++(declare-function semantic-create-bovine-debug-error-frame
++ "semantic/bovine/debug")
++(declare-function semantic-bovine-debug-create-frame
++ "semantic/bovine/debug")
++(declare-function semantic-debug-break "semantic/debug")
+
+ ;;; Variables
+ ;;
+ (defvar semantic-bovinate-nonterminal-check-obarray nil
+ "Obarray of streams already parsed for nonterminal symbols.
+ Use this to detect infinite recursion during a parse.")
+ (make-variable-buffer-local 'semantic-bovinate-nonterminal-check-obarray)
+
+
+ \f
+ ;; These are functions that can be called from within a bovine table.
+ ;; Most of these have code auto-generated from other construct in the
+ ;; bovine input grammar.
+ (defmacro semantic-lambda (&rest return-val)
+ "Create a lambda expression to return a list including RETURN-VAL.
+ The return list is a lambda expression to be used in a bovine table."
+ `(lambda (vals start end)
+ (append ,@return-val (list start end))))
+
+ ;;; Semantic Bovination
+ ;;
+ ;; Take a semantic token stream, and convert it using the bovinator.
+ ;; The bovinator takes a state table, and converts the token stream
+ ;; into a new semantic stream defined by the bovination table.
+ ;;
+ (defsubst semantic-bovinate-symbol-nonterminal-p (sym table)
+ "Return non-nil if SYM is in TABLE, indicating it is NONTERMINAL."
+ ;; sym is always a sym, so assq should be ok.
+ (if (assq sym table) t nil))
+
+ (defmacro semantic-bovinate-nonterminal-db-nt ()
+ "Return the current nonterminal symbol.
+ Part of the grammar source debugger. Depends on the existing
+ environment of `semantic-bovinate-stream'."
+ `(if nt-stack
+ (car (aref (car nt-stack) 2))
+ nonterminal))
+
+ (defun semantic-bovinate-nonterminal-check (stream nonterminal)
+ "Check if STREAM not already parsed for NONTERMINAL.
+ If so abort because an infinite recursive parse is suspected."
+ (or (vectorp semantic-bovinate-nonterminal-check-obarray)
+ (setq semantic-bovinate-nonterminal-check-obarray
+ (make-vector 13 nil)))
+ (let* ((nt (symbol-name nonterminal))
+ (vs (symbol-value
+ (intern-soft
+ nt semantic-bovinate-nonterminal-check-obarray))))
+ (if (memq stream vs)
+ ;; Always enter debugger to see the backtrace
+ (let ((debug-on-signal t)
+ (debug-on-error t))
+ (setq semantic-bovinate-nonterminal-check-obarray nil)
+ (error "Infinite recursive parse suspected on %s" nt))
+ (set (intern nt semantic-bovinate-nonterminal-check-obarray)
+ (cons stream vs)))))
+
+ ;;;###autoload
+ (defun semantic-bovinate-stream (stream &optional nonterminal)
+ "Bovinate STREAM, starting at the first NONTERMINAL rule.
+ Use `bovine-toplevel' if NONTERMINAL is not provided.
+ This is the core routine for converting a stream into a table.
+ Return the list (STREAM SEMANTIC-STREAM) where STREAM are those
+ elements of STREAM that have not been used. SEMANTIC-STREAM is the
+ list of semantic tokens found."
+ (if (not nonterminal)
+ (setq nonterminal 'bovine-toplevel))
+
+ ;; Try to detect infinite recursive parse when doing a full reparse.
+ (or semantic--buffer-cache
+ (semantic-bovinate-nonterminal-check stream nonterminal))
+
+ (let* ((table semantic--parse-table)
+ (matchlist (cdr (assq nonterminal table)))
+ (starting-stream stream)
+ (nt-loop t) ;non-terminal loop condition
+ nt-popup ;non-nil if return from nt recursion
+ nt-stack ;non-terminal recursion stack
+ s ;Temp Stream Tracker
+ lse ;Local Semantic Element
+ lte ;Local matchlist element
+ tev ;Matchlist entry values from buffer
+ val ;Value found in buffer.
+ cvl ;collected values list.
+ out ;Output
+ end ;End of match
+ result
+ )
+ (condition-case debug-condition
+ (while nt-loop
+ (catch 'push-non-terminal
+ (setq nt-popup nil
+ end (semantic-lex-token-end (car stream)))
+ (while (or nt-loop nt-popup)
+ (setq nt-loop nil
+ out nil)
+ (while (or nt-popup matchlist)
+ (if nt-popup
+ ;; End of a non-terminal recursion
+ (setq nt-popup nil)
+ ;; New matching process
+ (setq s stream ;init s from stream.
+ cvl nil ;re-init the collected value list.
+ lte (car matchlist) ;Get the local matchlist entry.
+ )
+ (if (or (byte-code-function-p (car lte))
+ (listp (car lte)))
+ ;; In this case, we have an EMPTY match! Make
+ ;; stuff up.
+ (setq cvl (list nil))))
+
+ (while (and lte
+ (not (byte-code-function-p (car lte)))
+ (not (listp (car lte))))
+
+ ;; GRAMMAR SOURCE DEBUGGING!
- (frame (semantic-bovine-debug-create-frame
- db-nt db-midx db-tidx cvl (car s)))
++ (if (and (boundp 'semantic-debug-enabled)
++ semantic-debug-enabled)
+ (let* ((db-nt (semantic-bovinate-nonterminal-db-nt))
+ (db-ml (cdr (assq db-nt table)))
+ (db-mlen (length db-ml))
+ (db-midx (- db-mlen (length matchlist)))
+ (db-tlen (length (nth db-midx db-ml)))
+ (db-tidx (- db-tlen (length lte)))
- (if semantic-debug-enabled
- (let ((frame (semantic-create-bovine-debug-error-frame
- debug-condition)))
- (semantic-debug-break frame)
- ))
- ))
++ (frame (progn
++ (require 'semantic/bovine/debug)
++ (semantic-bovine-debug-create-frame
++ db-nt db-midx db-tidx cvl (car s))))
+ (cmd (semantic-debug-break frame))
+ )
+ (cond ((eq 'fail cmd) (setq lte '(trash 0 . 0)))
+ ((eq 'quit cmd) (signal 'quit "Abort"))
+ ((eq 'abort cmd) (error "Abort"))
+ ;; support more commands here.
+
+ )))
+ ;; END GRAMMAR SOURCE DEBUGGING!
+
+ (cond
+ ;; We have a nonterminal symbol. Recurse inline.
+ ((setq nt-loop (assq (car lte) table))
+
+ (setq
+ ;; push state into the nt-stack
+ nt-stack (cons (vector matchlist cvl lte stream end
+ )
+ nt-stack)
+ ;; new non-terminal matchlist
+ matchlist (cdr nt-loop)
+ ;; new non-terminal stream
+ stream s)
+
+ (throw 'push-non-terminal t)
+
+ )
+ ;; Default case
+ (t
+ (setq lse (car s) ;Get the local stream element
+ s (cdr s)) ;update stream.
+ ;; Do the compare
+ (if (eq (car lte) (semantic-lex-token-class lse)) ;syntactic match
+ (let ((valdot (semantic-lex-token-bounds lse)))
+ (setq val (semantic-lex-token-text lse))
+ (setq lte (cdr lte))
+ (if (stringp (car lte))
+ (progn
+ (setq tev (car lte)
+ lte (cdr lte))
+ (if (string-match tev val)
+ (setq cvl (cons
+ (if (memq (semantic-lex-token-class lse)
+ '(comment semantic-list))
+ valdot val)
+ cvl)) ;append this value
+ (setq lte nil cvl nil))) ;clear the entry (exit)
+ (setq cvl (cons
+ (if (memq (semantic-lex-token-class lse)
+ '(comment semantic-list))
+ valdot val) cvl))) ;append unchecked value.
+ (setq end (semantic-lex-token-end lse))
+ )
+ (setq lte nil cvl nil)) ;No more matches, exit
+ )))
+ (if (not cvl) ;lte=nil; there was no match.
+ (setq matchlist (cdr matchlist)) ;Move to next matchlist entry
+ (let ((start (semantic-lex-token-start (car stream))))
+ (setq out (cond
+ ((car lte)
+ (funcall (car lte) ;call matchlist fn on values
+ (nreverse cvl) start end))
+ ((and (= (length cvl) 1)
+ (listp (car cvl))
+ (not (numberp (car (car cvl)))))
+ (append (car cvl) (list start end)))
+ (t
+ ;;(append (nreverse cvl) (list start end))))
+ ;; MAYBE THE FOLLOWING NEEDS LESS CONS
+ ;; CELLS THAN THE ABOVE?
+ (nreverse (cons end (cons start cvl)))))
+ matchlist nil) ;;generate exit condition
+ (if (not end)
+ (setq out nil)))
+ ;; Nothin?
+ ))
+ (setq result
+ (if (eq s starting-stream)
+ (list (cdr s) nil)
+ (list s out)))
+ (if nt-stack
+ ;; pop previous state from the nt-stack
+ (let ((state (car nt-stack)))
+
+ (setq nt-popup t
+ ;; pop actual parser state
+ matchlist (aref state 0)
+ cvl (aref state 1)
+ lte (aref state 2)
+ stream (aref state 3)
+ end (aref state 4)
+ ;; update the stack
+ nt-stack (cdr nt-stack))
+
+ (if out
+ (let ((len (length out))
+ (strip (nreverse (cdr (cdr (reverse out))))))
+ (setq end (nth (1- len) out) ;reset end to the end of exp
+ cvl (cons strip cvl) ;prepend value of exp
+ lte (cdr lte)) ;update the local table entry
+ )
+ ;; No value means that we need to terminate this
+ ;; match.
+ (setq lte nil cvl nil)) ;No match, exit
+ )))))
+ (error
+ ;; On error just move forward the stream of lexical tokens
+ (setq result (list (cdr starting-stream) nil))
++ (when (and (boundp 'semantic-debug-enabled)
++ semantic-debug-enabled)
++ (require 'semantic/bovine/debug)
++ (let ((frame (semantic-create-bovine-debug-error-frame
++ debug-condition)))
++ (semantic-debug-break frame)))))
+ result))
+
+ ;; Make it the default parser
+ ;;;###autoload
+ (defalias 'semantic-parse-stream-default 'semantic-bovinate-stream)
+
+ (provide 'semantic/bovine)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/bovine"
+ ;; End:
+
+ ;;; semantic/bovine.el ends here
--- /dev/null
-
-\f
-;;; Analyzers
-;;
-(require 'semantic/lex)
-
+ ;;; semantic/bovine/c-by.el --- Generated parser support file
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+ ;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; This file was generated from the grammar file semantic/bovine/c.by
+ ;; in the CEDET repository.
+
+ ;;; Code:
+
++(require 'semantic/lex)
+ (eval-when-compile (require 'semantic/bovine))
++
+ (declare-function semantic-c-reconstitute-token "semantic/bovine/c")
+ (declare-function semantic-c-reconstitute-template "semantic/bovine/c")
+ (declare-function semantic-expand-c-tag "semantic/bovine/c")
+
+ (defconst semantic-c-by--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("extern" . EXTERN)
+ ("static" . STATIC)
+ ("const" . CONST)
+ ("volatile" . VOLATILE)
+ ("register" . REGISTER)
+ ("signed" . SIGNED)
+ ("unsigned" . UNSIGNED)
+ ("inline" . INLINE)
+ ("virtual" . VIRTUAL)
+ ("mutable" . MUTABLE)
+ ("struct" . STRUCT)
+ ("union" . UNION)
+ ("enum" . ENUM)
+ ("typedef" . TYPEDEF)
+ ("class" . CLASS)
+ ("typename" . TYPENAME)
+ ("namespace" . NAMESPACE)
+ ("using" . USING)
+ ("new" . NEW)
+ ("delete" . DELETE)
+ ("template" . TEMPLATE)
+ ("throw" . THROW)
+ ("reentrant" . REENTRANT)
+ ("try" . TRY)
+ ("catch" . CATCH)
+ ("operator" . OPERATOR)
+ ("public" . PUBLIC)
+ ("private" . PRIVATE)
+ ("protected" . PROTECTED)
+ ("friend" . FRIEND)
+ ("if" . IF)
+ ("else" . ELSE)
+ ("do" . DO)
+ ("while" . WHILE)
+ ("for" . FOR)
+ ("switch" . SWITCH)
+ ("case" . CASE)
+ ("default" . DEFAULT)
+ ("return" . RETURN)
+ ("break" . BREAK)
+ ("continue" . CONTINUE)
+ ("sizeof" . SIZEOF)
+ ("void" . VOID)
+ ("char" . CHAR)
+ ("wchar_t" . WCHAR)
+ ("short" . SHORT)
+ ("int" . INT)
+ ("long" . LONG)
+ ("float" . FLOAT)
+ ("double" . DOUBLE)
+ ("bool" . BOOL)
+ ("_P" . UNDERP)
+ ("__P" . UNDERUNDERP))
+ '(("__P" summary "Common macro to eliminate prototype compatibility on some compilers")
+ ("_P" summary "Common macro to eliminate prototype compatibility on some compilers")
+ ("bool" summary "Primitive boolean type")
+ ("double" summary "Primitive floating-point type (double-precision 64-bit IEEE 754)")
+ ("float" summary "Primitive floating-point type (single-precision 32-bit IEEE 754)")
+ ("long" summary "Integral primitive type (-9223372036854775808 to 9223372036854775807)")
+ ("int" summary "Integral Primitive Type: (-2147483648 to 2147483647)")
+ ("short" summary "Integral Primitive Type: (-32768 to 32767)")
+ ("wchar_t" summary "Wide Character Type")
+ ("char" summary "Integral Character Type: (0 to 256)")
+ ("void" summary "Built in typeless type: void")
+ ("sizeof" summary "Compile time macro: sizeof(<type or variable>) // size in bytes")
+ ("continue" summary "Non-local continue within a loop (for, do/while): continue;")
+ ("break" summary "Non-local exit within a loop or switch (for, do/while, switch): break;")
+ ("return" summary "return <value>;")
+ ("default" summary "switch (<variable>) { case <constvalue>: code; ... default: code; }")
+ ("case" summary "switch (<variable>) { case <constvalue>: code; ... default: code; }")
+ ("switch" summary "switch (<variable>) { case <constvalue>: code; ... default: code; }")
+ ("for" summary "for(<init>; <condition>; <increment>) { code }")
+ ("while" summary "do { code } while (<condition>); or while (<condition>) { code };")
+ ("do" summary " do { code } while (<condition>);")
+ ("else" summary "if (<condition>) { code } [ else { code } ]")
+ ("if" summary "if (<condition>) { code } [ else { code } ]")
+ ("friend" summary "friend class <CLASSNAME>")
+ ("catch" summary "try { <body> } catch { <catch code> }")
+ ("try" summary "try { <body> } catch { <catch code> }")
+ ("reentrant" summary "<type> <methoddef> (<method args>) reentrant ...")
+ ("throw" summary "<type> <methoddef> (<method args>) throw (<exception>) ...")
+ ("template" summary "template <class TYPE ...> TYPE_OR_FUNCTION")
+ ("delete" summary "delete <object>;")
+ ("new" summary "new <classname>();")
+ ("using" summary "using <namespace>;")
+ ("namespace" summary "Namespace Declaration: namespace <name> { ... };")
+ ("typename" summary "typename is used to handle a qualified name as a typename;")
+ ("class" summary "Class Declaration: class <name>[:parents] { ... };")
+ ("typedef" summary "Arbitrary Type Declaration: typedef <typedeclaration> <name>;")
+ ("enum" summary "Enumeration Type Declaration: enum [name] { ... };")
+ ("union" summary "Union Type Declaration: union [name] { ... };")
+ ("struct" summary "Structure Type Declaration: struct [name] { ... };")
+ ("mutable" summary "Member Declaration Modifier: mutable <type> <name> ...")
+ ("virtual" summary "Method Modifier: virtual <type> <name>(...) ...")
+ ("inline" summary "Function Modifier: inline <return type> <name>(...) {...};")
+ ("unsigned" summary "Numeric Type Modifier: unsigned <numeric type> <name> ...")
+ ("signed" summary "Numeric Type Modifier: signed <numeric type> <name> ...")
+ ("register" summary "Declaration Modifier: register <type> <name> ...")
+ ("volatile" summary "Declaration Modifier: volatile <type> <name> ...")
+ ("const" summary "Declaration Modifier: const <type> <name> ...")
+ ("static" summary "Declaration Modifier: static <type> <name> ...")
+ ("extern" summary "Declaration Modifier: extern <type> <name> ...")))
+ "Table of language keywords.")
+
+ (defconst semantic-c-by--token-table
+ (semantic-lex-make-type-table
+ '(("semantic-list"
+ (BRACKETS . "\\[\\]")
+ (PARENS . "()")
+ (VOID_BLCK . "^(void)$")
+ (BRACE_BLCK . "^{")
+ (PAREN_BLCK . "^(")
+ (BRACK_BLCK . "\\[.*\\]$"))
+ ("close-paren"
+ (RBRACE . "}")
+ (RPAREN . ")"))
+ ("open-paren"
+ (LBRACE . "{")
+ (LPAREN . "("))
+ ("symbol"
+ (RESTRICT . "\\<\\(__\\)?restrict\\>"))
+ ("number"
+ (ZERO . "^0$"))
+ ("string"
+ (CPP . "\"C\\+\\+\"")
+ (C . "\"C\""))
+ ("punctuation"
+ (OR . "\\`[|]\\'")
+ (HAT . "\\`\\^\\'")
+ (MOD . "\\`[%]\\'")
+ (TILDE . "\\`[~]\\'")
+ (COMA . "\\`[,]\\'")
+ (GREATER . "\\`[>]\\'")
+ (LESS . "\\`[<]\\'")
+ (EQUAL . "\\`[=]\\'")
+ (BANG . "\\`[!]\\'")
+ (MINUS . "\\`[-]\\'")
+ (PLUS . "\\`[+]\\'")
+ (DIVIDE . "\\`[/]\\'")
+ (AMPERSAND . "\\`[&]\\'")
+ (STAR . "\\`[*]\\'")
+ (SEMICOLON . "\\`[;]\\'")
+ (COLON . "\\`[:]\\'")
+ (PERIOD . "\\`[.]\\'")
+ (HASH . "\\`[#]\\'")))
+ 'nil)
+ "Table of lexical tokens.")
+
+ (defconst semantic-c-by--parse-table
+ `(
+ (bovine-toplevel
+ (declaration)
+ ) ;; end bovine-toplevel
+
+ (bovine-inner-scope
+ (codeblock)
+ ) ;; end bovine-inner-scope
+
+ (declaration
+ (macro)
+ (type)
+ (define)
+ (var-or-fun)
+ (extern-c)
+ (template)
+ (using)
+ ) ;; end declaration
+
+ (codeblock
+ (define)
+ (codeblock-var-or-fun)
+ (type)
+ (using)
+ ) ;; end codeblock
+
+ (extern-c-contents
+ (open-paren
+ ,(semantic-lambda
+ (list nil))
+ )
+ (declaration)
+ (close-paren
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end extern-c-contents
+
+ (extern-c
+ (EXTERN
+ string
+ "\"C\""
+ semantic-list
+ ,(semantic-lambda
+ (semantic-tag
+ "C"
+ 'extern :members
+ (semantic-parse-region
+ (car
+ (nth 2 vals))
+ (cdr
+ (nth 2 vals))
+ 'extern-c-contents
+ 1)))
+ )
+ (EXTERN
+ string
+ "\"C\\+\\+\""
+ semantic-list
+ ,(semantic-lambda
+ (semantic-tag
+ "C"
+ 'extern :members
+ (semantic-parse-region
+ (car
+ (nth 2 vals))
+ (cdr
+ (nth 2 vals))
+ 'extern-c-contents
+ 1)))
+ )
+ (EXTERN
+ string
+ "\"C\""
+ ,(semantic-lambda
+ (list nil))
+ )
+ (EXTERN
+ string
+ "\"C\\+\\+\""
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end extern-c
+
+ (macro
+ (spp-macro-def
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nth 0 vals) nil nil :constant-flag t))
+ )
+ (spp-system-include
+ ,(semantic-lambda
+ (semantic-tag-new-include
+ (nth 0 vals) t))
+ )
+ (spp-include
+ ,(semantic-lambda
+ (semantic-tag-new-include
+ (nth 0 vals) nil))
+ )
+ ) ;; end macro
+
+ (define
+ (spp-macro-def
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nth 0 vals) nil nil :constant-flag t))
+ )
+ (spp-macro-undef
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end define
+
+ (unionparts
+ (semantic-list
+ ,(semantic-lambda
+ (semantic-parse-region
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'classsubparts
+ 1))
+ )
+ ) ;; end unionparts
+
+ (opt-symbol
+ (symbol)
+ ( ;;EMPTY
+ )
+ ) ;; end opt-symbol
+
+ (classsubparts
+ (open-paren
+ "{"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (close-paren
+ "}"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (class-protection
+ opt-symbol
+ punctuation
+ "\\`[:]\\'"
+ ,(semantic-lambda
+ (semantic-tag
+ (car
+ (nth 0 vals))
+ 'label))
+ )
+ (var-or-fun)
+ (FRIEND
+ func-decl
+ ,(semantic-lambda
+ (semantic-tag
+ (car
+ (nth 1 vals))
+ 'friend))
+ )
+ (FRIEND
+ CLASS
+ symbol
+ ,(semantic-lambda
+ (semantic-tag
+ (nth 2 vals)
+ 'friend))
+ )
+ (type)
+ (define)
+ (template)
+ ( ;;EMPTY
+ )
+ ) ;; end classsubparts
+
+ (opt-class-parents
+ (punctuation
+ "\\`[:]\\'"
+ class-parents
+ opt-template-specifier
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end opt-class-parents
+
+ (one-class-parent
+ (opt-class-protection
+ opt-class-declmods
+ namespace-symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ "class" nil nil :protection
+ (car
+ (nth 0 vals))))
+ )
+ (opt-class-declmods
+ opt-class-protection
+ namespace-symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ "class" nil nil :protection
+ (car
+ (nth 1 vals))))
+ )
+ ) ;; end one-class-parent
+
+ (class-parents
+ (one-class-parent
+ punctuation
+ "\\`[,]\\'"
+ class-parents
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 2 vals)))
+ )
+ (one-class-parent
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end class-parents
+
+ (opt-class-declmods
+ (class-declmods
+ opt-class-declmods
+ ,(semantic-lambda
+ (list nil))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end opt-class-declmods
+
+ (class-declmods
+ (VIRTUAL)
+ ) ;; end class-declmods
+
+ (class-protection
+ (PUBLIC)
+ (PRIVATE)
+ (PROTECTED)
+ ) ;; end class-protection
+
+ (opt-class-protection
+ (class-protection
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list
+ "unspecified"))
+ )
+ ) ;; end opt-class-protection
+
+ (namespaceparts
+ (semantic-list
+ ,(semantic-lambda
+ (semantic-parse-region
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'namespacesubparts
+ 1))
+ )
+ ) ;; end namespaceparts
+
+ (namespacesubparts
+ (open-paren
+ "{"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (close-paren
+ "}"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (type)
+ (var-or-fun)
+ (define)
+ (class-protection
+ punctuation
+ "\\`[:]\\'"
+ ,(semantic-lambda
+ (semantic-tag
+ (car
+ (nth 0 vals))
+ 'label))
+ )
+ (template)
+ (using)
+ ( ;;EMPTY
+ )
+ ) ;; end namespacesubparts
+
+ (enumparts
+ (semantic-list
+ ,(semantic-lambda
+ (semantic-parse-region
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'enumsubparts
+ 1))
+ )
+ ) ;; end enumparts
+
+ (enumsubparts
+ (symbol
+ opt-assign
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nth 0 vals)
+ "int"
+ (car
+ (nth 1 vals)) :constant-flag t))
+ )
+ (open-paren
+ "{"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (close-paren
+ "}"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (punctuation
+ "\\`[,]\\'"
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end enumsubparts
+
+ (opt-name
+ (symbol)
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list
+ ""))
+ )
+ ) ;; end opt-name
+
+ (typesimple
+ (struct-or-class
+ opt-class
+ opt-name
+ opt-template-specifier
+ opt-class-parents
+ semantic-list
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ (car
+ (nth 0 vals))
+ (let
+ (
+ (semantic-c-classname
+ (cons
+ (car
+ (nth 2 vals))
+ (car
+ (nth 0 vals)))))
+ (semantic-parse-region
+ (car
+ (nth 5 vals))
+ (cdr
+ (nth 5 vals))
+ 'classsubparts
+ 1))
+ (nth 4 vals) :template-specifier
+ (nth 3 vals) :parent
+ (car
+ (nth 1 vals))))
+ )
+ (struct-or-class
+ opt-class
+ opt-name
+ opt-template-specifier
+ opt-class-parents
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ (car
+ (nth 0 vals)) nil
+ (nth 4 vals) :template-specifier
+ (nth 3 vals) :prototype t :parent
+ (car
+ (nth 1 vals))))
+ )
+ (UNION
+ opt-class
+ opt-name
+ unionparts
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ (nth 0 vals)
+ (nth 3 vals) nil :parent
+ (car
+ (nth 1 vals))))
+ )
+ (ENUM
+ opt-class
+ opt-name
+ enumparts
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 2 vals))
+ (nth 0 vals)
+ (nth 3 vals) nil :parent
+ (car
+ (nth 1 vals))))
+ )
+ (TYPEDEF
+ declmods
+ typeformbase
+ cv-declmods
+ typedef-symbol-list
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 4 vals)
+ (nth 0 vals) nil
+ (list
+ (nth 2 vals))))
+ )
+ ) ;; end typesimple
+
+ (typedef-symbol-list
+ (typedefname
+ punctuation
+ "\\`[,]\\'"
+ typedef-symbol-list
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 2 vals)))
+ )
+ (typedefname
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end typedef-symbol-list
+
+ (typedefname
+ (opt-stars
+ symbol
+ opt-bits
+ opt-array
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)
+ (nth 1 vals)))
+ )
+ ) ;; end typedefname
+
+ (struct-or-class
+ (STRUCT)
+ (CLASS)
+ ) ;; end struct-or-class
+
+ (type
+ (typesimple
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (NAMESPACE
+ symbol
+ namespaceparts
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ (nth 0 vals)
+ (nth 2 vals) nil))
+ )
+ (NAMESPACE
+ namespaceparts
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ "unnamed"
+ (nth 0 vals)
+ (nth 1 vals) nil))
+ )
+ (NAMESPACE
+ symbol
+ punctuation
+ "\\`[=]\\'"
+ typeformbase
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ (nth 0 vals)
+ (list
+ (semantic-tag-new-type
+ (car
+ (nth 3 vals))
+ (nth 0 vals) nil nil)) nil :kind
+ 'alias))
+ )
+ ) ;; end type
+
+ (using
+ (USING
+ usingname
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (semantic-tag
+ (car
+ (nth 1 vals))
+ 'using :type
+ (nth 1 vals)))
+ )
+ ) ;; end using
+
+ (usingname
+ (typeformbase
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 0 vals))
+ "class" nil nil :prototype t))
+ )
+ (NAMESPACE
+ typeformbase
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 1 vals))
+ "namespace" nil nil :prototype t))
+ )
+ ) ;; end usingname
+
+ (template
+ (TEMPLATE
+ template-specifier
+ opt-friend
+ template-definition
+ ,(semantic-lambda
+ (semantic-c-reconstitute-template
+ (nth 3 vals)
+ (nth 1 vals)))
+ )
+ ) ;; end template
+
+ (opt-friend
+ (FRIEND)
+ ( ;;EMPTY
+ )
+ ) ;; end opt-friend
+
+ (opt-template-specifier
+ (template-specifier
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end opt-template-specifier
+
+ (template-specifier
+ (punctuation
+ "\\`[<]\\'"
+ template-specifier-types
+ punctuation
+ "\\`[>]\\'"
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ ) ;; end template-specifier
+
+ (template-specifier-types
+ (template-var
+ template-specifier-type-list
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end template-specifier-types
+
+ (template-specifier-type-list
+ (punctuation
+ "\\`[,]\\'"
+ template-specifier-types
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end template-specifier-type-list
+
+ (template-var
+ (template-type
+ opt-template-equal
+ ,(semantic-lambda
+ (cons
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))))
+ )
+ (string
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ (number
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ (opt-stars
+ opt-ref
+ namespace-symbol
+ ,(semantic-lambda
+ (nth 2 vals))
+ )
+ (semantic-list
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ (SIZEOF
+ semantic-list
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ) ;; end template-var
+
+ (opt-template-equal
+ (punctuation
+ "\\`[=]\\'"
+ symbol
+ punctuation
+ "\\`[<]\\'"
+ template-specifier-types
+ punctuation
+ "\\`[>]\\'"
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ (punctuation
+ "\\`[=]\\'"
+ symbol
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end opt-template-equal
+
+ (template-type
+ (CLASS
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ "class" nil nil))
+ )
+ (STRUCT
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ "struct" nil nil))
+ )
+ (TYPENAME
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ "class" nil nil))
+ )
+ (declmods
+ typeformbase
+ cv-declmods
+ opt-stars
+ opt-ref
+ variablearg-opt-name
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 1 vals)) nil nil nil :constant-flag
+ (if
+ (member
+ "const"
+ (append
+ (nth 0 vals)
+ (nth 2 vals))) t nil) :typemodifiers
+ (delete
+ "const"
+ (append
+ (nth 0 vals)
+ (nth 2 vals))) :reference
+ (car
+ (nth 4 vals)) :pointer
+ (car
+ (nth 3 vals))))
+ )
+ ) ;; end template-type
+
+ (template-definition
+ (type
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (var-or-fun
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ) ;; end template-definition
+
+ (opt-stars
+ (punctuation
+ "\\`[*]\\'"
+ opt-starmod
+ opt-stars
+ ,(semantic-lambda
+ (list
+ (1+
+ (car
+ (nth 2 vals)))))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list
+ 0))
+ )
+ ) ;; end opt-stars
+
+ (opt-starmod
+ (STARMOD
+ opt-starmod
+ ,(semantic-lambda
+ (cons
+ (car
+ (nth 0 vals))
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end opt-starmod
+
+ (STARMOD
+ (CONST)
+ ) ;; end STARMOD
+
+ (declmods
+ (DECLMOD
+ declmods
+ ,(semantic-lambda
+ (cons
+ (car
+ (nth 0 vals))
+ (nth 1 vals)))
+ )
+ (DECLMOD
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end declmods
+
+ (DECLMOD
+ (EXTERN)
+ (STATIC)
+ (CVDECLMOD)
+ (INLINE)
+ (REGISTER)
+ (FRIEND)
+ (TYPENAME)
+ (METADECLMOD)
+ (VIRTUAL)
+ ) ;; end DECLMOD
+
+ (metadeclmod
+ (METADECLMOD
+ ,(semantic-lambda)
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end metadeclmod
+
+ (CVDECLMOD
+ (CONST)
+ (VOLATILE)
+ ) ;; end CVDECLMOD
+
+ (cv-declmods
+ (CVDECLMOD
+ cv-declmods
+ ,(semantic-lambda
+ (cons
+ (car
+ (nth 0 vals))
+ (nth 1 vals)))
+ )
+ (CVDECLMOD
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end cv-declmods
+
+ (METADECLMOD
+ (VIRTUAL)
+ (MUTABLE)
+ ) ;; end METADECLMOD
+
+ (opt-ref
+ (punctuation
+ "\\`[&]\\'"
+ ,(semantic-lambda
+ (list
+ 1))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list
+ 0))
+ )
+ ) ;; end opt-ref
+
+ (typeformbase
+ (typesimple
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (STRUCT
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ (nth 0 vals) nil nil))
+ )
+ (UNION
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ (nth 0 vals) nil nil))
+ )
+ (ENUM
+ symbol
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 1 vals)
+ (nth 0 vals) nil nil))
+ )
+ (builtintype
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (symbol
+ template-specifier
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (nth 0 vals)
+ "class" nil nil :template-specifier
+ (nth 1 vals)))
+ )
+ (namespace-symbol-for-typeformbase
+ opt-template-specifier
+ ,(semantic-lambda
+ (semantic-tag-new-type
+ (car
+ (nth 0 vals))
+ "class" nil nil :template-specifier
+ (nth 1 vals)))
+ )
+ (symbol
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end typeformbase
+
+ (signedmod
+ (UNSIGNED)
+ (SIGNED)
+ ) ;; end signedmod
+
+ (builtintype-types
+ (VOID)
+ (CHAR)
+ (WCHAR)
+ (SHORT
+ INT
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ " "
+ (nth 1 vals))))
+ )
+ (SHORT)
+ (INT)
+ (LONG
+ INT
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ " "
+ (nth 1 vals))))
+ )
+ (FLOAT)
+ (DOUBLE)
+ (BOOL)
+ (LONG
+ DOUBLE
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ " "
+ (nth 1 vals))))
+ )
+ (LONG
+ LONG
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ " "
+ (nth 1 vals))))
+ )
+ (LONG)
+ ) ;; end builtintype-types
+
+ (builtintype
+ (signedmod
+ builtintype-types
+ ,(semantic-lambda
+ (list
+ (concat
+ (car
+ (nth 0 vals))
+ " "
+ (car
+ (nth 1 vals)))))
+ )
+ (builtintype-types
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (signedmod
+ ,(semantic-lambda
+ (list
+ (concat
+ (car
+ (nth 0 vals))
+ " int")))
+ )
+ ) ;; end builtintype
+
+ (codeblock-var-or-fun
+ (declmods
+ typeformbase
+ declmods
+ opt-ref
+ var-or-func-decl
+ ,(semantic-lambda
+ (semantic-c-reconstitute-token
+ (nth 4 vals)
+ (nth 0 vals)
+ (nth 1 vals)))
+ )
+ ) ;; end codeblock-var-or-fun
+
+ (var-or-fun
+ (codeblock-var-or-fun
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (declmods
+ var-or-func-decl
+ ,(semantic-lambda
+ (semantic-c-reconstitute-token
+ (nth 1 vals)
+ (nth 0 vals) nil))
+ )
+ ) ;; end var-or-fun
+
+ (var-or-func-decl
+ (func-decl
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (var-decl
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ) ;; end var-or-func-decl
+
+ (func-decl
+ (opt-stars
+ opt-class
+ opt-destructor
+ functionname
+ opt-template-specifier
+ opt-under-p
+ arg-list
+ opt-post-fcn-modifiers
+ opt-throw
+ opt-initializers
+ fun-or-proto-end
+ ,(semantic-lambda
+ (nth 3 vals)
+ (list
+ 'function
+ (nth 1 vals)
+ (nth 2 vals)
+ (nth 6 vals)
+ (nth 8 vals)
+ (nth 7 vals))
+ (nth 0 vals)
+ (nth 10 vals)
+ (nth 4 vals))
+ )
+ (opt-stars
+ opt-class
+ opt-destructor
+ functionname
+ opt-template-specifier
+ opt-under-p
+ opt-post-fcn-modifiers
+ opt-throw
+ opt-initializers
+ fun-try-end
+ ,(semantic-lambda
+ (nth 3 vals)
+ (list
+ 'function
+ (nth 1 vals)
+ (nth 2 vals) nil
+ (nth 7 vals)
+ (nth 6 vals))
+ (nth 0 vals)
+ (nth 9 vals)
+ (nth 4 vals))
+ )
+ ) ;; end func-decl
+
+ (var-decl
+ (varnamelist
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)
+ 'variable))
+ )
+ ) ;; end var-decl
+
+ (opt-under-p
+ (UNDERP
+ ,(semantic-lambda
+ (list nil))
+ )
+ (UNDERUNDERP
+ ,(semantic-lambda
+ (list nil))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end opt-under-p
+
+ (opt-initializers
+ (punctuation
+ "\\`[:]\\'"
+ namespace-symbol
+ semantic-list
+ opt-initializers)
+ (punctuation
+ "\\`[,]\\'"
+ namespace-symbol
+ semantic-list
+ opt-initializers)
+ ( ;;EMPTY
+ )
+ ) ;; end opt-initializers
+
+ (opt-post-fcn-modifiers
+ (post-fcn-modifiers
+ opt-post-fcn-modifiers
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-post-fcn-modifiers
+
+ (post-fcn-modifiers
+ (REENTRANT)
+ (CONST)
+ ) ;; end post-fcn-modifiers
+
+ (opt-throw
+ (THROW
+ semantic-list
+ ,(lambda (vals start end)
+ (semantic-bovinate-from-nonterminal
+ (car
+ (nth 1 vals))
+ (cdr
+ (nth 1 vals))
+ 'throw-exception-list))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end opt-throw
+
+ (throw-exception-list
+ (namespace-symbol
+ punctuation
+ "\\`[,]\\'"
+ throw-exception-list
+ ,(semantic-lambda
+ (cons
+ (car
+ (nth 0 vals))
+ (nth 2 vals)))
+ )
+ (namespace-symbol
+ close-paren
+ ")"
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (symbol
+ close-paren
+ ")"
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ (open-paren
+ "("
+ throw-exception-list
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (close-paren
+ ")"
+ ,(semantic-lambda)
+ )
+ ) ;; end throw-exception-list
+
+ (opt-bits
+ (punctuation
+ "\\`[:]\\'"
+ number
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-bits
+
+ (opt-array
+ (semantic-list
+ "\\[.*\\]$"
+ opt-array
+ ,(semantic-lambda
+ (list
+ (cons
+ 1
+ (car
+ (nth 1 vals)))))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-array
+
+ (opt-assign
+ (punctuation
+ "\\`[=]\\'"
+ expression
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-assign
+
+ (opt-restrict
+ (symbol
+ "\\<\\(__\\)?restrict\\>")
+ ( ;;EMPTY
+ )
+ ) ;; end opt-restrict
+
+ (varname
+ (opt-stars
+ opt-restrict
+ namespace-symbol
+ opt-bits
+ opt-array
+ opt-assign
+ ,(semantic-lambda
+ (nth 2 vals)
+ (nth 0 vals)
+ (nth 3 vals)
+ (nth 4 vals)
+ (nth 5 vals))
+ )
+ ) ;; end varname
+
+ (variablearg
+ (declmods
+ typeformbase
+ cv-declmods
+ opt-ref
+ variablearg-opt-name
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (list
+ (nth 4 vals))
+ (nth 1 vals) nil :constant-flag
+ (if
+ (member
+ "const"
+ (append
+ (nth 0 vals)
+ (nth 2 vals))) t nil) :typemodifiers
+ (delete
+ "const"
+ (append
+ (nth 0 vals)
+ (nth 2 vals))) :reference
+ (car
+ (nth 3 vals))))
+ )
+ ) ;; end variablearg
+
+ (variablearg-opt-name
+ (varname
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (opt-stars
+ ,(semantic-lambda
+ (list
+ "")
+ (nth 0 vals)
+ (list nil nil nil))
+ )
+ ) ;; end variablearg-opt-name
+
+ (varnamelist
+ (opt-ref
+ varname
+ punctuation
+ "\\`[,]\\'"
+ varnamelist
+ ,(semantic-lambda
+ (cons
+ (nth 1 vals)
+ (nth 3 vals)))
+ )
+ (opt-ref
+ varname
+ ,(semantic-lambda
+ (list
+ (nth 1 vals)))
+ )
+ ) ;; end varnamelist
+
+ (namespace-symbol
+ (symbol
+ opt-template-specifier
+ punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[:]\\'"
+ namespace-symbol
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ "::"
+ (car
+ (nth 4 vals)))))
+ )
+ (symbol
+ opt-template-specifier
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end namespace-symbol
+
+ (namespace-symbol-for-typeformbase
+ (symbol
+ opt-template-specifier
+ punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[:]\\'"
+ namespace-symbol-for-typeformbase
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ "::"
+ (car
+ (nth 4 vals)))))
+ )
+ (symbol
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end namespace-symbol-for-typeformbase
+
+ (namespace-opt-class
+ (symbol
+ punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[:]\\'"
+ namespace-opt-class
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ "::"
+ (car
+ (nth 3 vals)))))
+ )
+ (symbol
+ opt-template-specifier
+ punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[:]\\'"
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end namespace-opt-class
+
+ (opt-class
+ (namespace-opt-class
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-class
+
+ (opt-destructor
+ (punctuation
+ "\\`[~]\\'"
+ ,(semantic-lambda
+ (list t))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end opt-destructor
+
+ (arg-list
+ (semantic-list
+ "^("
+ knr-arguments
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (semantic-list
+ "^("
+ ,(semantic-lambda
+ (semantic-parse-region
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'arg-sub-list
+ 1))
+ )
+ (semantic-list
+ "^(void)$"
+ ,(semantic-lambda)
+ )
+ ) ;; end arg-list
+
+ (knr-varnamelist
+ (varname
+ punctuation
+ "\\`[,]\\'"
+ knr-varnamelist
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 2 vals)))
+ )
+ (varname
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end knr-varnamelist
+
+ (knr-one-variable-decl
+ (declmods
+ typeformbase
+ cv-declmods
+ knr-varnamelist
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nreverse
+ (nth 3 vals))
+ (nth 1 vals) nil :constant-flag
+ (if
+ (member
+ "const"
+ (append
+ (nth 2 vals))) t nil) :typemodifiers
+ (delete
+ "const"
+ (nth 2 vals))))
+ )
+ ) ;; end knr-one-variable-decl
+
+ (knr-arguments
+ (knr-one-variable-decl
+ punctuation
+ "\\`[;]\\'"
+ knr-arguments
+ ,(semantic-lambda
+ (append
+ (semantic-expand-c-tag
+ (nth 0 vals))
+ (nth 2 vals)))
+ )
+ (knr-one-variable-decl
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (semantic-expand-c-tag
+ (nth 0 vals)))
+ )
+ ) ;; end knr-arguments
+
+ (arg-sub-list
+ (variablearg
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ (punctuation
+ "\\`[.]\\'"
+ punctuation
+ "\\`[.]\\'"
+ punctuation
+ "\\`[.]\\'"
+ close-paren
+ ")"
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ "..."
+ "vararg" nil))
+ )
+ (punctuation
+ "\\`[,]\\'"
+ ,(semantic-lambda
+ (list nil))
+ )
+ (open-paren
+ "("
+ ,(semantic-lambda
+ (list nil))
+ )
+ (close-paren
+ ")"
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end arg-sub-list
+
+ (operatorsym
+ (punctuation
+ "\\`[<]\\'"
+ punctuation
+ "\\`[<]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "<<="))
+ )
+ (punctuation
+ "\\`[>]\\'"
+ punctuation
+ "\\`[>]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ ">>="))
+ )
+ (punctuation
+ "\\`[<]\\'"
+ punctuation
+ "\\`[<]\\'"
+ ,(semantic-lambda
+ (list
+ "<<"))
+ )
+ (punctuation
+ "\\`[>]\\'"
+ punctuation
+ "\\`[>]\\'"
+ ,(semantic-lambda
+ (list
+ ">>"))
+ )
+ (punctuation
+ "\\`[=]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "=="))
+ )
+ (punctuation
+ "\\`[<]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "<="))
+ )
+ (punctuation
+ "\\`[>]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ ">="))
+ )
+ (punctuation
+ "\\`[!]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "!="))
+ )
+ (punctuation
+ "\\`[+]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "+="))
+ )
+ (punctuation
+ "\\`[-]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "-="))
+ )
+ (punctuation
+ "\\`[*]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "*="))
+ )
+ (punctuation
+ "\\`[/]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "/="))
+ )
+ (punctuation
+ "\\`[%]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "%="))
+ )
+ (punctuation
+ "\\`[&]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "&="))
+ )
+ (punctuation
+ "\\`[|]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "|="))
+ )
+ (punctuation
+ "\\`[-]\\'"
+ punctuation
+ "\\`[>]\\'"
+ punctuation
+ "\\`[*]\\'"
+ ,(semantic-lambda
+ (list
+ "->*"))
+ )
+ (punctuation
+ "\\`[-]\\'"
+ punctuation
+ "\\`[>]\\'"
+ ,(semantic-lambda
+ (list
+ "->"))
+ )
+ (semantic-list
+ "()"
+ ,(semantic-lambda
+ (list
+ "()"))
+ )
+ (semantic-list
+ "\\[\\]"
+ ,(semantic-lambda
+ (list
+ "[]"))
+ )
+ (punctuation
+ "\\`[<]\\'")
+ (punctuation
+ "\\`[>]\\'")
+ (punctuation
+ "\\`[*]\\'")
+ (punctuation
+ "\\`[+]\\'"
+ punctuation
+ "\\`[+]\\'"
+ ,(semantic-lambda
+ (list
+ "++"))
+ )
+ (punctuation
+ "\\`[+]\\'")
+ (punctuation
+ "\\`[-]\\'"
+ punctuation
+ "\\`[-]\\'"
+ ,(semantic-lambda
+ (list
+ "--"))
+ )
+ (punctuation
+ "\\`[-]\\'")
+ (punctuation
+ "\\`[&]\\'"
+ punctuation
+ "\\`[&]\\'"
+ ,(semantic-lambda
+ (list
+ "&&"))
+ )
+ (punctuation
+ "\\`[&]\\'")
+ (punctuation
+ "\\`[|]\\'"
+ punctuation
+ "\\`[|]\\'"
+ ,(semantic-lambda
+ (list
+ "||"))
+ )
+ (punctuation
+ "\\`[|]\\'")
+ (punctuation
+ "\\`[/]\\'")
+ (punctuation
+ "\\`[=]\\'")
+ (punctuation
+ "\\`[!]\\'")
+ (punctuation
+ "\\`[~]\\'")
+ (punctuation
+ "\\`[%]\\'")
+ (punctuation
+ "\\`[,]\\'")
+ (punctuation
+ "\\`\\^\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda
+ (list
+ "^="))
+ )
+ (punctuation
+ "\\`\\^\\'")
+ ) ;; end operatorsym
+
+ (functionname
+ (OPERATOR
+ operatorsym
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (semantic-list
+ ,(lambda (vals start end)
+ (semantic-bovinate-from-nonterminal
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'function-pointer))
+ )
+ (symbol
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end functionname
+
+ (function-pointer
+ (open-paren
+ "("
+ punctuation
+ "\\`[*]\\'"
+ symbol
+ close-paren
+ ")"
+ ,(semantic-lambda
+ (list
+ (concat
+ "*"
+ (nth 2 vals))))
+ )
+ ) ;; end function-pointer
+
+ (fun-or-proto-end
+ (punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (list t))
+ )
+ (semantic-list
+ ,(semantic-lambda
+ (list nil))
+ )
+ (punctuation
+ "\\`[=]\\'"
+ number
+ "^0$"
+ punctuation
+ "\\`[;]\\'"
+ ,(semantic-lambda
+ (list ':pure-virtual-flag))
+ )
+ (fun-try-end
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end fun-or-proto-end
+
+ (fun-try-end
+ (TRY
+ opt-initializers
+ semantic-list
+ "^{"
+ fun-try-several-catches
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end fun-try-end
+
+ (fun-try-several-catches
+ (CATCH
+ semantic-list
+ "^("
+ semantic-list
+ "^{"
+ fun-try-several-catches
+ ,(semantic-lambda)
+ )
+ (CATCH
+ semantic-list
+ "^{"
+ fun-try-several-catches
+ ,(semantic-lambda)
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end fun-try-several-catches
+
+ (type-cast
+ (semantic-list
+ ,(lambda (vals start end)
+ (semantic-bovinate-from-nonterminal
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'type-cast-list))
+ )
+ ) ;; end type-cast
+
+ (type-cast-list
+ (open-paren
+ typeformbase
+ close-paren)
+ ) ;; end type-cast-list
+
+ (opt-stuff-after-symbol
+ (semantic-list
+ "^(")
+ (semantic-list
+ "\\[.*\\]$")
+ ( ;;EMPTY
+ )
+ ) ;; end opt-stuff-after-symbol
+
+ (multi-stage-dereference
+ (namespace-symbol
+ opt-stuff-after-symbol
+ punctuation
+ "\\`[.]\\'"
+ multi-stage-dereference)
+ (namespace-symbol
+ opt-stuff-after-symbol
+ punctuation
+ "\\`[-]\\'"
+ punctuation
+ "\\`[>]\\'"
+ multi-stage-dereference)
+ (namespace-symbol
+ opt-stuff-after-symbol)
+ ) ;; end multi-stage-dereference
+
+ (string-seq
+ (string
+ string-seq
+ ,(semantic-lambda
+ (list
+ (concat
+ (nth 0 vals)
+ (car
+ (nth 1 vals)))))
+ )
+ (string
+ ,(semantic-lambda
+ (list
+ (nth 0 vals)))
+ )
+ ) ;; end string-seq
+
+ (expr-start
+ (punctuation
+ "\\`[-]\\'")
+ (punctuation
+ "\\`[+]\\'")
+ (punctuation
+ "\\`[*]\\'")
+ (punctuation
+ "\\`[&]\\'")
+ ) ;; end expr-start
+
+ (expression
+ (number
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (multi-stage-dereference
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (NEW
+ multi-stage-dereference
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (NEW
+ builtintype-types
+ semantic-list
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (namespace-symbol
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (string-seq
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (type-cast
+ expression
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (semantic-list
+ expression
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (semantic-list
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ (expr-start
+ expression
+ ,(semantic-lambda
+ (list
+ (identity start)
+ (identity end)))
+ )
+ ) ;; end expression
+ )
+ "Parser table.")
+
+ (defun semantic-c-by--install-parser ()
+ "Setup the Semantic Parser."
+ (setq semantic--parse-table semantic-c-by--parse-table
+ semantic-debug-parser-source "c.by"
+ semantic-debug-parser-class 'semantic-bovine-debug-parser
+ semantic-flex-keywords-obarray semantic-c-by--keyword-table
+ semantic-equivalent-major-modes '(c-mode c++-mode)
+ ))
+ \f
+ ;;; Epilogue
+ ;;
+
+ (provide 'semantic/bovine/c-by)
+
+ ;;; semantic/bovine/c-by.el ends here
--- /dev/null
-(require 'semantic/format)
+ ;;; semantic/bovine/c.el --- Semantic details for C
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+ ;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Support for the C/C++ bovine parser for Semantic.
+ ;;
+ ;; @todo - can I support c++-font-lock-extra-types ?
+
+ (require 'semantic)
+ (require 'semantic/analyze)
+ (require 'semantic/bovine/gcc)
-(require 'backquote)
+ (require 'semantic/idle)
+ (require 'semantic/lex-spp)
- ;; For semantic-find-tags-* macros:
+ (require 'semantic/bovine/c-by)
+
+ (eval-when-compile
+ (require 'semantic/find))
+
+ (declare-function semantic-brute-find-tag-by-attribute "semantic/find")
+ (declare-function semanticdb-minor-mode-p "semantic/db-mode")
+ (declare-function semanticdb-needs-refresh-p "semantic/db")
+ (declare-function c-forward-conditional "cc-cmds")
+ (declare-function ede-system-include-path "ede")
+
+ ;;; Compatibility
+ ;;
+ (eval-when-compile (require 'cc-mode))
+
+ (if (fboundp 'c-end-of-macro)
+ (eval-and-compile
+ (defalias 'semantic-c-end-of-macro 'c-end-of-macro))
+ ;; From cc-mode 5.30
+ (defun semantic-c-end-of-macro ()
+ "Go to the end of a preprocessor directive.
+ More accurately, move point to the end of the closest following line
+ that doesn't end with a line continuation backslash.
+
+ This function does not do any hidden buffer changes."
+ (while (progn
+ (end-of-line)
+ (when (and (eq (char-before) ?\\)
+ (not (eobp)))
+ (forward-char)
+ t))))
+ )
+
+ ;;; Code:
+ (define-child-mode c++-mode c-mode
+ "`c++-mode' uses the same parser as `c-mode'.")
+
+ \f
+ ;;; Include Paths
+ ;;
+ (defcustom-mode-local-semantic-dependency-system-include-path
+ c-mode semantic-c-dependency-system-include-path
+ '("/usr/include")
+ "The system include path used by the C langauge.")
+
+ (defcustom semantic-default-c-path nil
+ "Default set of include paths for C code.
+ Used by `semantic-dep' to define an include path.
+ NOTE: In process of obsoleting this."
+ :group 'c
+ :group 'semantic
+ :type '(repeat (string :tag "Path")))
+
+ (defvar-mode-local c-mode semantic-dependency-include-path
+ semantic-default-c-path
+ "System path to search for include files.")
+
+ ;;; Compile Options
+ ;;
+ ;; Compiler options need to show up after path setup, but before
+ ;; the preprocessor section.
+
+ (when (member system-type '(gnu gnu/linux darwin cygwin))
+ (semantic-gcc-setup))
+
+ ;;; Pre-processor maps
+ ;;
+ ;;; Lexical analysis
+ (defvar semantic-lex-c-preprocessor-symbol-map-builtin
+ '( ("__THROW" . "")
+ ("__const" . "const")
+ ("__restrict" . "")
+ ("__declspec" . ((spp-arg-list ("foo") 1 . 2)))
+ ("__attribute__" . ((spp-arg-list ("foo") 1 . 2)))
+ )
+ "List of symbols to include by default.")
+
+ (defvar semantic-c-in-reset-preprocessor-table nil
+ "Non-nil while resetting the preprocessor symbol map.
+ Used to prevent a reset while trying to parse files that are
+ part of the preprocessor map.")
+
+ (defvar semantic-lex-c-preprocessor-symbol-file)
+ (defvar semantic-lex-c-preprocessor-symbol-map)
+
+ (defun semantic-c-reset-preprocessor-symbol-map ()
+ "Reset the C preprocessor symbol map based on all input variables."
+ (when (featurep 'semantic/bovine/c)
+ (let ((filemap nil)
+ )
+ (when (and (not semantic-c-in-reset-preprocessor-table)
+ (featurep 'semantic/db-mode)
+ (semanticdb-minor-mode-p))
+ (let ( ;; Don't use external parsers. We need the internal one.
+ (semanticdb-out-of-buffer-create-table-fcn nil)
+ ;; Don't recurse while parsing these files the first time.
+ (semantic-c-in-reset-preprocessor-table t)
+ )
+ (dolist (sf semantic-lex-c-preprocessor-symbol-file)
+ ;; Global map entries
+ (let* ((table (semanticdb-file-table-object sf t)))
+ (when table
+ (when (semanticdb-needs-refresh-p table)
+ (condition-case nil
+ ;; Call with FORCE, as the file is very likely to
+ ;; not be in a buffer.
+ (semanticdb-refresh-table table t)
+ (error (message "Error updating tables for %S"
+ (object-name table)))))
+ (setq filemap (append filemap (oref table lexical-table)))
+ )
+ ))))
+
+ (setq-mode-local c-mode
+ semantic-lex-spp-macro-symbol-obarray
+ (semantic-lex-make-spp-table
+ (append semantic-lex-c-preprocessor-symbol-map-builtin
+ semantic-lex-c-preprocessor-symbol-map
+ filemap))
+ )
+ )))
+
+ (defcustom semantic-lex-c-preprocessor-symbol-map nil
+ "Table of C Preprocessor keywords used by the Semantic C lexer.
+ Each entry is a cons cell like this:
+ ( \"KEYWORD\" . \"REPLACEMENT\" )
+ Where KEYWORD is the macro that gets replaced in the lexical phase,
+ and REPLACEMENT is a string that is inserted in it's place. Empty string
+ implies that the lexical analyzer will discard KEYWORD when it is encountered.
+
+ Alternately, it can be of the form:
+ ( \"KEYWORD\" ( LEXSYM1 \"str\" 1 1 ) ... ( LEXSYMN \"str\" 1 1 ) )
+ where LEXSYM is a symbol that would normally be produced by the
+ lexical analyzer, such as `symbol' or `string'. The string in the
+ second position is the text that makes up the replacement. This is
+ the way to have multiple lexical symbols in a replacement. Using the
+ first way to specify text like \"foo::bar\" would not work, because :
+ is a sepearate lexical symbol.
+
+ A quick way to see what you would need to insert is to place a
+ definition such as:
+
+ #define MYSYM foo::bar
+
+ into a C file, and do this:
+ \\[semantic-lex-spp-describe]
+
+ The output table will describe the symbols needed."
+ :group 'c
+ :type '(repeat (cons (string :tag "Keyword")
+ (sexp :tag "Replacement")))
+ :set (lambda (sym value)
+ (set-default sym value)
+ (condition-case nil
+ (semantic-c-reset-preprocessor-symbol-map)
+ (error nil))
+ )
+ )
+
+ (defcustom semantic-lex-c-preprocessor-symbol-file nil
+ "List of C/C++ files that contain preprocessor macros for the C lexer.
+ Each entry is a filename and each file is parsed, and those macros
+ are included in every C/C++ file parsed by semantic.
+ You can use this variable instead of `semantic-lex-c-preprocessor-symbol-map'
+ to store your global macros in a more natural way."
+ :group 'c
+ :type '(repeat (file :tag "File"))
+ :set (lambda (sym value)
+ (set-default sym value)
+ (condition-case nil
+ (semantic-c-reset-preprocessor-symbol-map)
+ (error nil))
+ )
+ )
+
+ (defcustom semantic-c-member-of-autocast 't
+ "Non-nil means classes with a '->' operator will cast to it's return type.
+
+ For Examples:
+
+ class Foo {
+ Bar *operator->();
+ }
+
+ Foo foo;
+
+ if `semantic-c-member-of-autocast' is non-nil :
+ foo->[here completion will list method of Bar]
+
+ if `semantic-c-member-of-autocast' is nil :
+ foo->[here completion will list method of Foo]"
+ :group 'c
+ :type 'boolean)
+
+ (define-lex-spp-macro-declaration-analyzer semantic-lex-cpp-define
+ "A #define of a symbol with some value.
+ Record the symbol in the semantic preprocessor.
+ Return the the defined symbol as a special spp lex token."
+ "^\\s-*#\\s-*define\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1
+ (goto-char (match-end 0))
+ (skip-chars-forward " \t")
+ (if (eolp)
+ nil
+ (let* ((name (buffer-substring-no-properties
+ (match-beginning 1) (match-end 1)))
+ (with-args (save-excursion
+ (goto-char (match-end 0))
+ (looking-at "(")))
+ (semantic-lex-spp-replacements-enabled nil)
+ ;; Temporarilly override the lexer to include
+ ;; special items needed inside a macro
+ (semantic-lex-analyzer #'semantic-cpp-lexer)
+ (raw-stream
+ (semantic-lex-spp-stream-for-macro (save-excursion
+ (semantic-c-end-of-macro)
+ (point))))
+ )
+
+ ;; Only do argument checking if the paren was immediatly after
+ ;; the macro name.
+ (if with-args
+ (semantic-lex-spp-first-token-arg-list (car raw-stream)))
+
+ ;; Magical spp variable for end point.
+ (setq semantic-lex-end-point (point))
+
+ ;; Handled nested macro streams.
+ (semantic-lex-spp-merge-streams raw-stream)
+ )))
+
+ (define-lex-spp-macro-undeclaration-analyzer semantic-lex-cpp-undef
+ "A #undef of a symbol.
+ Remove the symbol from the semantic preprocessor.
+ Return the the defined symbol as a special spp lex token."
+ "^\\s-*#\\s-*undef\\s-+\\(\\(\\sw\\|\\s_\\)+\\)" 1)
+
+ \f
+ ;;; Conditional Skipping
+ ;;
+ (defcustom semantic-c-obey-conditional-section-parsing-flag t
+ "*Non-nil means to interpret preprocessor #if sections.
+ This implies that some blocks of code will not be parsed based on the
+ values of the conditions in the #if blocks."
+ :group 'c
+ :type 'boolean)
+
+ (defun semantic-c-skip-conditional-section ()
+ "Skip one section of a conditional.
+ Moves forward to a matching #elif, #else, or #endif.
+ Moves completely over balanced #if blocks."
+ (require 'cc-cmds)
+ (let ((done nil))
+ ;; (if (looking-at "^\\s-*#if")
+ ;; (semantic-lex-spp-push-if (point))
+ (end-of-line)
+ (while (and semantic-c-obey-conditional-section-parsing-flag
+ (and (not done)
+ (re-search-forward
+ "^\\s-*#\\s-*\\(if\\(n?def\\)?\\|el\\(if\\|se\\)\\|endif\\)\\>"
+ nil t)))
+ (goto-char (match-beginning 0))
+ (cond
+ ((looking-at "^\\s-*#\\s-*if")
+ ;; We found a nested if. Skip it.
+ (c-forward-conditional 1))
+ ((looking-at "^\\s-*#\\s-*elif")
+ ;; We need to let the preprocessor analize this one.
+ (beginning-of-line)
+ (setq done t)
+ )
+ ((looking-at "^\\s-*#\\s-*\\(endif\\|else\\)\\>")
+ ;; We are at the end. Pop our state.
+ ;; (semantic-lex-spp-pop-if)
+ ;; Note: We include ELSE and ENDIF the same. If skip some previous
+ ;; section, then we should do the else by default, making it much
+ ;; like the endif.
+ (end-of-line)
+ (forward-char 1)
+ (setq done t))
+ (t
+ ;; We found an elif. Stop here.
+ (setq done t))))))
+
+ (define-lex-regex-analyzer semantic-lex-c-if
+ "Code blocks wrapped up in #if, or #ifdef.
+ Uses known macro tables in SPP to determine what block to skip."
+ "^\\s-*#\\s-*\\(if\\|ifndef\\|ifdef\\|elif\\)\\s-+\\(!?defined(\\|\\)\\s-*\\(\\(\\sw\\|\\s_\\)+\\)\\(\\s-*)\\)?\\s-*$"
+ (semantic-c-do-lex-if))
+
+ (defun semantic-c-do-lex-if ()
+ "Handle lexical CPP if statements."
+ (let* ((sym (buffer-substring-no-properties
+ (match-beginning 3) (match-end 3)))
+ (defstr (buffer-substring-no-properties
+ (match-beginning 2) (match-end 2)))
+ (defined (string= defstr "defined("))
+ (notdefined (string= defstr "!defined("))
+ (ift (buffer-substring-no-properties
+ (match-beginning 1) (match-end 1)))
+ (ifdef (or (string= ift "ifdef")
+ (and (string= ift "if") defined)
+ (and (string= ift "elif") defined)
+ ))
+ (ifndef (or (string= ift "ifndef")
+ (and (string= ift "if") notdefined)
+ (and (string= ift "elif") notdefined)
+ ))
+ )
+ (if (or (and (or (string= ift "if") (string= ift "elif"))
+ (string= sym "0"))
+ (and ifdef (not (semantic-lex-spp-symbol-p sym)))
+ (and ifndef (semantic-lex-spp-symbol-p sym)))
+ ;; The if indecates to skip this preprocessor section
+ (let ((pt nil))
+ ;; (message "%s %s yes" ift sym)
+ (beginning-of-line)
+ (setq pt (point))
+ ;;(c-forward-conditional 1)
+ ;; This skips only a section of a conditional. Once that section
+ ;; is opened, encountering any new #else or related conditional
+ ;; should be skipped.
+ (semantic-c-skip-conditional-section)
+ (setq semantic-lex-end-point (point))
+ (semantic-push-parser-warning (format "Skip #%s %s" ift sym)
+ pt (point))
+ ;; (semantic-lex-push-token
+ ;; (semantic-lex-token 'c-preprocessor-skip pt (point)))
+ nil)
+ ;; Else, don't ignore it, but do handle the internals.
+ ;;(message "%s %s no" ift sym)
+ (end-of-line)
+ (setq semantic-lex-end-point (point))
+ nil)))
+
+ (define-lex-regex-analyzer semantic-lex-c-macro-else
+ "Ignore an #else block.
+ We won't see the #else due to the macro skip section block
+ unless we are actively parsing an open #if statement. In that
+ case, we must skip it since it is the ELSE part."
+ "^\\s-*#\\s-*\\(else\\)"
+ (let ((pt (point)))
+ (semantic-c-skip-conditional-section)
+ (setq semantic-lex-end-point (point))
+ (semantic-push-parser-warning "Skip #else" pt (point))
+ ;; (semantic-lex-push-token
+ ;; (semantic-lex-token 'c-preprocessor-skip pt (point)))
+ nil))
+
+ (define-lex-regex-analyzer semantic-lex-c-macrobits
+ "Ignore various forms of #if/#else/#endif conditionals."
+ "^\\s-*#\\s-*\\(if\\(n?def\\)?\\|endif\\|elif\\|else\\)"
+ (semantic-c-end-of-macro)
+ (setq semantic-lex-end-point (point))
+ nil)
+
+ (define-lex-spp-include-analyzer semantic-lex-c-include-system
+ "Identify include strings, and return special tokens."
+ "^\\s-*#\\s-*include\\s-*<\\([^ \t\n>]+\\)>" 0
+ ;; Hit 1 is the name of the include.
+ (goto-char (match-end 0))
+ (setq semantic-lex-end-point (point))
+ (cons (buffer-substring-no-properties (match-beginning 1)
+ (match-end 1))
+ 'system))
+
+ (define-lex-spp-include-analyzer semantic-lex-c-include
+ "Identify include strings, and return special tokens."
+ "^\\s-*#\\s-*include\\s-*\"\\([^ \t\n>]+\\)\"" 0
+ ;; Hit 1 is the name of the include.
+ (goto-char (match-end 0))
+ (setq semantic-lex-end-point (point))
+ (cons (buffer-substring-no-properties (match-beginning 1)
+ (match-end 1))
+ nil))
+
+
+ (define-lex-regex-analyzer semantic-lex-c-ignore-ending-backslash
+ "Skip backslash ending a line.
+ Go to the next line."
+ "\\\\\\s-*\n"
+ (setq semantic-lex-end-point (match-end 0)))
+
+ (define-lex-regex-analyzer semantic-lex-c-namespace-begin-macro
+ "Handle G++'s namespace macros which the pre-processor can't handle."
+ "\\(_GLIBCXX_BEGIN_NAMESPACE\\)(\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*)"
+ (let* ((nsend (match-end 1))
+ (sym-start (match-beginning 2))
+ (sym-end (match-end 2))
+ (ms (buffer-substring-no-properties sym-start sym-end)))
+ ;; Push the namespace keyword.
+ (semantic-lex-push-token
+ (semantic-lex-token 'NAMESPACE (match-beginning 0) nsend "namespace"))
+ ;; Push the name.
+ (semantic-lex-push-token
+ (semantic-lex-token 'symbol sym-start sym-end ms))
+ )
+ (goto-char (match-end 0))
+ (let ((start (point))
+ (end 0))
+ ;; If we can't find a matching end, then create the fake list.
+ (when (re-search-forward "_GLIBCXX_END_NAMESPACE" nil t)
+ (setq end (point))
+ (semantic-lex-push-token
+ (semantic-lex-token 'semantic-list start end
+ (list 'prefix-fake)))))
+ (setq semantic-lex-end-point (point)))
+
+ (defcustom semantic-lex-c-nested-namespace-ignore-second t
+ "Should _GLIBCXX_BEGIN_NESTED_NAMESPACE ignore the second namespace?
+ It is really there, but if a majority of uses is to squeeze out
+ the second namespace in use, then it should not be included.
+
+ If you are having problems with smart completion and STL templates,
+ it may that this is set incorrectly. After changing the value
+ of this flag, you will need to delete any semanticdb cache files
+ that may have been incorrectly parsed."
+ :group 'semantic
+ :type 'boolean)
+
+ (define-lex-regex-analyzer semantic-lex-c-VC++-begin-std-namespace
+ "Handle VC++'s definition of the std namespace."
+ "\\(_STD_BEGIN\\)"
+ (semantic-lex-push-token
+ (semantic-lex-token 'NAMESPACE (match-beginning 0) (match-end 0) "namespace"))
+ (semantic-lex-push-token
+ (semantic-lex-token 'symbol (match-beginning 0) (match-end 0) "std"))
+ (goto-char (match-end 0))
+ (let ((start (point))
+ (end 0))
+ (when (re-search-forward "_STD_END" nil t)
+ (setq end (point))
+ (semantic-lex-push-token
+ (semantic-lex-token 'semantic-list start end
+ (list 'prefix-fake)))))
+ (setq semantic-lex-end-point (point)))
+
+ (define-lex-regex-analyzer semantic-lex-c-VC++-end-std-namespace
+ "Handle VC++'s definition of the std namespace."
+ "\\(_STD_END\\)"
+ (goto-char (match-end 0))
+ (setq semantic-lex-end-point (point)))
+
+ (define-lex-regex-analyzer semantic-lex-c-namespace-begin-nested-macro
+ "Handle G++'s namespace macros which the pre-processor can't handle."
+ "\\(_GLIBCXX_BEGIN_NESTED_NAMESPACE\\)(\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*,\\s-*\\(\\(?:\\w\\|\\s_\\)+\\)\\s-*)"
+ (goto-char (match-end 0))
+ (let* ((nsend (match-end 1))
+ (sym-start (match-beginning 2))
+ (sym-end (match-end 2))
+ (ms (buffer-substring-no-properties sym-start sym-end))
+ (sym2-start (match-beginning 3))
+ (sym2-end (match-end 3))
+ (ms2 (buffer-substring-no-properties sym2-start sym2-end)))
+ ;; Push the namespace keyword.
+ (semantic-lex-push-token
+ (semantic-lex-token 'NAMESPACE (match-beginning 0) nsend "namespace"))
+ ;; Push the name.
+ (semantic-lex-push-token
+ (semantic-lex-token 'symbol sym-start sym-end ms))
+
+ (goto-char (match-end 0))
+ (let ((start (point))
+ (end 0))
+ ;; If we can't find a matching end, then create the fake list.
+ (when (re-search-forward "_GLIBCXX_END_NESTED_NAMESPACE" nil t)
+ (setq end (point))
+ (if semantic-lex-c-nested-namespace-ignore-second
+ ;; The same as _GLIBCXX_BEGIN_NAMESPACE
+ (semantic-lex-push-token
+ (semantic-lex-token 'semantic-list start end
+ (list 'prefix-fake)))
+ ;; Do both the top and second level namespace
+ (semantic-lex-push-token
+ (semantic-lex-token 'semantic-list start end
+ ;; We'll depend on a quick hack
+ (list 'prefix-fake-plus
+ (semantic-lex-token 'NAMESPACE
+ sym-end sym2-start
+ "namespace")
+ (semantic-lex-token 'symbol
+ sym2-start sym2-end
+ ms2)
+ (semantic-lex-token 'semantic-list start end
+ (list 'prefix-fake)))
+ )))
+ )))
+ (setq semantic-lex-end-point (point)))
+
+ (define-lex-regex-analyzer semantic-lex-c-namespace-end-macro
+ "Handle G++'s namespace macros which the pre-processor can't handle."
+ "_GLIBCXX_END_\\(NESTED_\\)?NAMESPACE"
+ (goto-char (match-end 0))
+ (setq semantic-lex-end-point (point)))
+
+ (define-lex-regex-analyzer semantic-lex-c-string
+ "Detect and create a C string token."
+ "L?\\(\\s\"\\)"
+ ;; Zing to the end of this string.
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'string (point)
+ (save-excursion
+ ;; Skip L prefix if present.
+ (goto-char (match-beginning 1))
+ (semantic-lex-unterminated-syntax-protection 'string
+ (forward-sexp 1)
+ (point))
+ ))))
+
+ (define-lex-regex-analyzer semantic-c-lex-ignore-newline
+ "Detect and ignore newline tokens.
+ Use this ONLY if newlines are not whitespace characters (such as when
+ they are comment end characters)."
+ ;; Just like semantic-lex-ignore-newline, but also ignores
+ ;; trailing \.
+ "\\s-*\\\\?\\s-*\\(\n\\|\\s>\\)"
+ (setq semantic-lex-end-point (match-end 0)))
+
+
+ (define-lex semantic-c-lexer
+ "Lexical Analyzer for C code.
+ Use semantic-cpp-lexer for parsing text inside a CPP macro."
+ ;; C preprocessor features
+ semantic-lex-cpp-define
+ semantic-lex-cpp-undef
+ semantic-lex-c-if
+ semantic-lex-c-macro-else
+ semantic-lex-c-macrobits
+ semantic-lex-c-include
+ semantic-lex-c-include-system
+ semantic-lex-c-ignore-ending-backslash
+ ;; Whitespace handling
+ semantic-lex-ignore-whitespace
+ semantic-c-lex-ignore-newline
+ ;; Non-preprocessor features
+ semantic-lex-number
+ ;; Must detect C strings before symbols because of possible L prefix!
+ semantic-lex-c-string
+ ;; Custom handlers for some macros come before the macro replacement analyzer.
+ semantic-lex-c-namespace-begin-macro
+ semantic-lex-c-namespace-begin-nested-macro
+ semantic-lex-c-namespace-end-macro
+ semantic-lex-c-VC++-begin-std-namespace
+ semantic-lex-c-VC++-end-std-namespace
+ ;; Handle macros, symbols, and keywords
+ semantic-lex-spp-replace-or-symbol-or-keyword
+ semantic-lex-charquote
+ semantic-lex-paren-or-list
+ semantic-lex-close-paren
+ semantic-lex-ignore-comments
+ semantic-lex-punctuation
+ semantic-lex-default-action)
+
+ (define-lex-simple-regex-analyzer semantic-lex-cpp-hashhash
+ "Match ## inside a CPP macro as special."
+ "##" 'spp-concat)
+
+ (define-lex semantic-cpp-lexer
+ "Lexical Analyzer for CPP macros in C code."
+ ;; CPP special
+ semantic-lex-cpp-hashhash
+ ;; C preprocessor features
+ semantic-lex-cpp-define
+ semantic-lex-cpp-undef
+ semantic-lex-c-if
+ semantic-lex-c-macro-else
+ semantic-lex-c-macrobits
+ semantic-lex-c-include
+ semantic-lex-c-include-system
+ semantic-lex-c-ignore-ending-backslash
+ ;; Whitespace handling
+ semantic-lex-ignore-whitespace
+ semantic-c-lex-ignore-newline
+ ;; Non-preprocessor features
+ semantic-lex-number
+ ;; Must detect C strings before symbols because of possible L prefix!
+ semantic-lex-c-string
+ ;; Parsing inside a macro means that we don't do macro replacement.
+ ;; semantic-lex-spp-replace-or-symbol-or-keyword
+ semantic-lex-symbol-or-keyword
+ semantic-lex-charquote
+ semantic-lex-paren-or-list
+ semantic-lex-close-paren
+ semantic-lex-ignore-comments
+ semantic-lex-punctuation
+ semantic-lex-default-action)
+
+ (define-mode-local-override semantic-parse-region c-mode
+ (start end &optional nonterminal depth returnonerror)
+ "Calls 'semantic-parse-region-default', except in a macro expansion.
+ MACRO expansion mode is handled through the nature of Emacs's non-lexical
+ binding of variables.
+ START, END, NONTERMINAL, DEPTH, and RETURNONERRORS are the same
+ as for the parent."
+ (if (and (boundp 'lse) (or (/= start 1) (/= end (point-max))))
+ (let* ((last-lexical-token lse)
+ (llt-class (semantic-lex-token-class last-lexical-token))
+ (llt-fakebits (car (cdr last-lexical-token)))
+ (macroexpand (stringp (car (cdr last-lexical-token)))))
+ (if macroexpand
+ (progn
+ ;; It is a macro expansion. Do something special.
+ ;;(message "MOOSE %S %S, %S : %S" start end nonterminal lse)
+ (semantic-c-parse-lexical-token
+ lse nonterminal depth returnonerror)
+ )
+ ;; Not a macro expansion, but perhaps a funny semantic-list
+ ;; is at the start? Remove the depth if our semantic list is not
+ ;; made of list tokens.
+ (if (and depth (= depth 1)
+ (eq llt-class 'semantic-list)
+ (not (null llt-fakebits))
+ (consp llt-fakebits)
+ (symbolp (car llt-fakebits))
+ )
+ (progn
+ (setq depth 0)
+
+ ;; This is a copy of semantic-parse-region-default where we
+ ;; are doing something special with the lexication of the
+ ;; contents of the semantic-list token. Stuff not used by C
+ ;; removed.
+ (let ((tokstream
+ (if (and (consp llt-fakebits)
+ (eq (car llt-fakebits) 'prefix-fake-plus))
+ ;; If our semantic-list is special, then only stick in the
+ ;; fake tokens.
+ (cdr llt-fakebits)
+ ;; Lex up the region with a depth of 0
+ (semantic-lex start end 0))))
+
+ ;; Do the parse
+ (nreverse
+ (semantic-repeat-parse-whole-stream tokstream
+ nonterminal
+ returnonerror))
+
+ ))
+
+ ;; It was not a macro expansion, nor a special semantic-list.
+ ;; Do old thing.
+ (semantic-parse-region-default start end
+ nonterminal depth
+ returnonerror)
+ )))
+ ;; Do the parse
+ (semantic-parse-region-default start end nonterminal
+ depth returnonerror)
+ ))
+
+ (defvar semantic-c-parse-token-hack-depth 0
+ "Current depth of recursive calls to `semantic-c-parse-lexical-token'")
+
+ (defun semantic-c-parse-lexical-token (lexicaltoken nonterminal depth
+ returnonerror)
+ "Do a region parse on the contents of LEXICALTOKEN.
+ Presumably, this token has a string in it from a macro.
+ The text of the token is inserted into a different buffer, and
+ parsed there.
+ Argument NONTERMINAL, DEPTH, and RETURNONERROR are passed into
+ the regular parser."
+ (let* ((semantic-c-parse-token-hack-depth (1+ semantic-c-parse-token-hack-depth))
+ (buf (get-buffer-create (format " *C parse hack %d*"
+ semantic-c-parse-token-hack-depth)))
+ (mode major-mode)
+ (spp-syms semantic-lex-spp-dynamic-macro-symbol-obarray)
+ (stream nil)
+ (start (semantic-lex-token-start lexicaltoken))
+ (end (semantic-lex-token-end lexicaltoken))
+ (symtext (semantic-lex-token-text lexicaltoken))
+ (macros (get-text-property 0 'macros symtext))
+ )
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ (when (not (eq major-mode mode))
+ (save-match-data
+
+ ;; Protect against user hooks throwing errors.
+ (condition-case nil
+ (funcall mode)
+ (error nil))
+
+ ;; 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)
+ ))
+ ;; Get the macro symbol table right.
+ (setq semantic-lex-spp-dynamic-macro-symbol-obarray spp-syms)
+ ;; (message "%S" macros)
+ (dolist (sym macros)
+ (semantic-lex-spp-symbol-set (car sym) (cdr sym)))
+
+ (insert symtext)
+
+ (setq stream
+ (semantic-parse-region-default
+ (point-min) (point-max) nonterminal depth returnonerror))
+
+ ;; Clean up macro symbols
+ (dolist (sym macros)
+ (semantic-lex-spp-symbol-remove (car sym)))
+
+ ;; Convert the text of the stream.
+ (dolist (tag stream)
+ ;; Only do two levels here 'cause I'm lazy.
+ (semantic--tag-set-overlay tag (list start end))
+ (dolist (stag (semantic-tag-components-with-overlays tag))
+ (semantic--tag-set-overlay stag (list start end))
+ ))
+ )
+ stream))
+
+ (defun semantic-expand-c-tag (tag)
+ "Expand TAG into a list of equivalent tags, or nil."
+ (let ((return-list nil)
+ )
+ ;; Expand an EXTERN C first.
+ (when (eq (semantic-tag-class tag) 'extern)
+ (let* ((mb (semantic-tag-get-attribute tag :members))
+ (ret mb))
+ (while mb
+ (let ((mods (semantic-tag-get-attribute (car mb) :typemodifiers)))
+ (setq mods (cons "extern" (cons "\"C\"" mods)))
+ (semantic-tag-put-attribute (car mb) :typemodifiers mods))
+ (setq mb (cdr mb)))
+ (setq return-list ret)))
+
+ ;; Function or variables that have a :type that is some complex
+ ;; thing, extract it, and replace it with a reference.
+ ;;
+ ;; Thus, struct A { int a; } B;
+ ;;
+ ;; will create 2 toplevel tags, one is type A, and the other variable B
+ ;; where the :type of B is just a type tag A that is a prototype, and
+ ;; the actual struct info of A is it's own toplevel tag.
+ (when (or (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-of-class-p tag 'variable))
+ (let* ((basetype (semantic-tag-type tag))
+ (typeref nil)
+ (tname (when (consp basetype)
+ (semantic-tag-name basetype))))
+ ;; Make tname be a string.
+ (when (consp tname) (setq tname (car (car tname))))
+ ;; Is the basetype a full type with a name of its own?
+ (when (and basetype (semantic-tag-p basetype)
+ (not (semantic-tag-prototype-p basetype))
+ tname
+ (not (string= tname "")))
+ ;; a type tag referencing the type we are extracting.
+ (setq typeref (semantic-tag-new-type
+ (semantic-tag-name basetype)
+ (semantic-tag-type basetype)
+ nil nil
+ :prototype t))
+ ;; Convert original tag to only have a reference.
+ (setq tag (semantic-tag-copy tag))
+ (semantic-tag-put-attribute tag :type typeref)
+ ;; Convert basetype to have the location information.
+ (semantic--tag-copy-properties tag basetype)
+ (semantic--tag-set-overlay basetype
+ (semantic-tag-overlay tag))
+ ;; Store the base tag as part of the return list.
+ (setq return-list (cons basetype return-list)))))
+
+ ;; Name of the tag is a list, so expand it. Tag lists occur
+ ;; for variables like this: int var1, var2, var3;
+ ;;
+ ;; This will expand that to 3 tags that happen to share the
+ ;; same overlay information.
+ (if (consp (semantic-tag-name tag))
+ (let ((rl (semantic-expand-c-tag-namelist tag)))
+ (cond
+ ;; If this returns nothing, then return nil overall
+ ;; because that will restore the old TAG input.
+ ((not rl) (setq return-list nil))
+ ;; If we have a return, append it to the existing list
+ ;; of returns.
+ ((consp rl)
+ (setq return-list (append rl return-list)))
+ ))
+ ;; If we didn't have a list, but the return-list is non-empty,
+ ;; that means we still need to take our existing tag, and glom
+ ;; it onto our extracted type.
+ (if (consp return-list)
+ (setq return-list (cons tag return-list)))
+ )
+
+ ;; Default, don't change the tag means returning nil.
+ return-list))
+
+ (defun semantic-expand-c-tag-namelist (tag)
+ "Expand TAG whose name is a list into a list of tags, or nil."
+ (cond ((semantic-tag-of-class-p tag 'variable)
+ ;; The name part comes back in the form of:
+ ;; ( NAME NUMSTARS BITS ARRAY ASSIGN )
+ (let ((vl nil)
+ (basety (semantic-tag-type tag))
+ (ty "")
+ (mods (semantic-tag-get-attribute tag :typemodifiers))
+ (suffix "")
+ (lst (semantic-tag-name tag))
+ (default nil)
+ (cur nil))
+ ;; Open up each name in the name list.
+ (while lst
+ (setq suffix "" ty "")
+ (setq cur (car lst))
+ (if (nth 2 cur)
+ (setq suffix (concat ":" (nth 2 cur))))
+ (if (= (length basety) 1)
+ (setq ty (car basety))
+ (setq ty basety))
+ (setq default (nth 4 cur))
+ (setq vl (cons
+ (semantic-tag-new-variable
+ (car cur) ;name
+ ty ;type
+ (if default
+ (buffer-substring-no-properties
+ (car default) (car (cdr default))))
+ :constant-flag (semantic-tag-variable-constant-p tag)
+ :suffix suffix
+ :typemodifiers mods
+ :dereference (length (nth 3 cur))
+ :pointer (nth 1 cur)
+ :reference (semantic-tag-get-attribute tag :reference)
+ :documentation (semantic-tag-docstring tag) ;doc
+ )
+ vl))
+ (semantic--tag-copy-properties tag (car vl))
+ (semantic--tag-set-overlay (car vl)
+ (semantic-tag-overlay tag))
+ (setq lst (cdr lst)))
+ ;; Return the list
+ (nreverse vl)))
+ ((semantic-tag-of-class-p tag 'type)
+ ;; We may someday want to add an extra check for a type
+ ;; of type "typedef".
+ ;; Each elt of NAME is ( STARS NAME )
+ (let ((vl nil)
+ (names (semantic-tag-name tag)))
+ (while names
+ (setq vl (cons (semantic-tag-new-type
+ (nth 1 (car names)) ; name
+ "typedef"
+ (semantic-tag-type-members tag)
+ ;; parent is just tbe name of what
+ ;; is passed down as a tag.
+ (list
+ (semantic-tag-name
+ (semantic-tag-type-superclasses tag)))
+ :pointer
+ (let ((stars (car (car (car names)))))
+ (if (= stars 0) nil stars))
+ ;; This specifies what the typedef
+ ;; is expanded out as. Just the
+ ;; name shows up as a parent of this
+ ;; typedef.
+ :typedef
+ (semantic-tag-get-attribute tag :superclasses)
+ ;;(semantic-tag-type-superclasses tag)
+ :documentation
+ (semantic-tag-docstring tag))
+ vl))
+ (semantic--tag-copy-properties tag (car vl))
+ (semantic--tag-set-overlay (car vl)
+ (semantic-tag-overlay tag))
+ (setq names (cdr names)))
+ vl))
+ ((and (listp (car tag))
+ (semantic-tag-of-class-p (car tag) 'variable))
+ ;; Argument lists come in this way. Append all the expansions!
+ (let ((vl nil))
+ (while tag
+ (setq vl (append (semantic-tag-components (car vl))
+ vl)
+ tag (cdr tag)))
+ vl))
+ (t nil)))
+
+ (defvar-mode-local c-mode semantic-tag-expand-function 'semantic-expand-c-tag
+ "Function used to expand tags generated in the C bovine parser.")
+
+ (defvar semantic-c-classname nil
+ "At parse time, assign a class or struct name text here.
+ It is picked up by `semantic-c-reconstitute-token' to determine
+ if something is a constructor. Value should be:
+ ( TYPENAME . TYPEOFTYPE)
+ where typename is the name of the type, and typeoftype is \"class\"
+ or \"struct\".")
+
+ (defun semantic-c-reconstitute-token (tokenpart declmods typedecl)
+ "Reconstitute a token TOKENPART with DECLMODS and TYPEDECL.
+ This is so we don't have to match the same starting text several times.
+ Optional argument STAR and REF indicate the number of * and & in the typedef."
+ (when (and (listp typedecl)
+ (= 1 (length typedecl))
+ (stringp (car typedecl)))
+ (setq typedecl (car typedecl)))
+ (cond ((eq (nth 1 tokenpart) 'variable)
+ (semantic-tag-new-variable
+ (car tokenpart)
+ (or typedecl "int") ;type
+ nil ;default value (filled with expand)
+ :constant-flag (if (member "const" declmods) t nil)
+ :typemodifiers (delete "const" declmods)
+ )
+ )
+ ((eq (nth 1 tokenpart) 'function)
+ ;; We should look at part 4 (the arglist) here, and throw an
+ ;; error of some sort if it contains parser errors so that we
+ ;; don't parser function calls, but that is a little beyond what
+ ;; is available for data here.
+ (let* ((constructor
+ (and (or (and semantic-c-classname
+ (string= (car semantic-c-classname)
+ (car tokenpart)))
+ (and (stringp (car (nth 2 tokenpart)))
+ (string= (car (nth 2 tokenpart)) (car tokenpart)))
+ )
+ (not (car (nth 3 tokenpart)))))
+ (fcnpointer (string-match "^\\*" (car tokenpart)))
+ (fnname (if fcnpointer
+ (substring (car tokenpart) 1)
+ (car tokenpart)))
+ (operator (if (string-match "[a-zA-Z]" fnname)
+ nil
+ t))
+ )
+ (if fcnpointer
+ ;; Function pointers are really variables.
+ (semantic-tag-new-variable
+ fnname
+ typedecl
+ nil
+ ;; It is a function pointer
+ :functionpointer-flag t
+ )
+ ;; The function
+ (semantic-tag-new-function
+ fnname
+ (or typedecl ;type
+ (cond ((car (nth 3 tokenpart) )
+ "void") ; Destructors have no return?
+ (constructor
+ ;; Constructors return an object.
+ (semantic-tag-new-type
+ ;; name
+ (or (car semantic-c-classname)
+ (car (nth 2 tokenpart)))
+ ;; type
+ (or (cdr semantic-c-classname)
+ "class")
+ ;; members
+ nil
+ ;; parents
+ nil
+ ))
+ (t "int")))
+ (nth 4 tokenpart) ;arglist
+ :constant-flag (if (member "const" declmods) t nil)
+ :typemodifiers (delete "const" declmods)
+ :parent (car (nth 2 tokenpart))
+ :destructor-flag (if (car (nth 3 tokenpart) ) t)
+ :constructor-flag (if constructor t)
+ :pointer (nth 7 tokenpart)
+ :operator-flag operator
+ ;; Even though it is "throw" in C++, we use
+ ;; `throws' as a common name for things that toss
+ ;; exceptions about.
+ :throws (nth 5 tokenpart)
+ ;; Reemtrant is a C++ thingy. Add it here
+ :reentrant-flag (if (member "reentrant" (nth 6 tokenpart)) t)
+ ;; A function post-const is funky. Try stuff
+ :methodconst-flag (if (member "const" (nth 6 tokenpart)) t)
+ ;; prototypes are functions w/ no body
+ :prototype-flag (if (nth 8 tokenpart) t)
+ ;; Pure virtual
+ :pure-virtual-flag (if (eq (nth 8 tokenpart) :pure-virtual-flag) t)
+ ;; Template specifier.
+ :template-specifier (nth 9 tokenpart)
+ )))
+ )
+ ))
+
+ (defun semantic-c-reconstitute-template (tag specifier)
+ "Reconstitute the token TAG with the template SPECIFIER."
+ (semantic-tag-put-attribute tag :template (or specifier ""))
+ tag)
+
+ \f
+ ;;; Override methods & Variables
+ ;;
+ (define-mode-local-override semantic-format-tag-name
+ c-mode (tag &optional parent color)
+ "Convert TAG to a string that is the print name for TAG.
+ Optional PARENT and COLOR are ignored."
+ (let ((name (semantic-format-tag-name-default tag parent color))
+ (fnptr (semantic-tag-get-attribute tag :functionpointer-flag))
+ )
+ (if (not fnptr)
+ name
+ (concat "(*" name ")"))
+ ))
+
+ (define-mode-local-override semantic-format-tag-canonical-name
+ c-mode (tag &optional parent color)
+ "Create a cannonical name for TAG.
+ PARENT specifies a parent class.
+ COLOR indicates that the text should be type colorized.
+ Enhances the base class to search for the entire parent
+ tree to make the name accurate."
+ (semantic-format-tag-canonical-name-default tag parent color)
+ )
+
+ (define-mode-local-override semantic-format-tag-type c-mode (tag color)
+ "Convert the data type of TAG to a string usable in tag formatting.
+ Adds pointer and reference symbols to the default.
+ Argument COLOR adds color to the text."
+ (let* ((type (semantic-tag-type tag))
+ (defaulttype nil)
+ (point (semantic-tag-get-attribute tag :pointer))
+ (ref (semantic-tag-get-attribute tag :reference))
+ )
+ (if (semantic-tag-p type)
+ (let ((typetype (semantic-tag-type type))
+ (typename (semantic-tag-name type)))
+ ;; Create the string that expresses the type
+ (if (string= typetype "class")
+ (setq defaulttype typename)
+ (setq defaulttype (concat typetype " " typename))))
+ (setq defaulttype (semantic-format-tag-type-default tag color)))
+
+ ;; Colorize
+ (when color
+ (setq defaulttype (semantic--format-colorize-text defaulttype 'type)))
+
+ ;; Add refs, ptrs, etc
+ (if ref (setq ref "&"))
+ (if point (setq point (make-string point ?*)) "")
+ (when type
+ (concat defaulttype ref point))
+ ))
+
+ (define-mode-local-override semantic-find-tags-by-scope-protection
+ c-mode (scopeprotection parent &optional table)
+ "Override the usual search for protection.
+ We can be more effective than the default by scanning through once,
+ and collecting tags based on the labels we see along the way."
+ (if (not table) (setq table (semantic-tag-type-members parent)))
+ (if (null scopeprotection)
+ table
+ (let ((ans nil)
+ (curprot 1)
+ (targetprot (cond ((eq scopeprotection 'public)
+ 1)
+ ((eq scopeprotection 'protected)
+ 2)
+ (t 3)
+ ))
+ (alist '(("public" . 1)
+ ("protected" . 2)
+ ("private" . 3)))
+ )
+ (dolist (tag table)
+ (cond
+ ((semantic-tag-of-class-p tag 'label)
+ (setq curprot (cdr (assoc (semantic-tag-name tag) alist)))
+ )
+ ((>= targetprot curprot)
+ (setq ans (cons tag ans)))
+ ))
+ ans)))
+
+ (define-mode-local-override semantic-tag-protection
+ c-mode (tag &optional parent)
+ "Return the protection of TAG in PARENT.
+ Override function for `semantic-tag-protection'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (prot nil))
+ ;; Check the modifiers for protection if we are not a child
+ ;; of some class type.
+ (when (or (not parent) (not (eq (semantic-tag-class parent) 'type)))
+ (while (and (not prot) mods)
+ (if (stringp (car mods))
+ (let ((s (car mods)))
+ ;; A few silly defaults to get things started.
+ (cond ((or (string= s "extern")
+ (string= s "export"))
+ 'public)
+ ((string= s "static")
+ 'private))))
+ (setq mods (cdr mods))))
+ ;; If we have a typed parent, look for :public style labels.
+ (when (and parent (eq (semantic-tag-class parent) 'type))
+ (let ((pp (semantic-tag-type-members parent)))
+ (while (and pp (not (semantic-equivalent-tag-p (car pp) tag)))
+ (when (eq (semantic-tag-class (car pp)) 'label)
+ (setq prot
+ (cond ((string= (semantic-tag-name (car pp)) "public")
+ 'public)
+ ((string= (semantic-tag-name (car pp)) "private")
+ 'private)
+ ((string= (semantic-tag-name (car pp)) "protected")
+ 'protected)))
+ )
+ (setq pp (cdr pp)))))
+ (when (and (not prot) (eq (semantic-tag-class parent) 'type))
+ (setq prot
+ (cond ((string= (semantic-tag-type parent) "class") 'private)
+ ((string= (semantic-tag-type parent) "struct") 'public)
+ (t 'unknown))))
+ (or prot
+ (if (and parent (semantic-tag-of-class-p parent 'type))
+ 'public
+ nil))))
+
+ (define-mode-local-override semantic-tag-components c-mode (tag)
+ "Return components for TAG."
+ (if (and (eq (semantic-tag-class tag) 'type)
+ (string= (semantic-tag-type tag) "typedef"))
+ ;; A typedef can contain a parent who has positional children,
+ ;; but that parent will not have a position. Do this funny hack
+ ;; to make sure we can apply overlays properly.
+ (let ((sc (semantic-tag-get-attribute tag :typedef)))
+ (when (semantic-tag-p sc) (semantic-tag-components sc)))
+ (semantic-tag-components-default tag)))
+
+ (defun semantic-c-tag-template (tag)
+ "Return the template specification for TAG, or nil."
+ (semantic-tag-get-attribute tag :template))
+
+ (defun semantic-c-tag-template-specifier (tag)
+ "Return the template specifier specification for TAG, or nil."
+ (semantic-tag-get-attribute tag :template-specifier))
+
+ (defun semantic-c-template-string-body (templatespec)
+ "Convert TEMPLATESPEC into a string.
+ This might be a string, or a list of tokens."
+ (cond ((stringp templatespec)
+ templatespec)
+ ((semantic-tag-p templatespec)
+ (semantic-format-tag-abbreviate templatespec))
+ ((listp templatespec)
+ (mapconcat 'semantic-format-tag-abbreviate templatespec ", "))))
+
+ (defun semantic-c-template-string (token &optional parent color)
+ "Return a string representing the TEMPLATE attribute of TOKEN.
+ This string is prefixed with a space, or is the empty string.
+ Argument PARENT specifies a parent type.
+ Argument COLOR specifies that the string should be colorized."
+ (let ((t2 (semantic-c-tag-template-specifier token))
+ (t1 (semantic-c-tag-template token))
+ ;; @todo - Need to account for a parent that is a template
+ (pt1 (if parent (semantic-c-tag-template parent)))
+ (pt2 (if parent (semantic-c-tag-template-specifier parent)))
+ )
+ (cond (t2 ;; we have a template with specifier
+ (concat " <"
+ ;; Fill in the parts here
+ (semantic-c-template-string-body t2)
+ ">"))
+ (t1 ;; we have a template without specifier
+ " <>")
+ (t
+ ""))))
+
+ (define-mode-local-override semantic-format-tag-concise-prototype
+ c-mode (token &optional parent color)
+ "Return an abbreviated string describing TOKEN for C and C++.
+ Optional PARENT and COLOR as specified with
+ `semantic-format-tag-abbreviate-default'."
+ ;; If we have special template things, append.
+ (concat (semantic-format-tag-concise-prototype-default token parent color)
+ (semantic-c-template-string token parent color)))
+
+ (define-mode-local-override semantic-format-tag-uml-prototype
+ c-mode (token &optional parent color)
+ "Return an uml string describing TOKEN for C and C++.
+ Optional PARENT and COLOR as specified with
+ `semantic-abbreviate-tag-default'."
+ ;; If we have special template things, append.
+ (concat (semantic-format-tag-uml-prototype-default token parent color)
+ (semantic-c-template-string token parent color)))
+
+ (define-mode-local-override semantic-tag-abstract-p
+ c-mode (tag &optional parent)
+ "Return non-nil if TAG is considered abstract.
+ PARENT is tag's parent.
+ In C, a method is abstract if it is `virtual', which is already
+ handled. A class is abstract iff it's destructor is virtual."
+ (cond
+ ((eq (semantic-tag-class tag) 'type)
+ (require 'semantic/find)
+ (or (semantic-brute-find-tag-by-attribute :pure-virtual-flag
+ (semantic-tag-components tag)
+ )
+ (let* ((ds (semantic-brute-find-tag-by-attribute
+ :destructor-flag
+ (semantic-tag-components tag)
+ ))
+ (cs (semantic-brute-find-tag-by-attribute
+ :constructor-flag
+ (semantic-tag-components tag)
+ )))
+ (and ds (member "virtual" (semantic-tag-modifiers (car ds)))
+ cs (eq 'protected (semantic-tag-protection (car cs) tag))
+ )
+ )))
+ ((eq (semantic-tag-class tag) 'function)
+ (or (semantic-tag-get-attribute tag :pure-virtual-flag)
+ (member "virtual" (semantic-tag-modifiers tag))))
+ (t (semantic-tag-abstract-p-default tag parent))))
+
+ (defun semantic-c-dereference-typedef (type scope &optional type-declaration)
+ "If TYPE is a typedef, get TYPE's type by name or tag, and return.
+ SCOPE is not used, and TYPE-DECLARATION is used only if TYPE is not a typedef."
+ (if (and (eq (semantic-tag-class type) 'type)
+ (string= (semantic-tag-type type) "typedef"))
+ (let ((dt (semantic-tag-get-attribute type :typedef)))
+ (cond ((and (semantic-tag-p dt)
+ (not (semantic-analyze-tag-prototype-p dt)))
+ ;; In this case, DT was declared directly. We need
+ ;; to clone DT and apply a filename to it.
+ (let* ((fname (semantic-tag-file-name type))
+ (def (semantic-tag-copy dt nil fname)))
+ (list def def)))
+ ((stringp dt) (list dt (semantic-tag dt 'type)))
+ ((consp dt) (list (car dt) dt))))
+
+ (list type type-declaration)))
+
+ (defun semantic-c--instantiate-template (tag def-list spec-list)
+ "Replace TAG name according to template specification.
+ DEF-LIST is the template information.
+ SPEC-LIST is the template specifier of the datatype instantiated."
+ (when (and (car def-list) (car spec-list))
+
+ (when (and (string= (semantic-tag-type (car def-list)) "class")
+ (string= (semantic-tag-name tag) (semantic-tag-name (car def-list))))
+ (semantic-tag-set-name tag (semantic-tag-name (car spec-list))))
+
+ (semantic-c--instantiate-template tag (cdr def-list) (cdr spec-list))))
+
+ (defun semantic-c--template-name-1 (spec-list)
+ "return a string used to compute template class name based on SPEC-LIST
+ for ref<Foo,Bar> it will return 'Foo,Bar'."
+ (when (car spec-list)
+ (let* ((endpart (semantic-c--template-name-1 (cdr spec-list)))
+ (separator (and endpart ",")))
+ (concat (semantic-tag-name (car spec-list)) separator endpart))))
+
+ (defun semantic-c--template-name (type spec-list)
+ "Return a template class name for TYPE based on SPEC-LIST.
+ For a type `ref' with a template specifier of (Foo Bar) it will
+ return 'ref<Foo,Bar>'."
+ (concat (semantic-tag-name type)
+ "<" (semantic-c--template-name-1 (cdr spec-list)) ">"))
+
+ (defun semantic-c-dereference-template (type scope &optional type-declaration)
+ "Dereference any template specifieres in TYPE within SCOPE.
+ If TYPE is a template, return a TYPE copy with the templates types
+ instantiated as specified in TYPE-DECLARATION."
+ (when (semantic-tag-p type-declaration)
+ (let ((def-list (semantic-tag-get-attribute type :template))
+ (spec-list (semantic-tag-get-attribute type-declaration :template-specifier)))
+ (when (and def-list spec-list)
+ (setq type (semantic-tag-deep-copy-one-tag
+ type
+ (lambda (tag)
+ (when (semantic-tag-of-class-p tag 'type)
+ (semantic-c--instantiate-template
+ tag def-list spec-list))
+ tag)
+ ))
+ (semantic-tag-set-name type (semantic-c--template-name type spec-list))
+ (semantic-tag-put-attribute type :template nil)
+ (semantic-tag-set-faux type))))
+ (list type type-declaration))
+
+ ;;; Patch here by "Raf" for instantiating templates.
+ (defun semantic-c-dereference-member-of (type scope &optional type-declaration)
+ "Dereference through the `->' operator of TYPE.
+ Uses the return type of the '->' operator if it is contained in TYPE.
+ SCOPE is the current local scope to perform searches in.
+ TYPE-DECLARATION is passed through."
+ (if semantic-c-member-of-autocast
+ (let ((operator (car (semantic-find-tags-by-name "->" (semantic-analyze-scoped-type-parts type)))))
+ (if operator
+ (list (semantic-tag-get-attribute operator :type) (semantic-tag-get-attribute operator :type))
+ (list type type-declaration)))
+ (list type type-declaration)))
+
+ ;; David Engster: The following three functions deal with namespace
+ ;; aliases and types which are member of a namespace through a using
+ ;; statement. For examples, see the file semantic/tests/testusing.cpp,
+ ;; tests 5 and following.
+
+ (defun semantic-c-dereference-namespace (type scope &optional type-declaration)
+ "Dereference namespace which might hold an 'alias' for TYPE.
+ Such an alias can be created through 'using' statements in a
+ namespace declaration. This function checks the namespaces in
+ SCOPE for such statements."
+ (let ((scopetypes (oref scope scopetypes))
+ typename currentns tmp usingname result namespaces)
+ (when (and (semantic-tag-p type-declaration)
+ (or (null type) (semantic-tag-prototype-p type)))
+ (setq typename (semantic-analyze-split-name (semantic-tag-name type-declaration)))
+ ;; If we already have that TYPE in SCOPE, we do nothing
+ (unless (semantic-deep-find-tags-by-name (or (car-safe typename) typename) scopetypes)
+ (if (stringp typename)
+ ;; The type isn't fully qualified, so we have to search in all namespaces in SCOPE.
+ (setq namespaces (semantic-find-tags-by-type "namespace" scopetypes))
+ ;; This is a fully qualified name, so we only have to search one namespace.
+ (setq namespaces (semanticdb-typecache-find (car typename)))
+ ;; Make sure it's really a namespace.
+ (if (string= (semantic-tag-type namespaces) "namespace")
+ (setq namespaces (list namespaces))
+ (setq namespaces nil)))
+ (setq result nil)
+ ;; Iterate over all the namespaces we have to check.
+ (while (and namespaces
+ (null result))
+ (setq currentns (car namespaces))
+ ;; Check if this is namespace is an alias and dereference it if necessary.
+ (setq result (semantic-c-dereference-namespace-alias type-declaration currentns))
+ (unless result
+ ;; Otherwise, check if we can reach the type through 'using' statements.
+ (setq result
+ (semantic-c-check-type-namespace-using type-declaration currentns)))
+ (setq namespaces (cdr namespaces)))))
+ (if result
+ ;; we have found the original type
+ (list result result)
+ (list type type-declaration))))
+
+ (defun semantic-c-dereference-namespace-alias (type namespace)
+ "Dereference TYPE in NAMESPACE, given that NAMESPACE is an alias.
+ Checks if NAMESPACE is an alias and if so, returns a new type
+ with a fully qualified name in the original namespace. Returns
+ nil if NAMESPACE is not an alias."
+ (when (eq (semantic-tag-get-attribute namespace :kind) 'alias)
+ (let ((typename (semantic-analyze-split-name (semantic-tag-name type)))
+ ns nstype originaltype newtype)
+ ;; Make typename unqualified
+ (if (listp typename)
+ (setq typename (last typename))
+ (setq typename (list typename)))
+ (when
+ (and
+ ;; Get original namespace and make sure TYPE exists there.
+ (setq ns (semantic-tag-name
+ (car (semantic-tag-get-attribute namespace :members))))
+ (setq nstype (semanticdb-typecache-find ns))
+ (setq originaltype (semantic-find-tags-by-name
+ (car typename)
+ (semantic-tag-get-attribute nstype :members))))
+ ;; Construct new type with name in original namespace.
+ (setq ns (semantic-analyze-split-name ns))
+ (setq newtype
+ (semantic-tag-clone
+ (car originaltype)
+ (semantic-analyze-unsplit-name
+ (if (listp ns)
+ (append ns typename)
+ (append (list ns) typename)))))))))
+
+ ;; This searches a type in a namespace, following through all using
+ ;; statements.
+ (defun semantic-c-check-type-namespace-using (type namespace)
+ "Check if TYPE is accessible in NAMESPACE through a using statement.
+ Returns the original type from the namespace where it is defined,
+ or nil if it cannot be found."
+ (let (usings result usingname usingtype unqualifiedname members shortname tmp)
+ ;; Get all using statements from NAMESPACE.
+ (when (and (setq usings (semantic-tag-get-attribute namespace :members))
+ (setq usings (semantic-find-tags-by-class 'using usings)))
+ ;; Get unqualified typename.
+ (when (listp (setq unqualifiedname (semantic-analyze-split-name
+ (semantic-tag-name type))))
+ (setq unqualifiedname (car (last unqualifiedname))))
+ ;; Iterate over all using statements in NAMESPACE.
+ (while (and usings
+ (null result))
+ (setq usingname (semantic-analyze-split-name
+ (semantic-tag-name (car usings)))
+ usingtype (semantic-tag-type (semantic-tag-type (car usings))))
+ (cond
+ ((or (string= usingtype "namespace")
+ (stringp usingname))
+ ;; We are dealing with a 'using [namespace] NAMESPACE;'
+ ;; Search for TYPE in that namespace
+ (setq result
+ (semanticdb-typecache-find usingname))
+ (if (and result
+ (setq members (semantic-tag-get-attribute result :members))
+ (setq members (semantic-find-tags-by-name unqualifiedname members)))
+ ;; TYPE is member of that namespace, so we are finished
+ (setq result (car members))
+ ;; otherwise recursively search in that namespace for an alias
+ (setq result (semantic-c-check-type-namespace-using type result))
+ (when result
+ (setq result (semantic-tag-type result)))))
+ ((and (string= usingtype "class")
+ (listp usingname))
+ ;; We are dealing with a 'using TYPE;'
+ (when (string= unqualifiedname (car (last usingname)))
+ ;; We have found the correct tag.
+ (setq result (semantic-tag-type (car usings))))))
+ (setq usings (cdr usings))))
+ result))
+
+
+ (define-mode-local-override semantic-analyze-dereference-metatype
+ c-mode (type scope &optional type-declaration)
+ "Dereference TYPE as described in `semantic-analyze-dereference-metatype'.
+ Handle typedef, template instantiation, and '->' operator."
+ (let* ((dereferencer-list '(semantic-c-dereference-typedef
+ semantic-c-dereference-template
+ semantic-c-dereference-member-of
+ semantic-c-dereference-namespace))
+ (dereferencer (pop dereferencer-list))
+ (type-tuple)
+ (original-type type))
+ (while dereferencer
+ (setq type-tuple (funcall dereferencer type scope type-declaration)
+ type (car type-tuple)
+ type-declaration (cadr type-tuple))
+ (if (not (eq type original-type))
+ ;; we found a new type so break the dereferencer loop now !
+ ;; (we will be recalled with the new type expanded by
+ ;; semantic-analyze-dereference-metatype-stack).
+ (setq dereferencer nil)
+ ;; no new type found try the next dereferencer :
+ (setq dereferencer (pop dereferencer-list)))))
+ (list type type-declaration))
+
+ (define-mode-local-override semantic-analyze-type-constants c-mode (type)
+ "When TYPE is a tag for an enum, return it's parts.
+ These are constants which are of type TYPE."
+ (if (and (eq (semantic-tag-class type) 'type)
+ (string= (semantic-tag-type type) "enum"))
+ (semantic-tag-type-members type)))
+
+ (define-mode-local-override semantic-analyze-split-name c-mode (name)
+ "Split up tag names on colon (:) boundaries."
+ (let ((ans (split-string name ":")))
+ (if (= (length ans) 1)
+ name
+ (delete "" ans))))
+
+ (define-mode-local-override semantic-analyze-unsplit-name c-mode (namelist)
+ "Assemble the list of names NAMELIST into a namespace name."
+ (mapconcat 'identity namelist "::"))
+
+ (define-mode-local-override semantic-ctxt-scoped-types c++-mode (&optional point)
+ "Return a list of tags of CLASS type based on POINT.
+ DO NOT return the list of tags encompassing point."
+ (when point (goto-char (point)))
+ (let ((tagsaroundpoint (semantic-find-tag-by-overlay))
+ (tagreturn nil)
+ (tmp nil))
+ ;; In C++, we want to find all the namespaces declared
+ ;; locally and add them to the list.
+ (setq tmp (semantic-find-tags-by-class 'type (current-buffer)))
+ (setq tmp (semantic-find-tags-by-type "namespace" tmp))
+ (setq tmp (semantic-find-tags-by-name "unnamed" tmp))
+ (setq tagreturn tmp)
+ ;; We should also find all "using" type statements and
+ ;; accept those entities in as well.
+ (setq tmp (semanticdb-find-tags-by-class 'using))
+ (let ((idx 0)
+ (len (semanticdb-find-result-length tmp)))
+ (while (< idx len)
+ (setq tagreturn (cons (semantic-tag-type (car (semanticdb-find-result-nth tmp idx))) tagreturn))
+ (setq idx (1+ idx)))
+ )
+ ;; Use the encompased types around point to also look for using statements.
+ ;;(setq tagreturn (cons "bread_name" tagreturn))
+ (while (cdr tagsaroundpoint) ; don't search the last one
+ (setq tmp (semantic-find-tags-by-class 'using (semantic-tag-components (car tagsaroundpoint))))
+ (dolist (T tmp)
+ (setq tagreturn (cons (semantic-tag-type T) tagreturn))
+ )
+ (setq tagsaroundpoint (cdr tagsaroundpoint))
+ )
+ ;; If in a function...
+ (when (and (semantic-tag-of-class-p (car tagsaroundpoint) 'function)
+ ;; ...search for using statements in the local scope...
+ (setq tmp (semantic-find-tags-by-class
+ 'using
+ (semantic-get-local-variables))))
+ ;; ... and add them.
+ (setq tagreturn
+ (append tagreturn
+ (mapcar 'semantic-tag-type tmp))))
+ ;; Return the stuff
+ tagreturn
+ ))
+
+ (define-mode-local-override semantic-get-local-variables c++-mode ()
+ "Do what `semantic-get-local-variables' does, plus add `this' if needed."
+ (let* ((origvar (semantic-get-local-variables-default))
+ (ct (semantic-current-tag))
+ (p (semantic-tag-function-parent ct)))
+ ;; If we have a function parent, then that implies we can
+ (if (and p (semantic-tag-of-class-p ct 'function))
+ ;; Append a new tag THIS into our space.
+ (cons (semantic-tag-new-variable "this" p nil)
+ origvar)
+ ;; No parent, just return the usual
+ origvar)
+ ))
+
+ (define-mode-local-override semantic-idle-summary-current-symbol-info
+ c-mode ()
+ "Handle the SPP keywords, then use the default mechanism."
+ (let* ((sym (car (semantic-ctxt-current-thing)))
+ (spp-sym (semantic-lex-spp-symbol sym)))
+ (if spp-sym
+ (let* ((txt (concat "Macro: " sym))
+ (sv (symbol-value spp-sym))
+ (arg (semantic-lex-spp-macro-with-args sv))
+ )
+ (when arg
+ (setq txt (concat txt (format "%S" arg)))
+ (setq sv (cdr sv)))
+
+ ;; This is optional, and potentially fraught w/ errors.
+ (condition-case nil
+ (dolist (lt sv)
+ (setq txt (concat txt " " (semantic-lex-token-text lt))))
+ (error (setq txt (concat txt " #error in summary fcn"))))
+
+ txt)
+ (semantic-idle-summary-current-symbol-info-default))))
+
+ (defvar-mode-local c-mode semantic-orphaned-member-metaparent-type "struct"
+ "When lost memberes are found in the class hierarchy generator, use a struct.")
+
+ (defvar-mode-local c-mode semantic-symbol->name-assoc-list
+ '((type . "Types")
+ (variable . "Variables")
+ (function . "Functions")
+ (include . "Includes")
+ )
+ "List of tag classes, and strings to describe them.")
+
+ (defvar-mode-local c-mode semantic-symbol->name-assoc-list-for-type-parts
+ '((type . "Types")
+ (variable . "Attributes")
+ (function . "Methods")
+ (label . "Labels")
+ )
+ "List of tag classes in a datatype decl, and strings to describe them.")
+
+ (defvar-mode-local c-mode imenu-create-index-function 'semantic-create-imenu-index
+ "Imenu index function for C.")
+
+ (defvar-mode-local c-mode semantic-type-relation-separator-character
+ '("." "->" "::")
+ "Separator characters between something of a given type, and a field.")
+
+ (defvar-mode-local c-mode semantic-command-separation-character ";"
+ "Commen separation character for C")
+
+ (defvar-mode-local c-mode senator-step-at-tag-classes '(function variable)
+ "Tag classes where senator will stop at the end.")
+
+ ;;;###autoload
+ (defun semantic-default-c-setup ()
+ "Set up a buffer for semantic parsing of the C language."
+ (semantic-c-by--install-parser)
+ (setq semantic-lex-syntax-modifications '((?> ".")
+ (?< ".")
+ )
+ )
+
+ (setq semantic-lex-analyzer #'semantic-c-lexer)
+ (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t)
+ )
+
+ ;;;###autoload
+ (defun semantic-c-add-preprocessor-symbol (sym replacement)
+ "Add a preprocessor symbol SYM with a REPLACEMENT value."
+ (interactive "sSymbol: \nsReplacement: ")
+ (let ((SA (assoc sym semantic-lex-c-preprocessor-symbol-map)))
+ (if SA
+ ;; Replace if there is one.
+ (setcdr SA replacement)
+ ;; Otherwise, append
+ (setq semantic-lex-c-preprocessor-symbol-map
+ (cons (cons sym replacement)
+ semantic-lex-c-preprocessor-symbol-map))))
+
+ (semantic-c-reset-preprocessor-symbol-map)
+ )
+
+ ;;; SETUP QUERY
+ ;;
+ (defun semantic-c-describe-environment ()
+ "Describe the Semantic features of the current C environment."
+ (interactive)
+ (if (not (or (eq major-mode 'c-mode) (eq major-mode 'c++-mode)))
+ (error "Not useful to query C mode in %s mode" major-mode))
+ (let ((gcc (when (boundp 'semantic-gcc-setup-data)
+ semantic-gcc-setup-data))
+ )
+ (semantic-fetch-tags)
+
+ (with-output-to-temp-buffer "*Semantic C Environment*"
+ (when gcc
+ (princ "Calculated GCC Parameters:")
+ (dolist (P gcc)
+ (princ "\n ")
+ (princ (car P))
+ (princ " = ")
+ (princ (cdr P))
+ )
+ )
+
+ (princ "\n\nInclude Path Summary:\n")
+ (when (and (boundp 'ede-object) ede-object)
+ (princ "\n This file's project include is handled by:\n")
+ (princ " ")
+ (princ (object-print ede-object))
+ (princ "\n with the system path:\n")
+ (dolist (dir (ede-system-include-path ede-object))
+ (princ " ")
+ (princ dir)
+ (princ "\n"))
+ )
+
+ (when semantic-dependency-include-path
+ (princ "\n This file's generic include path is:\n")
+ (dolist (dir semantic-dependency-include-path)
+ (princ " ")
+ (princ dir)
+ (princ "\n")))
+
+ (when semantic-dependency-system-include-path
+ (princ "\n This file's system include path is:\n")
+ (dolist (dir semantic-dependency-system-include-path)
+ (princ " ")
+ (princ dir)
+ (princ "\n")))
+
+ (princ "\n\nMacro Summary:\n")
+ (when semantic-lex-c-preprocessor-symbol-file
+ (princ "\n Your CPP table is primed from these files:\n")
+ (dolist (file semantic-lex-c-preprocessor-symbol-file)
+ (princ " ")
+ (princ file)
+ (princ "\n")
+ (princ " in table: ")
+ (princ (object-print (semanticdb-file-table-object file)))
+ (princ "\n")
+ ))
+
+ (when semantic-lex-c-preprocessor-symbol-map-builtin
+ (princ "\n Built-in symbol map:\n")
+ (dolist (S semantic-lex-c-preprocessor-symbol-map-builtin)
+ (princ " ")
+ (princ (car S))
+ (princ " = ")
+ (princ (cdr S))
+ (princ "\n")
+ ))
+
+ (when semantic-lex-c-preprocessor-symbol-map
+ (princ "\n User symbol map:\n")
+ (dolist (S semantic-lex-c-preprocessor-symbol-map)
+ (princ " ")
+ (princ (car S))
+ (princ " = ")
+ (princ (cdr S))
+ (princ "\n")
+ ))
+
+ (princ "\n\n Use: M-x semantic-lex-spp-describe RET\n")
+ (princ "\n to see the complete macro table.\n")
+
+ )))
+
+ (provide 'semantic/bovine/c)
+
+ (semantic-c-reset-preprocessor-symbol-map)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "../loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/bovine/c"
+ ;; End:
+
+ ;;; semantic/bovine/c.el ends here
--- /dev/null
-\f
-;;; Analyzers
-;;
-(require 'semantic/lex)
-
-\f
-;;; Epilogue
-;;
-
+ ;;; semantic/bovine/make-by.el --- Generated parser support file
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2008
+ ;;; Free Software Foundation, Inc.
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; This file was generated from the grammar file
+ ;; semantic/bovine/make.by in the CEDET repository.
+
+ ;;; Code:
+
++(require 'semantic/lex)
+ (eval-when-compile (require 'semantic/bovine))
++
+ \f
+ ;;; Prologue
+ ;;
+ \f
+ ;;; Declarations
+ ;;
+ (defconst semantic-make-by--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("if" . IF)
+ ("ifdef" . IFDEF)
+ ("ifndef" . IFNDEF)
+ ("ifeq" . IFEQ)
+ ("ifneq" . IFNEQ)
+ ("else" . ELSE)
+ ("endif" . ENDIF)
+ ("include" . INCLUDE))
+ '(("include" summary "Macro: include filename1 filename2 ...")
+ ("ifneq" summary "Conditional: ifneq (expression) ... else ... endif")
+ ("ifeq" summary "Conditional: ifeq (expression) ... else ... endif")
+ ("ifndef" summary "Conditional: ifndef (expression) ... else ... endif")
+ ("ifdef" summary "Conditional: ifdef (expression) ... else ... endif")
+ ("endif" summary "Conditional: if (expression) ... else ... endif")
+ ("else" summary "Conditional: if (expression) ... else ... endif")
+ ("if" summary "Conditional: if (expression) ... else ... endif")))
+ "Table of language keywords.")
+
+ (defconst semantic-make-by--token-table
+ (semantic-lex-make-type-table
+ '(("punctuation"
+ (BACKSLASH . "\\`[\\]\\'")
+ (DOLLAR . "\\`[$]\\'")
+ (EQUAL . "\\`[=]\\'")
+ (PLUS . "\\`[+]\\'")
+ (COLON . "\\`[:]\\'")))
+ 'nil)
+ "Table of lexical tokens.")
+
+ (defconst semantic-make-by--parse-table
+ `(
+ (bovine-toplevel
+ (Makefile)
+ ) ;; end bovine-toplevel
+
+ (Makefile
+ (bol
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (bol
+ variable
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (bol
+ rule
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (bol
+ conditional
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (bol
+ include
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (whitespace
+ ,(semantic-lambda
+ (list nil))
+ )
+ (newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end Makefile
+
+ (variable
+ (symbol
+ opt-whitespace
+ equals
+ opt-whitespace
+ element-list
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nth 0 vals) nil
+ (nth 4 vals)))
+ )
+ ) ;; end variable
+
+ (rule
+ (targets
+ opt-whitespace
+ colons
+ opt-whitespace
+ element-list
+ commands
+ ,(semantic-lambda
+ (semantic-tag-new-function
+ (nth 0 vals) nil
+ (nth 4 vals)))
+ )
+ ) ;; end rule
+
+ (targets
+ (target
+ opt-whitespace
+ targets
+ ,(semantic-lambda
+ (list
+ (car
+ (nth 0 vals))
+ (car
+ (nth 2 vals))))
+ )
+ (target
+ ,(semantic-lambda
+ (list
+ (car
+ (nth 0 vals))))
+ )
+ ) ;; end targets
+
+ (target
+ (sub-target
+ target
+ ,(semantic-lambda
+ (list
+ (concat
+ (car
+ (nth 0 vals))
+ (car
+ (nth 2 vals)))))
+ )
+ (sub-target
+ ,(semantic-lambda
+ (list
+ (car
+ (nth 0 vals))))
+ )
+ ) ;; end target
+
+ (sub-target
+ (symbol)
+ (string)
+ (varref)
+ ) ;; end sub-target
+
+ (conditional
+ (IF
+ some-whitespace
+ symbol
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (IFDEF
+ some-whitespace
+ symbol
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (IFNDEF
+ some-whitespace
+ symbol
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (IFEQ
+ some-whitespace
+ expression
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (IFNEQ
+ some-whitespace
+ expression
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (ELSE
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ (ENDIF
+ newline
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end conditional
+
+ (expression
+ (semantic-list)
+ ) ;; end expression
+
+ (include
+ (INCLUDE
+ some-whitespace
+ element-list
+ ,(semantic-lambda
+ (semantic-tag-new-include
+ (nth 2 vals) nil))
+ )
+ ) ;; end include
+
+ (equals
+ (punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda)
+ )
+ (punctuation
+ "\\`[+]\\'"
+ punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda)
+ )
+ (punctuation
+ "\\`[=]\\'"
+ ,(semantic-lambda)
+ )
+ ) ;; end equals
+
+ (colons
+ (punctuation
+ "\\`[:]\\'"
+ punctuation
+ "\\`[:]\\'"
+ ,(semantic-lambda)
+ )
+ (punctuation
+ "\\`[:]\\'"
+ ,(semantic-lambda)
+ )
+ ) ;; end colons
+
+ (element-list
+ (elements
+ newline
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ) ;; end element-list
+
+ (elements
+ (element
+ some-whitespace
+ elements
+ ,(semantic-lambda
+ (nth 0 vals)
+ (nth 2 vals))
+ )
+ (element
+ ,(semantic-lambda
+ (nth 0 vals))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end elements
+
+ (element
+ (sub-element
+ element
+ ,(semantic-lambda
+ (list
+ (concat
+ (car
+ (nth 0 vals))
+ (car
+ (nth 1 vals)))))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end element
+
+ (sub-element
+ (symbol)
+ (string)
+ (punctuation)
+ (semantic-list
+ ,(semantic-lambda
+ (list
+ (buffer-substring-no-properties
+ (identity start)
+ (identity end))))
+ )
+ ) ;; end sub-element
+
+ (varref
+ (punctuation
+ "\\`[$]\\'"
+ semantic-list
+ ,(semantic-lambda
+ (list
+ (buffer-substring-no-properties
+ (identity start)
+ (identity end))))
+ )
+ ) ;; end varref
+
+ (commands
+ (bol
+ shell-command
+ newline
+ commands
+ ,(semantic-lambda
+ (list
+ (nth 0 vals))
+ (nth 1 vals))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end commands
+
+ (opt-whitespace
+ (some-whitespace
+ ,(semantic-lambda
+ (list nil))
+ )
+ ( ;;EMPTY
+ )
+ ) ;; end opt-whitespace
+
+ (some-whitespace
+ (whitespace
+ some-whitespace
+ ,(semantic-lambda
+ (list nil))
+ )
+ (whitespace
+ ,(semantic-lambda
+ (list nil))
+ )
+ ) ;; end some-whitespace
+ )
+ "Parser table.")
+
+ (defun semantic-make-by--install-parser ()
+ "Setup the Semantic Parser."
+ (setq semantic--parse-table semantic-make-by--parse-table
+ semantic-debug-parser-source "make.by"
+ semantic-debug-parser-class 'semantic-bovine-debug-parser
+ semantic-flex-keywords-obarray semantic-make-by--keyword-table
+ ))
+
+ (provide 'semantic/bovine/make-by)
+
+ ;;; semantic/bovine/make-by.el ends here
--- /dev/null
-(require 'semantic/format)
+ ;;; semantic/bovine/make.el --- Makefile parsing rules.
+
+ ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2008
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Use the Semantic Bovinator to parse Makefiles.
+ ;; Concocted as an experiment for nonstandard languages.
+
+ (require 'make-mode)
+
+ (require 'semantic)
+ (require 'semantic/bovine/make-by)
+ (require 'semantic/analyze)
-(eval-when-compile
- (require 'semantic/dep))
++(require 'semantic/dep)
+
++(declare-function semantic-analyze-possible-completions-default
++ "semantic/analyze/complete")
+
+ ;;; Code:
+ (define-lex-analyzer semantic-lex-make-backslash-no-newline
+ "Detect and create a beginning of line token (BOL)."
+ (and (looking-at "\\(\\\\\n\\s-*\\)")
+ ;; We have a \ at eol. Push it as whitespace, but pretend
+ ;; it never happened so we can skip the BOL tokenizer.
+ (semantic-lex-push-token (semantic-lex-token 'whitespace
+ (match-beginning 1)
+ (match-end 1)))
+ (goto-char (match-end 1))
+ nil) ;; CONTINUE
+ ;; We want to skip BOL, so move to the next condition.
+ nil)
+
+ (define-lex-regex-analyzer semantic-lex-make-command
+ "A command in a Makefile consists of a line starting with TAB, and ending at the newline."
+ "^\\(\t\\)"
+ (let ((start (match-end 0)))
+ (while (progn (end-of-line)
+ (save-excursion (forward-char -1) (looking-at "\\\\")))
+ (forward-char 1))
+ (semantic-lex-push-token
+ (semantic-lex-token 'shell-command start (point)))))
+
+ (define-lex-regex-analyzer semantic-lex-make-ignore-automake-conditional
+ "An automake conditional seems to really bog down the parser.
+ Ignore them."
+ "^@\\(\\w\\|\\s_\\)+@"
+ (setq semantic-lex-end-point (match-end 0)))
+
+ (define-lex semantic-make-lexer
+ "Lexical analyzer for Makefiles."
+ semantic-lex-beginning-of-line
+ semantic-lex-make-ignore-automake-conditional
+ semantic-lex-make-command
+ semantic-lex-make-backslash-no-newline
+ semantic-lex-whitespace
+ semantic-lex-newline
+ semantic-lex-symbol-or-keyword
+ semantic-lex-charquote
+ semantic-lex-paren-or-list
+ semantic-lex-close-paren
+ semantic-lex-string
+ semantic-lex-ignore-comments
+ semantic-lex-punctuation
+ semantic-lex-default-action)
+
+ (defun semantic-make-expand-tag (tag)
+ "Expand TAG into a list of equivalent tags, or nil."
+ (let ((name (semantic-tag-name tag))
+ xpand)
+ ;(message "Expanding %S" name)
+ ;(goto-char (semantic-tag-start tag))
+ ;(sit-for 0)
+ (if (and (consp name)
+ (memq (semantic-tag-class tag) '(function include))
+ (> (length name) 1))
+ (while name
+ (setq xpand (cons (semantic-tag-clone tag (car name)) xpand)
+ name (cdr name)))
+ ;; Else, only a single name.
+ (when (consp name)
+ (setcar tag (car name)))
+ (setq xpand (list tag)))
+ xpand))
+
+ (define-mode-local-override semantic-get-local-variables
+ makefile-mode (&optional point)
+ "Override `semantic-get-local-variables' so it does not throw an error.
+ We never have local variables in Makefiles."
+ nil)
+
+ (define-mode-local-override semantic-ctxt-current-class-list
+ makefile-mode (&optional point)
+ "List of classes that are valid to place at point."
+ (let ((tag (semantic-current-tag)))
+ (when tag
+ (cond ((condition-case nil
+ (save-excursion
+ (condition-case nil (forward-sexp -1)
+ (error nil))
+ (forward-char -2)
+ (looking-at "\\$\\s("))
+ (error nil))
+ ;; We are in a variable reference
+ '(variable))
+ ((semantic-tag-of-class-p tag 'function)
+ ;; Note: variables are handled above.
+ '(function filename))
+ ((semantic-tag-of-class-p tag 'variable)
+ '(function filename))
+ ))))
+
+ (define-mode-local-override semantic-format-tag-abbreviate
+ makefile-mode (tag &optional parent color)
+ "Return an abbreviated string describing tag for Makefiles."
+ (let ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color))
+ )
+ (cond ((eq class 'function)
+ (concat name ":"))
+ ((eq class 'filename)
+ (concat "./" name))
+ (t
+ (semantic-format-tag-abbreviate-default tag parent color)))))
+
+ (defvar-mode-local makefile-mode semantic-function-argument-separator
+ " "
+ "Separator used between dependencies to rules.")
+
+ (define-mode-local-override semantic-format-tag-prototype
+ makefile-mode (tag &optional parent color)
+ "Return a prototype string describing tag for Makefiles."
+ (let* ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color))
+ )
+ (cond ((eq class 'function)
+ (concat name ": "
+ (semantic--format-tag-arguments
+ (semantic-tag-function-arguments tag)
+ #'semantic-format-tag-prototype
+ color)))
+ ((eq class 'filename)
+ (concat "./" name))
+ (t
+ (semantic-format-tag-prototype-default tag parent color)))))
+
+ (define-mode-local-override semantic-format-tag-concise-prototype
+ makefile-mode (tag &optional parent color)
+ "Return a concise prototype string describing tag for Makefiles.
+ This is the same as a regular prototype."
+ (semantic-format-tag-prototype tag parent color))
+
+ (define-mode-local-override semantic-format-tag-uml-prototype
+ makefile-mode (tag &optional parent color)
+ "Return a UML prototype string describing tag for Makefiles.
+ This is the same as a regular prototype."
+ (semantic-format-tag-prototype tag parent color))
+
+ (define-mode-local-override semantic-analyze-possible-completions
+ makefile-mode (context)
+ "Return a list of possible completions in a Makefile.
+ Uses default implementation, and also gets a list of filenames."
+ (save-excursion
++ (require 'semantic/analyze/complete)
+ (set-buffer (oref context buffer))
+ (let* ((normal (semantic-analyze-possible-completions-default context))
+ (classes (oref context :prefixclass))
+ (filetags nil))
+ (when (memq 'filename classes)
+ (let* ((prefix (car (oref context :prefix)))
+ (completetext (cond ((semantic-tag-p prefix)
+ (semantic-tag-name prefix))
+ ((stringp prefix)
+ prefix)
+ ((stringp (car prefix))
+ (car prefix))))
+ (files (directory-files default-directory nil
+ (concat "^" completetext))))
+ (setq filetags (mapcar (lambda (f) (semantic-tag f 'filename))
+ files))))
+ ;; Return the normal completions found, plus any filenames
+ ;; that match.
+ (append normal filetags)
+ )))
+
+ (defcustom-mode-local-semantic-dependency-system-include-path
+ makefile-mode semantic-makefile-dependency-system-include-path
+ nil
+ "The system include path used by Makefiles langauge.")
+
+ ;;;###autoload
+ (defun semantic-default-make-setup ()
+ "Set up a Makefile buffer for parsing with semantic."
+ (semantic-make-by--install-parser)
+ (setq semantic-symbol->name-assoc-list '((variable . "Variables")
+ (function . "Rules")
+ (include . "Dependencies")
+ ;; File is a meta-type created
+ ;; to represent completions
+ ;; but not actually parsed.
+ (file . "File"))
+ semantic-case-fold t
+ semantic-tag-expand-function 'semantic-make-expand-tag
+ semantic-lex-syntax-modifications '((?. "_")
+ (?= ".")
+ (?/ "_")
+ (?$ ".")
+ (?+ ".")
+ (?\\ ".")
+ )
+ imenu-create-index-function 'semantic-create-imenu-index
+ )
+ (setq semantic-lex-analyzer #'semantic-make-lexer)
+ )
+
+ (provide 'semantic/bovine/make)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "../loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/bovine/make"
+ ;; End:
+
+ ;;; semantic/bovine/make.el ends here
--- /dev/null
-\f
-;;; Analyzers
-;;
-(require 'semantic/lex)
-
-\f
-;;; Epilogue
-;;
-
+ ;;; semantic-scm-by.el --- Generated parser support file
+
+ ;; Copyright (C) 2001, 2003, 2009 Free Software Foundation, Inc.
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; This file was generated from the grammar file
+ ;; semantic/bovine/scm.by in the CEDET repository.
+
+ ;;; Code:
+
++(require 'semantic/lex)
++
+ (eval-when-compile (require 'semantic/bovine))
+ \f
+ ;;; Prologue
+ ;;
+ \f
+ ;;; Declarations
+ ;;
+ (defconst semantic-scm-by--keyword-table
+ (semantic-lex-make-keyword-table
+ '(("define" . DEFINE)
+ ("define-module" . DEFINE-MODULE)
+ ("load" . LOAD))
+ '(("load" summary "Function: (load \"filename\")")
+ ("define-module" summary "Function: (define-module (name arg1 ...)) ")
+ ("define" summary "Function: (define symbol expression)")))
+ "Table of language keywords.")
+
+ (defconst semantic-scm-by--token-table
+ (semantic-lex-make-type-table
+ '(("close-paren"
+ (CLOSEPAREN . ")"))
+ ("open-paren"
+ (OPENPAREN . "(")))
+ 'nil)
+ "Table of lexical tokens.")
+
+ (defconst semantic-scm-by--parse-table
+ `(
+ (bovine-toplevel
+ (scheme)
+ ) ;; end bovine-toplevel
+
+ (scheme
+ (semantic-list
+ ,(lambda (vals start end)
+ (semantic-bovinate-from-nonterminal
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'scheme-list))
+ )
+ ) ;; end scheme
+
+ (scheme-list
+ (open-paren
+ "("
+ scheme-in-list
+ close-paren
+ ")"
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ ) ;; end scheme-list
+
+ (scheme-in-list
+ (DEFINE
+ symbol
+ expression
+ ,(semantic-lambda
+ (semantic-tag-new-variable
+ (nth 1 vals) nil
+ (nth 2 vals)))
+ )
+ (DEFINE
+ name-args
+ opt-doc
+ sequence
+ ,(semantic-lambda
+ (semantic-tag-new-function
+ (car
+ (nth 1 vals)) nil
+ (cdr
+ (nth 1 vals))))
+ )
+ (DEFINE-MODULE
+ name-args
+ ,(semantic-lambda
+ (semantic-tag-new-package
+ (nth
+ (length
+ (nth 1 vals))
+ (nth 1 vals)) nil))
+ )
+ (LOAD
+ string
+ ,(semantic-lambda
+ (semantic-tag-new-include
+ (file-name-nondirectory
+ (read
+ (nth 1 vals)))
+ (read
+ (nth 1 vals))))
+ )
+ (symbol
+ ,(semantic-lambda
+ (semantic-tag-new-code
+ (nth 0 vals) nil))
+ )
+ ) ;; end scheme-in-list
+
+ (name-args
+ (semantic-list
+ ,(lambda (vals start end)
+ (semantic-bovinate-from-nonterminal
+ (car
+ (nth 0 vals))
+ (cdr
+ (nth 0 vals))
+ 'name-arg-expand))
+ )
+ ) ;; end name-args
+
+ (name-arg-expand
+ (open-paren
+ name-arg-expand
+ ,(semantic-lambda
+ (nth 1 vals))
+ )
+ (symbol
+ name-arg-expand
+ ,(semantic-lambda
+ (cons
+ (nth 0 vals)
+ (nth 1 vals)))
+ )
+ ( ;;EMPTY
+ ,(semantic-lambda)
+ )
+ ) ;; end name-arg-expand
+
+ (opt-doc
+ (string)
+ ( ;;EMPTY
+ )
+ ) ;; end opt-doc
+
+ (sequence
+ (expression
+ sequence)
+ (expression)
+ ) ;; end sequence
+
+ (expression
+ (symbol)
+ (semantic-list)
+ (string)
+ (number)
+ ) ;; end expression
+ )
+ "Parser table.")
+
+ (defun semantic-scm-by--install-parser ()
+ "Setup the Semantic Parser."
+ (setq semantic--parse-table semantic-scm-by--parse-table
+ semantic-debug-parser-source "scheme.by"
+ semantic-debug-parser-class 'semantic-bovine-debug-parser
+ semantic-flex-keywords-obarray semantic-scm-by--keyword-table
+ ))
+
+ (provide 'semantic/bovine/scm-by)
+
+ ;;; semantic/bovine/scm-by.el ends here
--- /dev/null
-
-(eval-when-compile
- (require 'semantic/dep))
+ ;;; semantic/bovine/scm.el --- Semantic details for Scheme (guile)
+
+ ;;; Copyright (C) 2001, 2002, 2003, 2004, 2008, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Use the Semantic Bovinator for Scheme (guile)
+
+ (require 'semantic)
+ (require 'semantic/bovine/scm-by)
+ (require 'semantic/format)
++(require 'semantic/dep)
+
+ ;;; Code:
+
+ (defcustom-mode-local-semantic-dependency-system-include-path
+ scheme-mode semantic-default-scheme-path
+ '("/usr/share/guile/")
+ "Default set of include paths for scheme (guile) code.
+ This should probably do some sort of search to see what is
+ actually on the local machine.")
+
+ (define-mode-local-override semantic-format-tag-prototype scheme-mode (tag)
+ "Return a prototype for the Emacs Lisp nonterminal TAG."
+ (let* ((tok (semantic-tag-class tag))
+ (args (semantic-tag-components tag))
+ )
+ (if (eq tok 'function)
+ (concat (semantic-tag-name tag) " ("
+ (mapconcat (lambda (a) a) args " ")
+ ")")
+ (semantic-format-tag-prototype-default tag))))
+
+ (define-mode-local-override semantic-documentation-for-tag scheme-mode (tag &optional nosnarf)
+ "Return the documentation string for TAG.
+ Optional argument NOSNARF is ignored."
+ (let ((d (semantic-tag-docstring tag)))
+ (if (and d (> (length d) 0) (= (aref d 0) ?*))
+ (substring d 1)
+ d)))
+
+ (define-mode-local-override semantic-insert-foreign-tag scheme-mode (tag tagfile)
+ "Insert TAG from TAGFILE at point.
+ Attempts a simple prototype for calling or using TAG."
+ (cond ((eq (semantic-tag-class tag) 'function)
+ (insert "(" (semantic-tag-name tag) " )")
+ (forward-char -1))
+ (t
+ (insert (semantic-tag-name tag)))))
+
+ ;; Note: Analyzer from Henry S. Thompson
+ (define-lex-regex-analyzer semantic-lex-scheme-symbol
+ "Detect and create symbol and keyword tokens."
+ "\\(\\sw\\([:]\\|\\sw\\|\\s_\\)+\\)"
+ ;; (message (format "symbol: %s" (match-string 0)))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (or (semantic-lex-keyword-p (match-string 0)) 'symbol)
+ (match-beginning 0) (match-end 0))))
+
+
+ (define-lex semantic-scheme-lexer
+ "A simple lexical analyzer that handles simple buffers.
+ This lexer ignores comments and whitespace, and will return
+ syntax as specified by the syntax table."
+ semantic-lex-ignore-whitespace
+ semantic-lex-ignore-newline
+ semantic-lex-scheme-symbol
+ semantic-lex-charquote
+ semantic-lex-paren-or-list
+ semantic-lex-close-paren
+ semantic-lex-string
+ semantic-lex-ignore-comments
+ semantic-lex-punctuation
+ semantic-lex-number
+ semantic-lex-default-action)
+
+ ;;;###autoload
+ (defun semantic-default-scheme-setup ()
+ "Setup hook function for Emacs Lisp files and Semantic."
+ (semantic-scm-by--install-parser)
+ (setq semantic-symbol->name-assoc-list '( (variable . "Variables")
+ ;;(type . "Types")
+ (function . "Functions")
+ (include . "Loads")
+ (package . "DefineModule"))
+ imenu-create-index-function 'semantic-create-imenu-index
+ imenu-create-index-function 'semantic-create-imenu-index
+ )
+ (setq semantic-lex-analyzer #'semantic-scheme-lexer)
+ )
+
+ (provide 'semantic/bovine/scm)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "../loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/bovine/scm"
+ ;; End:
+
+ ;;; semantic/bovine/scm.el ends here
--- /dev/null
-(require 'eieio)
-(require 'eieio-opt)
+ ;;; semantic/complete.el --- Routines for performing tag completion
+
+ ;;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Completion of tags by name using tables of semantic generated tags.
+ ;;
+ ;; While it would be a simple matter of flattening all tag known
+ ;; tables to perform completion across them using `all-completions',
+ ;; or `try-completion', that process would be slow. In particular,
+ ;; when a system database is included in the mix, the potential for a
+ ;; ludicrous number of options becomes apparent.
+ ;;
+ ;; As such, dynamically searching across tables using a prefix,
+ ;; regular expression, or other feature is needed to help find symbols
+ ;; quickly without resorting to "show me every possible option now".
+ ;;
+ ;; In addition, some symbol names will appear in multiple locations.
+ ;; If it is important to distiguish, then a way to provide a choice
+ ;; over these locations is important as well.
+ ;;
+ ;; Beyond brute force offers for completion of plain strings,
+ ;; using the smarts of semantic-analyze to provide reduced lists of
+ ;; symbols, or fancy tabbing to zoom into files to show multiple hits
+ ;; of the same name can be provided.
+ ;;
+ ;;; How it works:
+ ;;
+ ;; There are several parts of any completion engine. They are:
+ ;;
+ ;; A. Collection of possible hits
+ ;; B. Typing or selecting an option
+ ;; C. Displaying possible unique completions
+ ;; D. Using the result
+ ;;
+ ;; Here, we will treat each section separately (excluding D)
+ ;; They can then be strung together in user-visible commands to
+ ;; fullfill specific needs.
+ ;;
+ ;; COLLECTORS:
+ ;;
+ ;; A collector is an object which represents the means by which tags
+ ;; to complete on are collected. It's first job is to find all the
+ ;; tags which are to be completed against. It can also rename
+ ;; some tags if needed so long as `semantic-tag-clone' is used.
+ ;;
+ ;; Some collectors will gather all tags to complete against first
+ ;; (for in buffer queries, or other small list situations). It may
+ ;; choose to do a broad search on each completion request. Built in
+ ;; functionality automatically focuses the cache in as the user types.
+ ;;
+ ;; A collector choosing to create and rename tags could choose a
+ ;; plain name format, a postfix name such as method:class, or a
+ ;; prefix name such as class.method.
+ ;;
+ ;; DISPLAYORS
+ ;;
+ ;; A displayor is in charge if showing the user interesting things
+ ;; about available completions, and can optionally provide a focus.
+ ;; The simplest display just lists all available names in a separate
+ ;; window. It may even choose to show short names when there are
+ ;; many to choose from, or long names when there are fewer.
+ ;;
+ ;; A complex displayor could opt to help the user 'focus' on some
+ ;; range. For example, if 4 tags all have the same name, subsequent
+ ;; calls to the displayor may opt to show each tag one at a time in
+ ;; the buffer. When the user likes one, selection would cause the
+ ;; 'focus' item to be selected.
+ ;;
+ ;; CACHE FORMAT
+ ;;
+ ;; The format of the tag lists used to perform the completions are in
+ ;; semanticdb "find" format, like this:
+ ;;
+ ;; ( ( DBTABLE1 TAG1 TAG2 ...)
+ ;; ( DBTABLE2 TAG1 TAG2 ...)
+ ;; ... )
+ ;;
+ ;; INLINE vs MINIBUFFER
+ ;;
+ ;; Two major ways completion is used in Emacs is either through a
+ ;; minibuffer query, or via completion in a normal editing buffer,
+ ;; encompassing some small range of characters.
+ ;;
+ ;; Structure for both types of completion are provided here.
+ ;; `semantic-complete-read-tag-engine' will use the minibuffer.
+ ;; `semantic-complete-inline-tag-engine' will complete text in
+ ;; a buffer.
+
-(eval-when-compile
- (condition-case nil
- ;; Tooltip not available in older emacsen.
- (require 'tooltip)
- (error nil))
- )
-
+ (require 'semantic)
++(require 'eieio-opt)
+ (require 'semantic/analyze)
+ (require 'semantic/ctxt)
+ (require 'semantic/decorate)
+ (require 'semantic/format)
+
+ (eval-when-compile
+ ;; For the semantic-find-tags-for-completion macro.
+ (require 'semantic/find))
+
-;;; Compatibility
-;;
-(if (fboundp 'minibuffer-contents)
- (eval-and-compile (defalias 'semantic-minibuffer-contents 'minibuffer-contents))
- (eval-and-compile (defalias 'semantic-minibuffer-contents 'buffer-string)))
-(if (fboundp 'delete-minibuffer-contents)
- (eval-and-compile (defalias 'semantic-delete-minibuffer-contents 'delete-minibuffer-contents))
- (eval-and-compile (defalias 'semantic-delete-minibuffer-contents 'erase-buffer)))
-
+ ;;; Code:
+
- (semantic-minibuffer-contents)))
+ (defvar semantic-complete-inline-overlay nil
+ "The overlay currently active while completing inline.")
+
+ (defun semantic-completion-inline-active-p ()
+ "Non-nil if inline completion is active."
+ (when (and semantic-complete-inline-overlay
+ (not (semantic-overlay-live-p semantic-complete-inline-overlay)))
+ (semantic-overlay-delete semantic-complete-inline-overlay)
+ (setq semantic-complete-inline-overlay nil))
+ semantic-complete-inline-overlay)
+
+ ;;; ------------------------------------------------------------
+ ;;; MINIBUFFER or INLINE utils
+ ;;
+ (defun semantic-completion-text ()
+ "Return the text that is currently in the completion buffer.
+ For a minibuffer prompt, this is the minibuffer text.
+ For inline completion, this is the text wrapped in the inline completion
+ overlay."
+ (if semantic-complete-inline-overlay
+ (semantic-complete-inline-text)
- (semantic-delete-minibuffer-contents)))
++ (minibuffer-contents)))
+
+ (defun semantic-completion-delete-text ()
+ "Delete the text that is actively being completed.
+ Presumably if you call this you will insert something new there."
+ (if semantic-complete-inline-overlay
+ (semantic-complete-inline-delete-text)
-;; @TODO - I can't find where this fcn is used. Delete?
-
-;;;;###autoload
-;(defun semantic-complete-inline-project ()
-; "Perform inline completion for any symbol in the current project.
-;`semantic-analyze-possible-completions' is used to determine the
-;possible values.
-;The function returns immediately, leaving the buffer in a mode that
-;will perform the completion."
-; (interactive)
-; ;; Only do this if we are not already completing something.
-; (if (not (semantic-completion-inline-active-p))
-; (semantic-complete-inline-tag-project))
-; ;; Report a message if things didn't startup.
-; (if (and (interactive-p)
-; (not (semantic-completion-inline-active-p)))
-; (message "Inline completion not needed."))
-; )
-
-;; End
++ (delete-minibuffer-contents)))
+
+ (defun semantic-completion-message (fmt &rest args)
+ "Display the string FMT formatted with ARGS at the end of the minibuffer."
+ (if semantic-complete-inline-overlay
+ (apply 'message fmt args)
+ (message (concat (buffer-string) (apply 'format fmt args)))))
+
+ ;;; ------------------------------------------------------------
+ ;;; MINIBUFFER: Option Selection harnesses
+ ;;
+ (defvar semantic-completion-collector-engine nil
+ "The tag collector for the current completion operation.
+ Value should be an object of a subclass of
+ `semantic-completion-engine-abstract'.")
+
+ (defvar semantic-completion-display-engine nil
+ "The tag display engine for the current completion operation.
+ Value should be a ... what?")
+
+ (defvar semantic-complete-key-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km " " 'semantic-complete-complete-space)
+ (define-key km "\t" 'semantic-complete-complete-tab)
+ (define-key km "\C-m" 'semantic-complete-done)
+ (define-key km "\C-g" 'abort-recursive-edit)
+ (define-key km "\M-n" 'next-history-element)
+ (define-key km "\M-p" 'previous-history-element)
+ (define-key km "\C-n" 'next-history-element)
+ (define-key km "\C-p" 'previous-history-element)
+ ;; Add history navigation
+ km)
+ "Keymap used while completing across a list of tags.")
+
+ (defvar semantic-completion-default-history nil
+ "Default history variable for any unhistoried prompt.
+ Keeps STRINGS only in the history.")
+
+
+ (defun semantic-complete-read-tag-engine (collector displayor prompt
+ default-tag initial-input
+ history)
+ "Read a semantic tag, and return a tag for the selection.
+ Argument COLLECTOR is an object which can be used to to calculate
+ a list of possible hits. See `semantic-completion-collector-engine'
+ for details on COLLECTOR.
+ Argumeng DISPLAYOR is an object used to display a list of possible
+ completions for a given prefix. See`semantic-completion-display-engine'
+ for details on DISPLAYOR.
+ PROMPT is a string to prompt with.
+ DEFAULT-TAG is a semantic tag or string to use as the default value.
+ If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
+ HISTORY is a symbol representing a variable to story the history in."
+ (let* ((semantic-completion-collector-engine collector)
+ (semantic-completion-display-engine displayor)
+ (semantic-complete-active-default nil)
+ (semantic-complete-current-matched-tag nil)
+ (default-as-tag (semantic-complete-default-to-tag default-tag))
+ (default-as-string (when (semantic-tag-p default-as-tag)
+ (semantic-tag-name default-as-tag)))
+ )
+
+ (when default-as-string
+ ;; Add this to the prompt.
+ ;;
+ ;; I really want to add a lookup of the symbol in those
+ ;; tags available to the collector and only add it if it
+ ;; is available as a possibility, but I'm too lazy right
+ ;; now.
+ ;;
+
+ ;; @todo - move from () to into the editable area
+ (if (string-match ":" prompt)
+ (setq prompt (concat
+ (substring prompt 0 (match-beginning 0))
+ " (" default-as-string ")"
+ (substring prompt (match-beginning 0))))
+ (setq prompt (concat prompt " (" default-as-string "): "))))
+ ;;
+ ;; Perform the Completion
+ ;;
+ (unwind-protect
+ (read-from-minibuffer prompt
+ initial-input
+ semantic-complete-key-map
+ nil
+ (or history
+ 'semantic-completion-default-history)
+ default-tag)
+ (semantic-collector-cleanup semantic-completion-collector-engine)
+ (semantic-displayor-cleanup semantic-completion-display-engine)
+ )
+ ;;
+ ;; Extract the tag from the completion machinery.
+ ;;
+ semantic-complete-current-matched-tag
+ ))
+
+ \f
+ ;;; Util for basic completion prompts
+ ;;
+
+ (defvar semantic-complete-active-default nil
+ "The current default tag calculated for this prompt.")
+
+ (defun semantic-complete-default-to-tag (default)
+ "Convert a calculated or passed in DEFAULT into a tag."
+ (if (semantic-tag-p default)
+ ;; Just return what was passed in.
+ (setq semantic-complete-active-default default)
+ ;; If none was passed in, guess.
+ (if (null default)
+ (setq default (semantic-ctxt-current-thing)))
+ (if (null default)
+ ;; Do nothing
+ nil
+ ;; Turn default into something useful.
+ (let ((str
+ (cond
+ ;; Semantic-ctxt-current-symbol will return a list of
+ ;; strings. Technically, we should use the analyzer to
+ ;; fully extract what we need, but for now, just grab the
+ ;; first string
+ ((and (listp default) (stringp (car default)))
+ (car default))
+ ((stringp default)
+ default)
+ ((symbolp default)
+ (symbol-name default))
+ (t
+ (signal 'wrong-type-argument
+ (list default 'semantic-tag-p)))))
+ (tag nil))
+ ;; Now that we have that symbol string, look it up using the active
+ ;; collector. If we get a match, use it.
+ (save-excursion
+ (semantic-collector-calculate-completions
+ semantic-completion-collector-engine
+ str nil))
+ ;; Do we have the perfect match???
+ (let ((ml (semantic-collector-current-exact-match
+ semantic-completion-collector-engine)))
+ (when ml
+ ;; We don't care about uniqueness. Just guess for convenience
+ (setq tag (semanticdb-find-result-nth-in-buffer ml 0))))
+ ;; save it
+ (setq semantic-complete-active-default tag)
+ ;; Return it.. .whatever it may be
+ tag))))
+
+ \f
+ ;;; Prompt Return Value
+ ;;
+ ;; Getting a return value out of this completion prompt is a bit
+ ;; challenging. The read command returns the string typed in.
+ ;; We need to convert this into a valid tag. We can exit the minibuffer
+ ;; for different reasons. If we purposely exit, we must make sure
+ ;; the focused tag is calculated... preferably once.
+ (defvar semantic-complete-current-matched-tag nil
+ "Variable used to pass the tags being matched to the prompt.")
+
+ ;; semantic-displayor-focus-abstract-child-p is part of the
+ ;; semantic-displayor-focus-abstract class, defined later in this
+ ;; file.
+ (declare-function semantic-displayor-focus-abstract-child-p "semantic/complete")
+
+ (defun semantic-complete-current-match ()
+ "Calculate a match from the current completion environment.
+ Save this in our completion variable. Make sure that variable
+ is cleared if any other keypress is made.
+ Return value can be:
+ tag - a single tag that has been matched.
+ string - a message to show in the minibuffer."
+ ;; Query the environment for an active completion.
+ (let ((collector semantic-completion-collector-engine)
+ (displayor semantic-completion-display-engine)
+ (contents (semantic-completion-text))
+ matchlist
+ answer)
+ (if (string= contents "")
+ ;; The user wants the defaults!
+ (setq answer semantic-complete-active-default)
+ ;; This forces a full calculation of completion on CR.
+ (save-excursion
+ (semantic-collector-calculate-completions collector contents nil))
+ (semantic-complete-try-completion)
+ (cond
+ ;; Input match displayor focus entry
+ ((setq answer (semantic-displayor-current-focus displayor))
+ ;; We have answer, continue
+ )
+ ;; One match from the collector
+ ((setq matchlist (semantic-collector-current-exact-match collector))
+ (if (= (semanticdb-find-result-length matchlist) 1)
+ (setq answer (semanticdb-find-result-nth-in-buffer matchlist 0))
+ (if (semantic-displayor-focus-abstract-child-p displayor)
+ ;; For focusing displayors, we can claim this is
+ ;; not unique. Multiple focuses can choose the correct
+ ;; one.
+ (setq answer "Not Unique")
+ ;; If we don't have a focusing displayor, we need to do something
+ ;; graceful. First, see if all the matches have the same name.
+ (let ((allsame t)
+ (firstname (semantic-tag-name
+ (car
+ (semanticdb-find-result-nth matchlist 0)))
+ )
+ (cnt 1)
+ (max (semanticdb-find-result-length matchlist)))
+ (while (and allsame (< cnt max))
+ (if (not (string=
+ firstname
+ (semantic-tag-name
+ (car
+ (semanticdb-find-result-nth matchlist cnt)))))
+ (setq allsame nil))
+ (setq cnt (1+ cnt))
+ )
+ ;; Now we know if they are all the same. If they are, just
+ ;; accept the first, otherwise complain.
+ (if allsame
+ (setq answer (semanticdb-find-result-nth-in-buffer
+ matchlist 0))
+ (setq answer "Not Unique"))
+ ))))
+ ;; No match
+ (t
+ (setq answer "No Match")))
+ )
+ ;; Set it into our completion target.
+ (when (semantic-tag-p answer)
+ (setq semantic-complete-current-matched-tag answer)
+ ;; Make sure it is up to date by clearing it if the user dares
+ ;; to touch the keyboard.
+ (add-hook 'pre-command-hook
+ (lambda () (setq semantic-complete-current-matched-tag nil)))
+ )
+ ;; Return it
+ answer
+ ))
+
+ \f
+ ;;; Keybindings
+ ;;
+ ;; Keys are bound to to perform completion using our mechanisms.
+ ;; Do that work here.
+ (defun semantic-complete-done ()
+ "Accept the current input."
+ (interactive)
+ (let ((ans (semantic-complete-current-match)))
+ (if (stringp ans)
+ (semantic-completion-message (concat " [" ans "]"))
+ (exit-minibuffer)))
+ )
+
+ (defun semantic-complete-complete-space ()
+ "Complete the partial input in the minibuffer."
+ (interactive)
+ (semantic-complete-do-completion t))
+
+ (defun semantic-complete-complete-tab ()
+ "Complete the partial input in the minibuffer as far as possible."
+ (interactive)
+ (semantic-complete-do-completion))
+
+ ;;; Completion Functions
+ ;;
+ ;; Thees routines are functional entry points to performing completion.
+ ;;
+ (defun semantic-complete-hack-word-boundaries (original new)
+ "Return a string to use for completion.
+ ORIGINAL is the text in the minibuffer.
+ NEW is the new text to insert into the minibuffer.
+ Within the difference bounds of ORIGINAL and NEW, shorten NEW
+ to the nearest word boundary, and return that."
+ (save-match-data
+ (let* ((diff (substring new (length original)))
+ (end (string-match "\\>" diff))
+ (start (string-match "\\<" diff)))
+ (cond
+ ((and start (> start 0))
+ ;; If start is greater than 0, include only the new
+ ;; white-space stuff
+ (concat original (substring diff 0 start)))
+ (end
+ (concat original (substring diff 0 end)))
+ (t new)))))
+
+ (defun semantic-complete-try-completion (&optional partial)
+ "Try a completion for the current minibuffer.
+ If PARTIAL, do partial completion stopping at spaces."
+ (let ((comp (semantic-collector-try-completion
+ semantic-completion-collector-engine
+ (semantic-completion-text))))
+ (cond
+ ((null comp)
+ (semantic-completion-message " [No Match]")
+ (ding)
+ )
+ ((stringp comp)
+ (if (string= (semantic-completion-text) comp)
+ (when partial
+ ;; Minibuffer isn't changing AND the text is not unique.
+ ;; Test for partial completion over a word separator character.
+ ;; If there is one available, use that so that SPC can
+ ;; act like a SPC insert key.
+ (let ((newcomp (semantic-collector-current-whitespace-completion
+ semantic-completion-collector-engine)))
+ (when newcomp
+ (semantic-completion-delete-text)
+ (insert newcomp))
+ ))
+ (when partial
+ (let ((orig (semantic-completion-text)))
+ ;; For partial completion, we stop and step over
+ ;; word boundaries. Use this nifty function to do
+ ;; that calculation for us.
+ (setq comp
+ (semantic-complete-hack-word-boundaries orig comp))))
+ ;; Do the replacement.
+ (semantic-completion-delete-text)
+ (insert comp))
+ )
+ ((and (listp comp) (semantic-tag-p (car comp)))
+ (unless (string= (semantic-completion-text)
+ (semantic-tag-name (car comp)))
+ ;; A fully unique completion was available.
+ (semantic-completion-delete-text)
+ (insert (semantic-tag-name (car comp))))
+ ;; The match is complete
+ (if (= (length comp) 1)
+ (semantic-completion-message " [Complete]")
+ (semantic-completion-message " [Complete, but not unique]"))
+ )
+ (t nil))))
+
+ (defun semantic-complete-do-completion (&optional partial inline)
+ "Do a completion for the current minibuffer.
+ If PARTIAL, do partial completion stopping at spaces.
+ if INLINE, then completion is happening inline in a buffer."
+ (let* ((collector semantic-completion-collector-engine)
+ (displayor semantic-completion-display-engine)
+ (contents (semantic-completion-text))
+ (ans nil))
+
+ (save-excursion
+ (semantic-collector-calculate-completions collector contents partial))
+ (let* ((na (semantic-complete-next-action partial)))
+ (cond
+ ;; We're all done, but only from a very specific
+ ;; area of completion.
+ ((eq na 'done)
+ (semantic-completion-message " [Complete]")
+ (setq ans 'done))
+ ;; Perform completion
+ ((or (eq na 'complete)
+ (eq na 'complete-whitespace))
+ (semantic-complete-try-completion partial)
+ (setq ans 'complete))
+ ;; We need to display the completions.
+ ;; Set the completions into the display engine
+ ((or (eq na 'display) (eq na 'displayend))
+ (semantic-displayor-set-completions
+ displayor
+ (or
+ (and (not (eq na 'displayend))
+ (semantic-collector-current-exact-match collector))
+ (semantic-collector-all-completions collector contents))
+ contents)
+ ;; Ask the displayor to display them.
+ (semantic-displayor-show-request displayor))
+ ((eq na 'scroll)
+ (semantic-displayor-scroll-request displayor)
+ )
+ ((eq na 'focus)
+ (semantic-displayor-focus-next displayor)
+ (semantic-displayor-focus-request displayor)
+ )
+ ((eq na 'empty)
+ (semantic-completion-message " [No Match]"))
+ (t nil)))
+ ans))
+
+ \f
+ ;;; ------------------------------------------------------------
+ ;;; INLINE: tag completion harness
+ ;;
+ ;; Unlike the minibuffer, there is no mode nor other traditional
+ ;; means of reading user commands in completion mode. Instead
+ ;; we use a pre-command-hook to inset in our commands, and to
+ ;; push ourselves out of this mode on alternate keypresses.
+ (defvar semantic-complete-inline-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "\C-i" 'semantic-complete-inline-TAB)
+ (define-key km "\M-p" 'semantic-complete-inline-up)
+ (define-key km "\M-n" 'semantic-complete-inline-down)
+ (define-key km "\C-m" 'semantic-complete-inline-done)
+ (define-key km "\C-\M-c" 'semantic-complete-inline-exit)
+ (define-key km "\C-g" 'semantic-complete-inline-quit)
+ (define-key km "?"
+ (lambda () (interactive)
+ (describe-variable 'semantic-complete-inline-map)))
+ km)
+ "Keymap used while performing Semantic inline completion.
+ \\{semantic-complete-inline-map}")
+
+ (defface semantic-complete-inline-face
+ '((((class color) (background dark))
+ (:underline "yellow"))
+ (((class color) (background light))
+ (:underline "brown")))
+ "*Face used to show the region being completed inline.
+ The face is used in `semantic-complete-inline-tag-engine'."
+ :group 'semantic-faces)
+
+ (defun semantic-complete-inline-text ()
+ "Return the text that is being completed inline.
+ Similar to `minibuffer-contents' when completing in the minibuffer."
+ (let ((s (semantic-overlay-start semantic-complete-inline-overlay))
+ (e (semantic-overlay-end semantic-complete-inline-overlay)))
+ (if (= s e)
+ ""
+ (buffer-substring-no-properties s e ))))
+
+ (defun semantic-complete-inline-delete-text ()
+ "Delete the text currently being completed in the current buffer."
+ (delete-region
+ (semantic-overlay-start semantic-complete-inline-overlay)
+ (semantic-overlay-end semantic-complete-inline-overlay)))
+
+ (defun semantic-complete-inline-done ()
+ "This completion thing is DONE, OR, insert a newline."
+ (interactive)
+ (let* ((displayor semantic-completion-display-engine)
+ (tag (semantic-displayor-current-focus displayor)))
+ (if tag
+ (let ((txt (semantic-completion-text)))
+ (insert (substring (semantic-tag-name tag)
+ (length txt)))
+ (semantic-complete-inline-exit))
+
+ ;; Get whatever binding RET usually has.
+ (let ((fcn
+ (condition-case nil
+ (lookup-key (current-active-maps) (this-command-keys))
+ (error
+ ;; I don't know why, but for some reason the above
+ ;; throws an error sometimes.
+ (lookup-key (current-global-map) (this-command-keys))
+ ))))
+ (when fcn
+ (funcall fcn)))
+ )))
+
+ (defun semantic-complete-inline-quit ()
+ "Quit an inline edit."
+ (interactive)
+ (semantic-complete-inline-exit)
+ (keyboard-quit))
+
+ (defun semantic-complete-inline-exit ()
+ "Exit inline completion mode."
+ (interactive)
+ ;; Remove this hook FIRST!
+ (remove-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
+
+ (condition-case nil
+ (progn
+ (when semantic-completion-collector-engine
+ (semantic-collector-cleanup semantic-completion-collector-engine))
+ (when semantic-completion-display-engine
+ (semantic-displayor-cleanup semantic-completion-display-engine))
+
+ (when semantic-complete-inline-overlay
+ (let ((wc (semantic-overlay-get semantic-complete-inline-overlay
+ 'window-config-start))
+ (buf (semantic-overlay-buffer semantic-complete-inline-overlay))
+ )
+ (semantic-overlay-delete semantic-complete-inline-overlay)
+ (setq semantic-complete-inline-overlay nil)
+ ;; DONT restore the window configuration if we just
+ ;; switched windows!
+ (when (eq buf (current-buffer))
+ (set-window-configuration wc))
+ ))
+
+ (setq semantic-completion-collector-engine nil
+ semantic-completion-display-engine nil))
+ (error nil))
+
+ ;; Remove this hook LAST!!!
+ ;; This will force us back through this function if there was
+ ;; some sort of error above.
+ (remove-hook 'post-command-hook 'semantic-complete-post-command-hook)
+
+ ;;(message "Exiting inline completion.")
+ )
+
+ (defun semantic-complete-pre-command-hook ()
+ "Used to redefine what commands are being run while completing.
+ When installed as a `pre-command-hook' the special keymap
+ `semantic-complete-inline-map' is queried to replace commands normally run.
+ Commands which edit what is in the region of interest operate normally.
+ Commands which would take us out of the region of interest, or our
+ quit hook, will exit this completion mode."
+ (let ((fcn (lookup-key semantic-complete-inline-map
+ (this-command-keys) nil)))
+ (cond ((commandp fcn)
+ (setq this-command fcn))
+ (t nil)))
+ )
+
+ (defun semantic-complete-post-command-hook ()
+ "Used to determine if we need to exit inline completion mode.
+ If completion mode is active, check to see if we are within
+ the bounds of `semantic-complete-inline-overlay', or within
+ a reasonable distance."
+ (condition-case nil
+ ;; Exit if something bad happened.
+ (if (not semantic-complete-inline-overlay)
+ (progn
+ ;;(message "Inline Hook installed, but overlay deleted.")
+ (semantic-complete-inline-exit))
+ ;; Exit if commands caused us to exit the area of interest
+ (let ((s (semantic-overlay-start semantic-complete-inline-overlay))
+ (e (semantic-overlay-end semantic-complete-inline-overlay))
+ (b (semantic-overlay-buffer semantic-complete-inline-overlay))
+ (txt nil)
+ )
+ (cond
+ ;; EXIT when we are no longer in a good place.
+ ((or (not (eq b (current-buffer)))
+ (< (point) s)
+ (> (point) e))
+ ;;(message "Exit: %S %S %S" s e (point))
+ (semantic-complete-inline-exit)
+ )
+ ;; Exit if the user typed in a character that is not part
+ ;; of the symbol being completed.
+ ((and (setq txt (semantic-completion-text))
+ (not (string= txt ""))
+ (and (/= (point) s)
+ (save-excursion
+ (forward-char -1)
+ (not (looking-at "\\(\\w\\|\\s_\\)")))))
+ ;;(message "Non symbol character.")
+ (semantic-complete-inline-exit))
+ ((lookup-key semantic-complete-inline-map
+ (this-command-keys) nil)
+ ;; If the last command was one of our completion commands,
+ ;; then do nothing.
+ nil
+ )
+ (t
+ ;; Else, show completions now
+ (semantic-complete-inline-force-display)
+
+ ))))
+ ;; If something goes terribly wrong, clean up after ourselves.
+ (error (semantic-complete-inline-exit))))
+
+ (defun semantic-complete-inline-force-display ()
+ "Force the display of whatever the current completions are.
+ DO NOT CALL THIS IF THE INLINE COMPLETION ENGINE IS NOT ACTIVE."
+ (condition-case e
+ (save-excursion
+ (let ((collector semantic-completion-collector-engine)
+ (displayor semantic-completion-display-engine)
+ (contents (semantic-completion-text)))
+ (when collector
+ (semantic-collector-calculate-completions
+ collector contents nil)
+ (semantic-displayor-set-completions
+ displayor
+ (semantic-collector-all-completions collector contents)
+ contents)
+ ;; Ask the displayor to display them.
+ (semantic-displayor-show-request displayor))
+ ))
+ (error (message "Bug Showing Completions: %S" e))))
+
+ (defun semantic-complete-inline-tag-engine
+ (collector displayor buffer start end)
+ "Perform completion based on semantic tags in a buffer.
+ Argument COLLECTOR is an object which can be used to to calculate
+ a list of possible hits. See `semantic-completion-collector-engine'
+ for details on COLLECTOR.
+ Argumeng DISPLAYOR is an object used to display a list of possible
+ completions for a given prefix. See`semantic-completion-display-engine'
+ for details on DISPLAYOR.
+ BUFFER is the buffer in which completion will take place.
+ START is a location for the start of the full symbol.
+ If the symbol being completed is \"foo.ba\", then START
+ is on the \"f\" character.
+ END is at the end of the current symbol being completed."
+ ;; Set us up for doing completion
+ (setq semantic-completion-collector-engine collector
+ semantic-completion-display-engine displayor)
+ ;; Create an overlay
+ (setq semantic-complete-inline-overlay
+ (semantic-make-overlay start end buffer nil t))
+ (semantic-overlay-put semantic-complete-inline-overlay
+ 'face
+ 'semantic-complete-inline-face)
+ (semantic-overlay-put semantic-complete-inline-overlay
+ 'window-config-start
+ (current-window-configuration))
+ ;; Install our command hooks
+ (add-hook 'pre-command-hook 'semantic-complete-pre-command-hook)
+ (add-hook 'post-command-hook 'semantic-complete-post-command-hook)
+ ;; Go!
+ (semantic-complete-inline-force-display)
+ )
+
+ ;;; Inline Completion Keymap Functions
+ ;;
+ (defun semantic-complete-inline-TAB ()
+ "Perform inline completion."
+ (interactive)
+ (let ((cmpl (semantic-complete-do-completion nil t)))
+ (cond
+ ((eq cmpl 'complete)
+ (semantic-complete-inline-force-display))
+ ((eq cmpl 'done)
+ (semantic-complete-inline-done))
+ ))
+ )
+
+ (defun semantic-complete-inline-down()
+ "Focus forwards through the displayor."
+ (interactive)
+ (let ((displayor semantic-completion-display-engine))
+ (semantic-displayor-focus-next displayor)
+ (semantic-displayor-focus-request displayor)
+ ))
+
+ (defun semantic-complete-inline-up ()
+ "Focus backwards through the displayor."
+ (interactive)
+ (let ((displayor semantic-completion-display-engine))
+ (semantic-displayor-focus-previous displayor)
+ (semantic-displayor-focus-request displayor)
+ ))
+
+ \f
+ ;;; ------------------------------------------------------------
+ ;;; Interactions between collection and displaying
+ ;;
+ ;; Functional routines used to help collectors communicate with
+ ;; the current displayor, or for the previous section.
+
+ (defun semantic-complete-next-action (partial)
+ "Determine what the next completion action should be.
+ PARTIAL is non-nil if we are doing partial completion.
+ First, the collector can determine if we should perform a completion or not.
+ If there is nothing to complete, then the displayor determines if we are
+ to show a completion list, scroll, or perhaps do a focus (if it is capable.)
+ Expected return values are:
+ done -> We have a singular match
+ empty -> There are no matches to the current text
+ complete -> Perform a completion action
+ complete-whitespace -> Complete next whitespace type character.
+ display -> Show the list of completions
+ scroll -> The completions have been shown, and the user keeps hitting
+ the complete button. If possible, scroll the completions
+ focus -> The displayor knows how to shift focus among possible completions.
+ Let it do that.
+ displayend -> Whatever options the displayor had for repeating options, there
+ are none left. Try something new."
+ (let ((ans1 (semantic-collector-next-action
+ semantic-completion-collector-engine
+ partial))
+ (ans2 (semantic-displayor-next-action
+ semantic-completion-display-engine))
+ )
+ (cond
+ ;; No collector answer, use displayor answer.
+ ((not ans1)
+ ans2)
+ ;; Displayor selection of 'scroll, 'display, or 'focus trumps
+ ;; 'done
+ ((and (eq ans1 'done) ans2)
+ ans2)
+ ;; Use ans1 when we have it.
+ (t
+ ans1))))
+
+
+ \f
+ ;;; ------------------------------------------------------------
+ ;;; Collection Engines
+ ;;
+ ;; Collection engines can scan tags from the current environment and
+ ;; provide lists of possible completions.
+ ;;
+ ;; General features of the abstract collector:
+ ;; * Cache completion lists between uses
+ ;; * Cache itself per buffer. Handle reparse hooks
+ ;;
+ ;; Key Interface Functions to implement:
+ ;; * semantic-collector-next-action
+ ;; * semantic-collector-calculate-completions
+ ;; * semantic-collector-try-completion
+ ;; * semantic-collector-all-completions
+
+ (defvar semantic-collector-per-buffer-list nil
+ "List of collectors active in this buffer.")
+ (make-variable-buffer-local 'semantic-collector-per-buffer-list)
+
+ (defvar semantic-collector-list nil
+ "List of global collectors active this session.")
+
+ (defclass semantic-collector-abstract ()
+ ((buffer :initarg :buffer
+ :type buffer
+ :documentation "Originating buffer for this collector.
+ Some collectors use a given buffer as a starting place while looking up
+ tags.")
+ (cache :initform nil
+ :type (or null semanticdb-find-result-with-nil)
+ :documentation "Cache of tags.
+ These tags are re-used during a completion session.
+ Sometimes these tags are cached between completion sessions.")
+ (last-all-completions :initarg nil
+ :type semanticdb-find-result-with-nil
+ :documentation "Last result of `all-completions'.
+ This result can be used for refined completions as `last-prefix' gets
+ closer to a specific result.")
+ (last-prefix :type string
+ :protection :protected
+ :documentation "The last queried prefix.
+ This prefix can be used to cache intermediate completion offers.
+ making the action of homing in on a token faster.")
+ (last-completion :type (or null string)
+ :documentation "The last calculated completion.
+ This completion is calculated and saved for future use.")
+ (last-whitespace-completion :type (or null string)
+ :documentation "The last whitespace completion.
+ For partial completion, SPC will disabiguate over whitespace type
+ characters. This is the last calculated version.")
+ (current-exact-match :type list
+ :protection :protected
+ :documentation "The list of matched tags.
+ When tokens are matched, they are added to this list.")
+ )
+ "Root class for completion engines.
+ The baseclass provides basic functionality for interacting with
+ a completion displayor object, and tracking the current progress
+ of a completion."
+ :abstract t)
+
+ (defmethod semantic-collector-cleanup ((obj semantic-collector-abstract))
+ "Clean up any mess this collector may have."
+ nil)
+
+ (defmethod semantic-collector-next-action
+ ((obj semantic-collector-abstract) partial)
+ "What should we do next? OBJ can predict a next good action.
+ PARTIAL indicates if we are doing a partial completion."
+ (if (and (slot-boundp obj 'last-completion)
+ (string= (semantic-completion-text) (oref obj last-completion)))
+ (let* ((cem (semantic-collector-current-exact-match obj))
+ (cemlen (semanticdb-find-result-length cem))
+ (cac (semantic-collector-all-completions
+ obj (semantic-completion-text)))
+ (caclen (semanticdb-find-result-length cac)))
+ (cond ((and cem (= cemlen 1)
+ cac (> caclen 1)
+ (eq last-command this-command))
+ ;; Defer to the displayor...
+ nil)
+ ((and cem (= cemlen 1))
+ 'done)
+ ((and (not cem) (not cac))
+ 'empty)
+ ((and partial (semantic-collector-try-completion-whitespace
+ obj (semantic-completion-text)))
+ 'complete-whitespace)))
+ 'complete))
+
+ (defmethod semantic-collector-last-prefix= ((obj semantic-collector-abstract)
+ last-prefix)
+ "Return non-nil if OBJ's prefix matches PREFIX."
+ (and (slot-boundp obj 'last-prefix)
+ (string= (oref obj last-prefix) last-prefix)))
+
+ (defmethod semantic-collector-get-cache ((obj semantic-collector-abstract))
+ "Get the raw cache of tags for completion.
+ Calculate the cache if there isn't one."
+ (or (oref obj cache)
+ (semantic-collector-calculate-cache obj)))
+
+ (defmethod semantic-collector-calculate-completions-raw
+ ((obj semantic-collector-abstract) prefix completionlist)
+ "Calculate the completions for prefix from completionlist.
+ Output must be in semanticdb Find result format."
+ ;; Must output in semanticdb format
+ (let ((table (save-excursion
+ (set-buffer (oref obj buffer))
+ semanticdb-current-table))
+ (result (semantic-find-tags-for-completion
+ prefix
+ ;; To do this kind of search with a pre-built completion
+ ;; list, we need to strip it first.
+ (semanticdb-strip-find-results completionlist)))
+ )
+ (if result
+ (list (cons table result)))))
+
+ (defmethod semantic-collector-calculate-completions
+ ((obj semantic-collector-abstract) prefix partial)
+ "Calculate completions for prefix as setup for other queries."
+ (let* ((case-fold-search semantic-case-fold)
+ (same-prefix-p (semantic-collector-last-prefix= obj prefix))
+ (completionlist
+ (if (or same-prefix-p
+ (and (slot-boundp obj 'last-prefix)
+ (eq (compare-strings (oref obj last-prefix) 0 nil
+ prefix 0 (length prefix))
+ t)))
+ ;; New prefix is subset of old prefix
+ (oref obj last-all-completions)
+ (semantic-collector-get-cache obj)))
+ ;; Get the result
+ (answer (if same-prefix-p
+ completionlist
+ (semantic-collector-calculate-completions-raw
+ obj prefix completionlist))
+ )
+ (completion nil)
+ (complete-not-uniq nil)
+ )
+ ;;(semanticdb-find-result-test answer)
+ (when (not same-prefix-p)
+ ;; Save results if it is interesting and beneficial
+ (oset obj last-prefix prefix)
+ (oset obj last-all-completions answer))
+ ;; Now calculate the completion.
+ (setq completion (try-completion
+ prefix
+ (semanticdb-strip-find-results answer)))
+ (oset obj last-whitespace-completion nil)
+ (oset obj current-exact-match nil)
+ ;; Only do this if a completion was found. Letting a nil in
+ ;; could cause a full semanticdb search by accident.
+ (when completion
+ (oset obj last-completion
+ (cond
+ ;; Unique match in AC. Last completion is a match.
+ ;; Also set the current-exact-match.
+ ((eq completion t)
+ (oset obj current-exact-match answer)
+ prefix)
+ ;; It may be complete (a symbol) but still not unique.
+ ;; We can capture a match
+ ((setq complete-not-uniq
+ (semanticdb-find-tags-by-name
+ prefix
+ answer))
+ (oset obj current-exact-match
+ complete-not-uniq)
+ prefix
+ )
+ ;; Non unique match, return the string that handles
+ ;; completion
+ (t (or completion prefix))
+ )))
+ ))
+
+ (defmethod semantic-collector-try-completion-whitespace
+ ((obj semantic-collector-abstract) prefix)
+ "For OBJ, do whatepsace completion based on PREFIX.
+ This implies that if there are two completions, one matching
+ the test \"preifx\\>\", and one not, the one matching the full
+ word version of PREFIX will be chosen, and that text returned.
+ This function requires that `semantic-collector-calculate-completions'
+ has been run first."
+ (let* ((ac (semantic-collector-all-completions obj prefix))
+ (matchme (concat "^" prefix "\\>"))
+ (compare (semanticdb-find-tags-by-name-regexp matchme ac))
+ (numtag (semanticdb-find-result-length compare))
+ )
+ (if compare
+ (let* ((idx 0)
+ (cutlen (1+ (length prefix)))
+ (twws (semanticdb-find-result-nth compare idx)))
+ ;; Is our tag with whitespace a match that has whitespace
+ ;; after it, or just an already complete symbol?
+ (while (and (< idx numtag)
+ (< (length (semantic-tag-name (car twws))) cutlen))
+ (setq idx (1+ idx)
+ twws (semanticdb-find-result-nth compare idx)))
+ (when (and twws (car-safe twws))
+ ;; If COMPARE has succeeded, then we should take the very
+ ;; first match, and extend prefix by one character.
+ (oset obj last-whitespace-completion
+ (substring (semantic-tag-name (car twws))
+ 0 cutlen))))
+ )))
+
+
+ (defmethod semantic-collector-current-exact-match ((obj semantic-collector-abstract))
+ "Return the active valid MATCH from the semantic collector.
+ For now, just return the first element from our list of available
+ matches. For semanticdb based results, make sure the file is loaded
+ into a buffer."
+ (when (slot-boundp obj 'current-exact-match)
+ (oref obj current-exact-match)))
+
+ (defmethod semantic-collector-current-whitespace-completion ((obj semantic-collector-abstract))
+ "Return the active whitespace completion value."
+ (when (slot-boundp obj 'last-whitespace-completion)
+ (oref obj last-whitespace-completion)))
+
+ (defmethod semantic-collector-get-match ((obj semantic-collector-abstract))
+ "Return the active valid MATCH from the semantic collector.
+ For now, just return the first element from our list of available
+ matches. For semanticdb based results, make sure the file is loaded
+ into a buffer."
+ (when (slot-boundp obj 'current-exact-match)
+ (semanticdb-find-result-nth-in-buffer (oref obj current-exact-match) 0)))
+
+ (defmethod semantic-collector-all-completions
+ ((obj semantic-collector-abstract) prefix)
+ "For OBJ, retrieve all completions matching PREFIX.
+ The returned list consists of all the tags currently
+ matching PREFIX."
+ (when (slot-boundp obj 'last-all-completions)
+ (oref obj last-all-completions)))
+
+ (defmethod semantic-collector-try-completion
+ ((obj semantic-collector-abstract) prefix)
+ "For OBJ, attempt to match PREFIX.
+ See `try-completion' for details on how this works.
+ Return nil for no match.
+ Return a string for a partial match.
+ For a unique match of PREFIX, return the list of all tags
+ with that name."
+ (if (slot-boundp obj 'last-completion)
+ (oref obj last-completion)))
+
+ (defmethod semantic-collector-calculate-cache
+ ((obj semantic-collector-abstract))
+ "Calculate the completion cache for OBJ."
+ nil
+ )
+
+ (defmethod semantic-collector-flush ((this semantic-collector-abstract))
+ "Flush THIS collector object, clearing any caches and prefix."
+ (oset this cache nil)
+ (slot-makeunbound this 'last-prefix)
+ (slot-makeunbound this 'last-completion)
+ (slot-makeunbound this 'last-all-completions)
+ (slot-makeunbound this 'current-exact-match)
+ )
+
+ ;;; PER BUFFER
+ ;;
+ (defclass semantic-collector-buffer-abstract (semantic-collector-abstract)
+ ()
+ "Root class for per-buffer completion engines.
+ These collectors track themselves on a per-buffer basis."
+ :abstract t)
+
+ (defmethod constructor :STATIC ((this semantic-collector-buffer-abstract)
+ newname &rest fields)
+ "Reuse previously created objects of this type in buffer."
+ (let ((old nil)
+ (bl semantic-collector-per-buffer-list))
+ (while (and bl (null old))
+ (if (eq (object-class (car bl)) this)
+ (setq old (car bl))))
+ (unless old
+ (let ((new (call-next-method)))
+ (add-to-list 'semantic-collector-per-buffer-list new)
+ (setq old new)))
+ (slot-makeunbound old 'last-completion)
+ (slot-makeunbound old 'last-prefix)
+ (slot-makeunbound old 'current-exact-match)
+ old))
+
+ ;; Buffer specific collectors should flush themselves
+ (defun semantic-collector-buffer-flush (newcache)
+ "Flush all buffer collector objects.
+ NEWCACHE is the new tag table, but we ignore it."
+ (condition-case nil
+ (let ((l semantic-collector-per-buffer-list))
+ (while l
+ (if (car l) (semantic-collector-flush (car l)))
+ (setq l (cdr l))))
+ (error nil)))
+
+ (add-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-collector-buffer-flush)
+
+ ;;; DEEP BUFFER SPECIFIC COMPLETION
+ ;;
+ (defclass semantic-collector-buffer-deep
+ (semantic-collector-buffer-abstract)
+ ()
+ "Completion engine for tags in the current buffer.
+ When searching for a tag, uses semantic deep searche functions.
+ Basics search only in the current buffer.")
+
+ (defmethod semantic-collector-calculate-cache
+ ((obj semantic-collector-buffer-deep))
+ "Calculate the completion cache for OBJ.
+ Uses `semantic-flatten-tags-table'"
+ (oset obj cache
+ ;; Must create it in SEMANTICDB find format.
+ ;; ( ( DBTABLE TAG TAG ... ) ... )
+ (list
+ (cons semanticdb-current-table
+ (semantic-flatten-tags-table (oref obj buffer))))))
+
+ ;;; PROJECT SPECIFIC COMPLETION
+ ;;
+ (defclass semantic-collector-project-abstract (semantic-collector-abstract)
+ ((path :initarg :path
+ :initform nil
+ :documentation "List of database tables to search.
+ At creation time, it can be anything accepted by
+ `semanticdb-find-translate-path' as a PATH argument.")
+ )
+ "Root class for project wide completion engines.
+ Uses semanticdb for searching all tags in the current project."
+ :abstract t)
+
+ ;;; Project Search
+ (defclass semantic-collector-project (semantic-collector-project-abstract)
+ ()
+ "Completion engine for tags in a project.")
+
+
+ (defmethod semantic-collector-calculate-completions-raw
+ ((obj semantic-collector-project) prefix completionlist)
+ "Calculate the completions for prefix from completionlist."
+ (semanticdb-find-tags-for-completion prefix (oref obj path)))
+
+ ;;; Brutish Project search
+ (defclass semantic-collector-project-brutish (semantic-collector-project-abstract)
+ ()
+ "Completion engine for tags in a project.")
+
+ (declare-function semanticdb-brute-deep-find-tags-for-completion
+ "semantic/db-find")
+
+ (defmethod semantic-collector-calculate-completions-raw
+ ((obj semantic-collector-project-brutish) prefix completionlist)
+ "Calculate the completions for prefix from completionlist."
+ (require 'semantic/db-find)
+ (semanticdb-brute-deep-find-tags-for-completion prefix (oref obj path)))
+
+ (defclass semantic-collector-analyze-completions (semantic-collector-abstract)
+ ((context :initarg :context
+ :type semantic-analyze-context
+ :documentation "An analysis context.
+ Specifies some context location from whence completion lists will be drawn."
+ )
+ (first-pass-completions :type list
+ :documentation "List of valid completion tags.
+ This list of tags is generated when completion starts. All searches
+ derive from this list.")
+ )
+ "Completion engine that uses the context analyzer to provide options.
+ The only options available for completion are those which can be logically
+ inserted into the current context.")
+
+ (defmethod semantic-collector-calculate-completions-raw
+ ((obj semantic-collector-analyze-completions) prefix completionlist)
+ "calculate the completions for prefix from completionlist."
+ ;; if there are no completions yet, calculate them.
+ (if (not (slot-boundp obj 'first-pass-completions))
+ (oset obj first-pass-completions
+ (semantic-analyze-possible-completions (oref obj context))))
+ ;; search our cached completion list. make it look like a semanticdb
+ ;; results type.
+ (list (cons (save-excursion
+ (set-buffer (oref (oref obj context) buffer))
+ semanticdb-current-table)
+ (semantic-find-tags-for-completion
+ prefix
+ (oref obj first-pass-completions)))))
+
+ \f
+ ;;; ------------------------------------------------------------
+ ;;; Tag List Display Engines
+ ;;
+ ;; A typical displayor accepts a pre-determined list of completions
+ ;; generated by a collector. This format is in semanticdb search
+ ;; form. This vaguely standard form is a bit challenging to navigate
+ ;; because the tags do not contain buffer info, but the file assocated
+ ;; with the tags preceed the tag in the list.
+ ;;
+ ;; Basic displayors don't care, and can strip the results.
+ ;; Advanced highlighting displayors need to know when they need
+ ;; to load a file so that the tag in question can be highlighted.
+ ;;
+ ;; Key interface methods to a displayor are:
+ ;; * semantic-displayor-next-action
+ ;; * semantic-displayor-set-completions
+ ;; * semantic-displayor-current-focus
+ ;; * semantic-displayor-show-request
+ ;; * semantic-displayor-scroll-request
+ ;; * semantic-displayor-focus-request
+
+ (defclass semantic-displayor-abstract ()
+ ((table :type (or null semanticdb-find-result-with-nil)
+ :initform nil
+ :protection :protected
+ :documentation "List of tags this displayor is showing.")
+ (last-prefix :type string
+ :protection :protected
+ :documentation "Prefix associated with slot `table'")
+ )
+ "Abstract displayor baseclass.
+ Manages the display of some number of tags.
+ Provides the basics for a displayor, including interacting with
+ a collector, and tracking tables of completion to display."
+ :abstract t)
+
+ (defmethod semantic-displayor-cleanup ((obj semantic-displayor-abstract))
+ "Clean up any mess this displayor may have."
+ nil)
+
+ (defmethod semantic-displayor-next-action ((obj semantic-displayor-abstract))
+ "The next action to take on the minibuffer related to display."
+ (if (and (slot-boundp obj 'last-prefix)
+ (string= (oref obj last-prefix) (semantic-completion-text))
+ (eq last-command this-command))
+ 'scroll
+ 'display))
+
+ (defmethod semantic-displayor-set-completions ((obj semantic-displayor-abstract)
+ table prefix)
+ "Set the list of tags to be completed over to TABLE."
+ (oset obj table table)
+ (oset obj last-prefix prefix))
+
+ (defmethod semantic-displayor-show-request ((obj semantic-displayor-abstract))
+ "A request to show the current tags table."
+ (ding))
+
+ (defmethod semantic-displayor-focus-request ((obj semantic-displayor-abstract))
+ "A request to for the displayor to focus on some tag option."
+ (ding))
+
+ (defmethod semantic-displayor-scroll-request ((obj semantic-displayor-abstract))
+ "A request to for the displayor to scroll the completion list (if needed)."
+ (scroll-other-window))
+
+ (defmethod semantic-displayor-focus-previous ((obj semantic-displayor-abstract))
+ "Set the current focus to the previous item."
+ nil)
+
+ (defmethod semantic-displayor-focus-next ((obj semantic-displayor-abstract))
+ "Set the current focus to the next item."
+ nil)
+
+ (defmethod semantic-displayor-current-focus ((obj semantic-displayor-abstract))
+ "Return a single tag currently in focus.
+ This object type doesn't do focus, so will never have a focus object."
+ nil)
+
+ ;; Traditional displayor
+ (defcustom semantic-completion-displayor-format-tag-function
+ #'semantic-format-tag-name
+ "*A Tag format function to use when showing completions."
+ :group 'semantic
+ :type semantic-format-tag-custom-list)
+
+ (defclass semantic-displayor-traditional (semantic-displayor-abstract)
+ ()
+ "Display options in *Completions* buffer.
+ Traditional display mechanism for a list of possible completions.
+ Completions are showin in a new buffer and listed with the ability
+ to click on the items to aid in completion.")
+
+ (defmethod semantic-displayor-show-request ((obj semantic-displayor-traditional))
+ "A request to show the current tags table."
+
+ ;; NOTE TO SELF. Find the character to type next, and emphesize it.
+
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list
+ (mapcar semantic-completion-displayor-format-tag-function
+ (semanticdb-strip-find-results (oref obj table))))
+ )
+ )
+
+ ;;; Abstract baseclass for any displayor which supports focus
+ (defclass semantic-displayor-focus-abstract (semantic-displayor-abstract)
+ ((focus :type number
+ :protection :protected
+ :documentation "A tag index from `table' which has focus.
+ Multiple calls to the display function can choose to focus on a
+ given tag, by highlighting its location.")
+ (find-file-focus
+ :allocation :class
+ :initform nil
+ :documentation
+ "Non-nil if focusing requires a tag's buffer be in memory.")
+ )
+ "Abstract displayor supporting `focus'.
+ A displayor which has the ability to focus in on one tag.
+ Focusing is a way of differentiationg between multiple tags
+ which have the same name."
+ :abstract t)
+
+ (defmethod semantic-displayor-next-action ((obj semantic-displayor-focus-abstract))
+ "The next action to take on the minibuffer related to display."
+ (if (and (slot-boundp obj 'last-prefix)
+ (string= (oref obj last-prefix) (semantic-completion-text))
+ (eq last-command this-command))
+ (if (and
+ (slot-boundp obj 'focus)
+ (slot-boundp obj 'table)
+ (<= (semanticdb-find-result-length (oref obj table))
+ (1+ (oref obj focus))))
+ ;; We are at the end of the focus road.
+ 'displayend
+ ;; Focus on some item.
+ 'focus)
+ 'display))
+
+ (defmethod semantic-displayor-set-completions ((obj semantic-displayor-focus-abstract)
+ table prefix)
+ "Set the list of tags to be completed over to TABLE."
+ (call-next-method)
+ (slot-makeunbound obj 'focus))
+
+ (defmethod semantic-displayor-focus-previous ((obj semantic-displayor-focus-abstract))
+ "Set the current focus to the previous item.
+ Not meaningful return value."
+ (when (and (slot-boundp obj 'table) (oref obj table))
+ (with-slots (table) obj
+ (if (or (not (slot-boundp obj 'focus))
+ (<= (oref obj focus) 0))
+ (oset obj focus (1- (semanticdb-find-result-length table)))
+ (oset obj focus (1- (oref obj focus)))
+ )
+ )))
+
+ (defmethod semantic-displayor-focus-next ((obj semantic-displayor-focus-abstract))
+ "Set the current focus to the next item.
+ Not meaningful return value."
+ (when (and (slot-boundp obj 'table) (oref obj table))
+ (with-slots (table) obj
+ (if (not (slot-boundp obj 'focus))
+ (oset obj focus 0)
+ (oset obj focus (1+ (oref obj focus)))
+ )
+ (if (<= (semanticdb-find-result-length table) (oref obj focus))
+ (oset obj focus 0))
+ )))
+
+ (defmethod semantic-displayor-focus-tag ((obj semantic-displayor-focus-abstract))
+ "Return the next tag OBJ should focus on."
+ (when (and (slot-boundp obj 'table) (oref obj table))
+ (with-slots (table) obj
+ (semanticdb-find-result-nth table (oref obj focus)))))
+
+ (defmethod semantic-displayor-current-focus ((obj semantic-displayor-focus-abstract))
+ "Return the tag currently in focus, or call parent method."
+ (if (and (slot-boundp obj 'focus)
+ (slot-boundp obj 'table)
+ ;; Only return the current focus IFF the minibuffer reflects
+ ;; the list this focus was derived from.
+ (slot-boundp obj 'last-prefix)
+ (string= (semantic-completion-text) (oref obj last-prefix))
+ )
+ ;; We need to focus
+ (if (oref obj find-file-focus)
+ (semanticdb-find-result-nth-in-buffer (oref obj table) (oref obj focus))
+ ;; result-nth returns a cons with car being the tag, and cdr the
+ ;; database.
+ (car (semanticdb-find-result-nth (oref obj table) (oref obj focus))))
+ ;; Do whatever
+ (call-next-method)))
+
+ ;;; Simple displayor which performs traditional display completion,
+ ;; and also focuses with highlighting.
+ (defclass semantic-displayor-traditional-with-focus-highlight
+ (semantic-displayor-focus-abstract semantic-displayor-traditional)
+ ((find-file-focus :initform t))
+ "Display completions in *Completions* buffer, with focus highlight.
+ A traditional displayor which can focus on a tag by showing it.
+ Same as `semantic-displayor-traditional', but with selection between
+ multiple tags with the same name done by 'focusing' on the source
+ location of the different tags to differentiate them.")
+
+ (defmethod semantic-displayor-focus-request
+ ((obj semantic-displayor-traditional-with-focus-highlight))
+ "Focus in on possible tag completions.
+ Focus is performed by cycling through the tags and highlighting
+ one in the source buffer."
+ (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
+ (focus (semantic-displayor-focus-tag obj))
+ ;; Raw tag info.
+ (rtag (car focus))
+ (rtable (cdr focus))
+ ;; Normalize
+ (nt (semanticdb-normalize-one-tag rtable rtag))
+ (tag (cdr nt))
+ (table (car nt))
+ )
+ ;; If we fail to normalize, resete.
+ (when (not tag) (setq table rtable tag rtag))
+ ;; Do the focus.
+ (let ((buf (or (semantic-tag-buffer tag)
+ (and table (semanticdb-get-buffer table)))))
+ ;; If no buffer is provided, then we can make up a summary buffer.
+ (when (not buf)
+ (save-excursion
+ (set-buffer (get-buffer-create "*Completion Focus*"))
+ (erase-buffer)
+ (insert "Focus on tag: \n")
+ (insert (semantic-format-tag-summarize tag nil t) "\n\n")
+ (when table
+ (insert "From table: \n")
+ (insert (object-name table) "\n\n"))
+ (when buf
+ (insert "In buffer: \n\n")
+ (insert (format "%S" buf)))
+ (setq buf (current-buffer))))
+ ;; Show the tag in the buffer.
+ (if (get-buffer-window buf)
+ (select-window (get-buffer-window buf))
+ (switch-to-buffer-other-window buf t)
+ (select-window (get-buffer-window buf)))
+ ;; Now do some positioning
+ (unwind-protect
+ (if (semantic-tag-with-position-p tag)
+ ;; Full tag positional information available
+ (progn
+ (goto-char (semantic-tag-start tag))
+ ;; This avoids a dangerous problem if we just loaded a tag
+ ;; from a file, but the original position was not updated
+ ;; in the TAG variable we are currently using.
+ (semantic-momentary-highlight-tag (semantic-current-tag))
+ ))
+ (select-window (minibuffer-window)))
+ ;; Calculate text difference between contents and the focus item.
+ (let* ((mbc (semantic-completion-text))
+ (ftn (semantic-tag-name tag))
+ (diff (substring ftn (length mbc))))
+ (semantic-completion-message
+ (format "%s [%d of %d matches]" diff (1+ (oref obj focus)) tablelength)))
+ )))
+
+ \f
+ ;;; Tooltip completion lister
+ ;;
+ ;; Written and contributed by Masatake YAMATO <jet@gyve.org>
+ ;;
+ ;; Modified by Eric Ludlam for
+ ;; * Safe compatibility for tooltip free systems.
+ ;; * Don't use 'avoid package for tooltip positioning.
+
+ (defclass semantic-displayor-tooltip (semantic-displayor-traditional)
+ ((max-tags :type integer
+ :initarg :max-tags
+ :initform 5
+ :custom integer
+ :documentation
+ "Max number of tags displayed on tooltip at once.
+ If `force-show' is 1, this value is ignored with typing tab or space twice continuously.
+ if `force-show' is 0, this value is always ignored.")
+ (force-show :type integer
+ :initarg :force-show
+ :initform 1
+ :custom (choice (const
+ :tag "Show when double typing"
+ 1)
+ (const
+ :tag "Show always"
+ 0)
+ (const
+ :tag "Show if the number of tags is less than `max-tags'."
+ -1))
+ :documentation
+ "Control the behavior of the number of tags is greater than `max-tags'.
+ -1 means tags are never shown.
+ 0 means the tags are always shown.
+ 1 means tags are shown if space or tab is typed twice continuously.")
+ (typing-count :type integer
+ :initform 0
+ :documentation
+ "Counter holding how many times the user types space or tab continuously before showing tags.")
+ (shown :type boolean
+ :initform nil
+ :documentation
+ "Flag representing whether tags is shown once or not.")
+ )
+ "Display completions options in a tooltip.
+ Display mechanism using tooltip for a list of possible completions.")
+
+ (defmethod initialize-instance :AFTER ((obj semantic-displayor-tooltip) &rest args)
+ "Make sure we have tooltips required."
+ (condition-case nil
+ (require 'tooltip)
+ (error nil))
+ )
+
+ (defmethod semantic-displayor-show-request ((obj semantic-displayor-tooltip))
+ "A request to show the current tags table."
+ (if (or (not (featurep 'tooltip)) (not tooltip-mode))
+ ;; If we cannot use tooltips, then go to the normal mode with
+ ;; a traditional completion buffer.
+ (call-next-method)
+ (let* ((tablelong (semanticdb-strip-find-results (oref obj table)))
+ (table (semantic-unique-tag-table-by-name tablelong))
+ (l (mapcar semantic-completion-displayor-format-tag-function table))
+ (ll (length l))
+ (typing-count (oref obj typing-count))
+ (force-show (oref obj force-show))
+ (matchtxt (semantic-completion-text))
+ msg)
+ (if (or (oref obj shown)
+ (< ll (oref obj max-tags))
+ (and (<= 0 force-show)
+ (< (1- force-show) typing-count)))
+ (progn
+ (oset obj typing-count 0)
+ (oset obj shown t)
+ (if (eq 1 ll)
+ ;; We Have only one possible match. There could be two cases.
+ ;; 1) input text != single match.
+ ;; --> Show it!
+ ;; 2) input text == single match.
+ ;; --> Complain about it, but still show the match.
+ (if (string= matchtxt (semantic-tag-name (car table)))
+ (setq msg (concat "[COMPLETE]\n" (car l)))
+ (setq msg (car l)))
+ ;; Create the long message.
+ (setq msg (mapconcat 'identity l "\n"))
+ ;; If there is nothing, say so!
+ (if (eq 0 (length msg))
+ (setq msg "[NO MATCH]")))
+ (semantic-displayor-tooltip-show msg))
+ ;; The typing count determines if the user REALLY REALLY
+ ;; wanted to show that much stuff. Only increment
+ ;; if the current command is a completion command.
+ (if (and (stringp (this-command-keys))
+ (string= (this-command-keys) "\C-i"))
+ (oset obj typing-count (1+ typing-count)))
+ ;; At this point, we know we have too many items.
+ ;; Lets be brave, and truncate l
+ (setcdr (nthcdr (oref obj max-tags) l) nil)
+ (setq msg (mapconcat 'identity l "\n"))
+ (cond
+ ((= force-show -1)
+ (semantic-displayor-tooltip-show (concat msg "\n...")))
+ ((= force-show 1)
+ (semantic-displayor-tooltip-show (concat msg "\n(TAB for more)")))
+ )))))
+
+ ;;; Compatibility
+ ;;
+ (eval-and-compile
+ (if (fboundp 'window-inside-edges)
+ ;; Emacs devel.
+ (defalias 'semantic-displayor-window-edges
+ 'window-inside-edges)
+ ;; Emacs 21
+ (defalias 'semantic-displayor-window-edges
+ 'window-edges)
+ ))
+
+ (defun semantic-displayor-point-position ()
+ "Return the location of POINT as positioned on the selected frame.
+ Return a cons cell (X . Y)"
+ (let* ((frame (selected-frame))
+ (left (frame-parameter frame 'left))
+ (top (frame-parameter frame 'top))
+ (point-pix-pos (posn-x-y (posn-at-point)))
+ (edges (window-inside-pixel-edges (selected-window))))
+ (cons (+ (car point-pix-pos) (car edges) left)
+ (+ (cdr point-pix-pos) (cadr edges) top))))
+
+
+ (defun semantic-displayor-tooltip-show (text)
+ "Display a tooltip with TEXT near cursor."
+ (let ((point-pix-pos (semantic-displayor-point-position))
+ (tooltip-frame-parameters
+ (append tooltip-frame-parameters nil)))
+ (push
+ (cons 'left (+ (car point-pix-pos) (frame-char-width)))
+ tooltip-frame-parameters)
+ (push
+ (cons 'top (+ (cdr point-pix-pos) (frame-char-height)))
+ tooltip-frame-parameters)
+ (tooltip-show text)))
+
+ (defmethod semantic-displayor-scroll-request ((obj semantic-displayor-tooltip))
+ "A request to for the displayor to scroll the completion list (if needed)."
+ ;; Do scrolling in the tooltip.
+ (oset obj max-tags 30)
+ (semantic-displayor-show-request obj)
+ )
+
+ ;; End code contributed by Masatake YAMATO <jet@gyve.org>
+
+ \f
+ ;;; Ghost Text displayor
+ ;;
+ (defclass semantic-displayor-ghost (semantic-displayor-focus-abstract)
+
+ ((ghostoverlay :type overlay
+ :documentation
+ "The overlay the ghost text is displayed in.")
+ (first-show :initform t
+ :documentation
+ "Non nil if we have not seen our first show request.")
+ )
+ "Cycle completions inline with ghost text.
+ Completion displayor using ghost chars after point for focus options.
+ Whichever completion is currently in focus will be displayed as ghost
+ text using overlay options.")
+
+ (defmethod semantic-displayor-next-action ((obj semantic-displayor-ghost))
+ "The next action to take on the inline completion related to display."
+ (let ((ans (call-next-method))
+ (table (when (slot-boundp obj 'table)
+ (oref obj table))))
+ (if (and (eq ans 'displayend)
+ table
+ (= (semanticdb-find-result-length table) 1)
+ )
+ nil
+ ans)))
+
+ (defmethod semantic-displayor-cleanup ((obj semantic-displayor-ghost))
+ "Clean up any mess this displayor may have."
+ (when (slot-boundp obj 'ghostoverlay)
+ (semantic-overlay-delete (oref obj ghostoverlay)))
+ )
+
+ (defmethod semantic-displayor-set-completions ((obj semantic-displayor-ghost)
+ table prefix)
+ "Set the list of tags to be completed over to TABLE."
+ (call-next-method)
+
+ (semantic-displayor-cleanup obj)
+ )
+
+
+ (defmethod semantic-displayor-show-request ((obj semantic-displayor-ghost))
+ "A request to show the current tags table."
+ ; (if (oref obj first-show)
+ ; (progn
+ ; (oset obj first-show nil)
+ (semantic-displayor-focus-next obj)
+ (semantic-displayor-focus-request obj)
+ ; )
+ ;; Only do the traditional thing if the first show request
+ ;; has been seen. Use the first one to start doing the ghost
+ ;; text display.
+ ; (call-next-method)
+ ; )
+ )
+
+ (defmethod semantic-displayor-focus-request
+ ((obj semantic-displayor-ghost))
+ "Focus in on possible tag completions.
+ Focus is performed by cycling through the tags and showing a possible
+ completion text in ghost text."
+ (let* ((tablelength (semanticdb-find-result-length (oref obj table)))
+ (focus (semantic-displayor-focus-tag obj))
+ (tag (car focus))
+ )
+ (if (not tag)
+ (semantic-completion-message "No tags to focus on.")
+ ;; Display the focus completion as ghost text after the current
+ ;; inline text.
+ (when (or (not (slot-boundp obj 'ghostoverlay))
+ (not (semantic-overlay-live-p (oref obj ghostoverlay))))
+ (oset obj ghostoverlay
+ (semantic-make-overlay (point) (1+ (point)) (current-buffer) t)))
+
+ (let* ((lp (semantic-completion-text))
+ (os (substring (semantic-tag-name tag) (length lp)))
+ (ol (oref obj ghostoverlay))
+ )
+
+ (put-text-property 0 (length os) 'face 'region os)
+
+ (semantic-overlay-put
+ ol 'display (concat os (buffer-substring (point) (1+ (point)))))
+ )
+ ;; Calculate text difference between contents and the focus item.
+ (let* ((mbc (semantic-completion-text))
+ (ftn (concat (semantic-tag-name tag)))
+ )
+ (put-text-property (length mbc) (length ftn) 'face
+ 'bold ftn)
+ (semantic-completion-message
+ (format "%s [%d of %d matches]" ftn (1+ (oref obj focus)) tablelength)))
+ )))
+
+ \f
+ ;;; ------------------------------------------------------------
+ ;;; Specific queries
+ ;;
+ (defvar semantic-complete-inline-custom-type
+ (append '(radio)
+ (mapcar
+ (lambda (class)
+ (let* ((C (intern (car class)))
+ (doc (documentation-property C 'variable-documentation))
+ (doc1 (car (split-string doc "\n")))
+ )
+ (list 'const
+ :tag doc1
+ C)))
+ (eieio-build-class-alist semantic-displayor-abstract t))
+ )
+ "Possible options for inlince completion displayors.
+ Use this to enable custom editing.")
+
+ (defcustom semantic-complete-inline-analyzer-displayor-class
+ 'semantic-displayor-traditional
+ "*Class for displayor to use with inline completion."
+ :group 'semantic
+ :type semantic-complete-inline-custom-type
+ )
+
+ (defun semantic-complete-read-tag-buffer-deep (prompt &optional
+ default-tag
+ initial-input
+ history)
+ "Ask for a tag by name from the current buffer.
+ Available tags are from the current buffer, at any level.
+ Completion options are presented in a traditional way, with highlighting
+ to resolve same-name collisions.
+ PROMPT is a string to prompt with.
+ DEFAULT-TAG is a semantic tag or string to use as the default value.
+ If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
+ HISTORY is a symbol representing a variable to store the history in."
+ (semantic-complete-read-tag-engine
+ (semantic-collector-buffer-deep prompt :buffer (current-buffer))
+ (semantic-displayor-traditional-with-focus-highlight "simple")
+ ;;(semantic-displayor-tooltip "simple")
+ prompt
+ default-tag
+ initial-input
+ history)
+ )
+
+ (defun semantic-complete-read-tag-project (prompt &optional
+ default-tag
+ initial-input
+ history)
+ "Ask for a tag by name from the current project.
+ Available tags are from the current project, at the top level.
+ Completion options are presented in a traditional way, with highlighting
+ to resolve same-name collisions.
+ PROMPT is a string to prompt with.
+ DEFAULT-TAG is a semantic tag or string to use as the default value.
+ If INITIAL-INPUT is non-nil, insert it in the minibuffer initially.
+ HISTORY is a symbol representing a variable to store the history in."
+ (semantic-complete-read-tag-engine
+ (semantic-collector-project-brutish prompt
+ :buffer (current-buffer)
+ :path (current-buffer)
+ )
+ (semantic-displayor-traditional-with-focus-highlight "simple")
+ prompt
+ default-tag
+ initial-input
+ history)
+ )
+
+ (defun semantic-complete-inline-tag-project ()
+ "Complete a symbol name by name from within the current project.
+ This is similar to `semantic-complete-read-tag-project', except
+ that the completion interaction is in the buffer where the context
+ was calculated from.
+ Customize `semantic-complete-inline-analyzer-displayor-class'
+ to control how completion options are displayed.
+ See `semantic-complete-inline-tag-engine' for details on how
+ completion works."
+ (let* ((collector (semantic-collector-project-brutish
+ "inline"
+ :buffer (current-buffer)
+ :path (current-buffer)))
+ (sbounds (semantic-ctxt-current-symbol-and-bounds))
+ (syms (car sbounds))
+ (start (car (nth 2 sbounds)))
+ (end (cdr (nth 2 sbounds)))
+ (rsym (reverse syms))
+ (thissym (nth 1 sbounds))
+ (nextsym (car-safe (cdr rsym)))
+ (complst nil))
+ (when (and thissym (or (not (string= thissym ""))
+ nextsym))
+ ;; Do a quick calcuation of completions.
+ (semantic-collector-calculate-completions
+ collector thissym nil)
+ ;; Get the master list
+ (setq complst (semanticdb-strip-find-results
+ (semantic-collector-all-completions collector thissym)))
+ ;; Shorten by name
+ (setq complst (semantic-unique-tag-table-by-name complst))
+ (if (or (and (= (length complst) 1)
+ ;; Check to see if it is the same as what is there.
+ ;; if so, we can offer to complete.
+ (let ((compname (semantic-tag-name (car complst))))
+ (not (string= compname thissym))))
+ (> (length complst) 1))
+ ;; There are several options. Do the completion.
+ (semantic-complete-inline-tag-engine
+ collector
+ (funcall semantic-complete-inline-analyzer-displayor-class
+ "inline displayor")
+ ;;(semantic-displayor-tooltip "simple")
+ (current-buffer)
+ start end))
+ )))
+
+ (defun semantic-complete-read-tag-analyzer (prompt &optional
+ context
+ history)
+ "Ask for a tag by name based on the current context.
+ The function `semantic-analyze-current-context' is used to
+ calculate the context. `semantic-analyze-possible-completions' is used
+ to generate the list of possible completions.
+ PROMPT is the first part of the prompt. Additional prompt
+ is added based on the contexts full prefix.
+ CONTEXT is the semantic analyzer context to start with.
+ HISTORY is a symbol representing a variable to stor the history in.
+ usually a default-tag and initial-input are available for completion
+ prompts. these are calculated from the CONTEXT variable passed in."
+ (if (not context) (setq context (semantic-analyze-current-context (point))))
+ (let* ((syms (semantic-ctxt-current-symbol (point)))
+ (inp (car (reverse syms))))
+ (setq syms (nreverse (cdr (nreverse syms))))
+ (semantic-complete-read-tag-engine
+ (semantic-collector-analyze-completions
+ prompt
+ :buffer (oref context buffer)
+ :context context)
+ (semantic-displayor-traditional-with-focus-highlight "simple")
+ (save-excursion
+ (set-buffer (oref context buffer))
+ (goto-char (cdr (oref context bounds)))
+ (concat prompt (mapconcat 'identity syms ".")
+ (if syms "." "")
+ ))
+ nil
+ inp
+ history)))
+
+ (defun semantic-complete-inline-analyzer (context)
+ "Complete a symbol name by name based on the current context.
+ This is similar to `semantic-complete-read-tag-analyze', except
+ that the completion interaction is in the buffer where the context
+ was calculated from.
+ CONTEXT is the semantic analyzer context to start with.
+ Customize `semantic-complete-inline-analyzer-displayor-class'
+ to control how completion options are displayed.
+
+ See `semantic-complete-inline-tag-engine' for details on how
+ completion works."
+ (if (not context) (setq context (semantic-analyze-current-context (point))))
+ (if (not context) (error "Nothing to complete on here"))
+ (let* ((collector (semantic-collector-analyze-completions
+ "inline"
+ :buffer (oref context buffer)
+ :context context))
+ (syms (semantic-ctxt-current-symbol (point)))
+ (rsym (reverse syms))
+ (thissym (car rsym))
+ (nextsym (car-safe (cdr rsym)))
+ (complst nil))
+ (when (and thissym (or (not (string= thissym ""))
+ nextsym))
+ ;; Do a quick calcuation of completions.
+ (semantic-collector-calculate-completions
+ collector thissym nil)
+ ;; Get the master list
+ (setq complst (semanticdb-strip-find-results
+ (semantic-collector-all-completions collector thissym)))
+ ;; Shorten by name
+ (setq complst (semantic-unique-tag-table-by-name complst))
+ (if (or (and (= (length complst) 1)
+ ;; Check to see if it is the same as what is there.
+ ;; if so, we can offer to complete.
+ (let ((compname (semantic-tag-name (car complst))))
+ (not (string= compname thissym))))
+ (> (length complst) 1))
+ ;; There are several options. Do the completion.
+ (semantic-complete-inline-tag-engine
+ collector
+ (funcall semantic-complete-inline-analyzer-displayor-class
+ "inline displayor")
+ ;;(semantic-displayor-tooltip "simple")
+ (oref context buffer)
+ (car (oref context bounds))
+ (cdr (oref context bounds))
+ ))
+ )))
+
+ (defcustom semantic-complete-inline-analyzer-idle-displayor-class
+ 'semantic-displayor-ghost
+ "*Class for displayor to use with inline completion at idle time."
+ :group 'semantic
+ :type semantic-complete-inline-custom-type
+ )
+
+ (defun semantic-complete-inline-analyzer-idle (context)
+ "Complete a symbol name by name based on the current context for idle time.
+ CONTEXT is the semantic analyzer context to start with.
+ This function is used from `semantic-idle-completions-mode'.
+
+ This is the same as `semantic-complete-inline-analyzer', except that
+ it uses `semantic-complete-inline-analyzer-idle-displayor-class'
+ to control how completions are displayed.
+
+ See `semantic-complete-inline-tag-engine' for details on how
+ completion works."
+ (let ((semantic-complete-inline-analyzer-displayor-class
+ semantic-complete-inline-analyzer-idle-displayor-class))
+ (semantic-complete-inline-analyzer context)
+ ))
+
+ \f
+ ;;;###autoload
+ (defun semantic-complete-jump-local ()
+ "Jump to a semantic symbol."
+ (interactive)
+ (let ((tag (semantic-complete-read-tag-buffer-deep "Symbol: ")))
+ (when (semantic-tag-p tag)
+ (push-mark)
+ (goto-char (semantic-tag-start tag))
+ (semantic-momentary-highlight-tag tag)
+ (message "%S: %s "
+ (semantic-tag-class tag)
+ (semantic-tag-name tag)))))
+
+ ;;;###autoload
+ (defun semantic-complete-jump ()
+ "Jump to a semantic symbol."
+ (interactive)
+ (let* ((tag (semantic-complete-read-tag-project "Symbol: ")))
+ (when (semantic-tag-p tag)
+ (push-mark)
+ (semantic-go-to-tag tag)
+ (switch-to-buffer (current-buffer))
+ (semantic-momentary-highlight-tag tag)
+ (message "%S: %s "
+ (semantic-tag-class tag)
+ (semantic-tag-name tag)))))
+
+ ;;;###autoload
+ (defun semantic-complete-analyze-and-replace ()
+ "Perform prompt completion to do in buffer completion.
+ `semantic-analyze-possible-completions' is used to determine the
+ possible values.
+ The minibuffer is used to perform the completion.
+ The result is inserted as a replacement of the text that was there."
+ (interactive)
+ (let* ((c (semantic-analyze-current-context (point)))
+ (tag (save-excursion (semantic-complete-read-tag-analyzer "" c))))
+ ;; Take tag, and replace context bound with its name.
+ (goto-char (car (oref c bounds)))
+ (delete-region (point) (cdr (oref c bounds)))
+ (insert (semantic-tag-name tag))
+ (message "%S" (semantic-format-tag-summarize tag))))
+
+ ;;;###autoload
+ (defun semantic-complete-analyze-inline ()
+ "Perform prompt completion to do in buffer completion.
+ `semantic-analyze-possible-completions' is used to determine the
+ possible values.
+ The function returns immediately, leaving the buffer in a mode that
+ will perform the completion.
+ Configure `semantic-complete-inline-analyzer-displayor-class' to change
+ how completion options are displayed."
+ (interactive)
+ ;; Only do this if we are not already completing something.
+ (if (not (semantic-completion-inline-active-p))
+ (semantic-complete-inline-analyzer
+ (semantic-analyze-current-context (point))))
+ ;; Report a message if things didn't startup.
+ (if (and (interactive-p)
+ (not (semantic-completion-inline-active-p)))
+ (message "Inline completion not needed.")
+ ;; Since this is most likely bound to something, and not used
+ ;; at idle time, throw in a TAB for good measure.
+ (semantic-complete-inline-TAB)
+ ))
+
+ ;;;###autoload
+ (defun semantic-complete-analyze-inline-idle ()
+ "Perform prompt completion to do in buffer completion.
+ `semantic-analyze-possible-completions' is used to determine the
+ possible values.
+ The function returns immediately, leaving the buffer in a mode that
+ will perform the completion.
+ Configure `semantic-complete-inline-analyzer-idle-displayor-class'
+ to change how completion options are displayed."
+ (interactive)
+ ;; Only do this if we are not already completing something.
+ (if (not (semantic-completion-inline-active-p))
+ (semantic-complete-inline-analyzer-idle
+ (semantic-analyze-current-context (point))))
+ ;; Report a message if things didn't startup.
+ (if (and (interactive-p)
+ (not (semantic-completion-inline-active-p)))
+ (message "Inline completion not needed."))
+ )
+
+ ;;;###autoload
+ (defun semantic-complete-self-insert (arg)
+ "Like `self-insert-command', but does completion afterwards.
+ ARG is passed to `self-insert-command'. If ARG is nil,
+ use `semantic-complete-analyze-inline' to complete."
+ (interactive "p")
+ ;; If we are already in a completion scenario, exit now, and then start over.
+ (semantic-complete-inline-exit)
+
+ ;; Insert the key
+ (self-insert-command arg)
+
+ ;; Prepare for doing completion, but exit quickly if there is keyboard
+ ;; input.
+ (when (and (not (semantic-exit-on-input 'csi
+ (semantic-fetch-tags)
+ (semantic-throw-on-input 'csi)
+ nil))
+ (= arg 1)
+ (not (semantic-exit-on-input 'csi
+ (semantic-analyze-current-context)
+ (semantic-throw-on-input 'csi)
+ nil)))
+ (condition-case nil
+ (semantic-complete-analyze-inline)
+ ;; Ignore errors. Seems likely that we'll get some once in a while.
+ (error nil))
+ ))
+
+ (provide 'semantic/complete)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/complete"
+ ;; End:
+
+ ;;; semantic/complete.el ends here
--- /dev/null
- )
-(require 'semantic/db-file)
-(require 'semantic/find)
+ ;;; semantic/db-ebrowse.el --- Semanticdb backend using ebrowse.
+
+ ;;; Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Authors: Eric M. Ludlam <zappo@gnu.org>, Joakim Verona
+ ;; Keywords: tags
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; This program was started by Eric Ludlam, and Joakim Verona finished
+ ;; the implementation by adding searches and fixing bugs.
+ ;;
+ ;; Read in custom-created ebrowse BROWSE files into a semanticdb back
+ ;; end.
+ ;;
+ ;; Add these databases to the 'system' search.
+ ;; Possibly use ebrowse for local parsing too.
+ ;;
+ ;; When real details are needed out of the tag system from ebrowse,
+ ;; we will need to delve into the originating source and parse those
+ ;; files the usual way.
+ ;;
+ ;; COMMANDS:
+ ;; `semanticdb-create-ebrowse-database' - Call EBROWSE to create a
+ ;; system database for some directory. In general, use this for
+ ;; system libraries, such as /usr/include, or include directories
+ ;; large software projects.
+ ;; Customize `semanticdb-ebrowse-file-match' to make sure the correct
+ ;; file extensions are matched.
+ ;;
+ ;; `semanticdb-load-ebrowse-caches' - Load all the EBROWSE caches from
+ ;; your semanticdb system database directory. Once they are
+ ;; loaded, they become searchable as omnipotent databases for
+ ;; all C++ files. This is called automatically by semantic-load.
+ ;; Call it a second time to refresh the Emacs DB with the file.
+ ;;
+
++(require 'ebrowse)
++(require 'semantic)
++(require 'semantic/db-file)
++
+ (eval-when-compile
+ ;; For generic function searching.
+ (require 'eieio)
+ (require 'eieio-opt)
-(eval-and-compile
- ;; Hopefully, this will allow semanticdb-ebrowse to compile under
- ;; XEmacs, it just won't run if a user attempts to use it.
- (condition-case nil
- (require 'ebrowse)
- (error nil)))
-
++ (require 'semantic/find))
+
+ (declare-function semantic-add-system-include "semantic/dep")
+
+ ;;; Code:
+ (defvar semanticdb-ebrowse-default-file-name "BROWSE"
+ "The EBROWSE file name used for system caches.")
+
+ (defcustom semanticdb-ebrowse-file-match "\\.\\(hh?\\|HH?\\|hpp\\)"
+ "Regular expression matching file names for ebrowse to parse.
+ This expression should exclude C++ headers that have no extension.
+ By default, include only headers since the semantic use of EBrowse
+ is only for searching via semanticdb, and thus only headers would
+ be searched."
+ :group 'semanticdb
+ :type 'string)
+
+ ;;; SEMANTIC Database related Code
+ ;;; Classes:
+ (defclass semanticdb-table-ebrowse (semanticdb-table)
+ ((major-mode :initform c++-mode)
+ (ebrowse-tree :initform nil
+ :initarg :ebrowse-tree
+ :documentation
+ "The raw ebrowse tree for this file."
+ )
+ (global-extract :initform nil
+ :initarg :global-extract
+ :documentation
+ "Table of ebrowse tags specific to this file.
+ This table is compisited from the ebrowse *Globals* section.")
+ )
+ "A table for returning search results from ebrowse.")
+
+ (defclass semanticdb-project-database-ebrowse
+ (semanticdb-project-database)
+ ((new-table-class :initform semanticdb-table-ebrowse
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ (system-include-p :initform nil
+ :initarg :system-include
+ :documentation
+ "Flag indicating this database represents a system include directory.")
+ (ebrowse-struct :initform nil
+ :initarg :ebrowse-struct
+ )
+ )
+ "Semantic Database deriving tags using the EBROWSE tool.
+ EBROWSE is a C/C++ parser for use with `ebrowse' Emacs program.")
+
+
+ (defun semanticdb-ebrowse-C-file-p (file)
+ "Is FILE a C or C++ file?"
+ (or (string-match semanticdb-ebrowse-file-match file)
+ (and (string-match "/\\w+$" file)
+ (not (file-directory-p file))
+ (let ((tmp (get-buffer-create "*semanticdb-ebrowse-tmp*")))
+ (save-excursion
+ (set-buffer tmp)
+ (condition-case nil
+ (insert-file-contents file nil 0 100 t)
+ (error (insert-file-contents file nil nil nil t)))
+ (goto-char (point-min))
+ (looking-at "\\s-*/\\(\\*\\|/\\)")
+ ))
+ )))
+
+ (defun semanticdb-create-ebrowse-database (dir)
+ "Create an EBROSE database for directory DIR.
+ The database file is stored in ~/.semanticdb, or whichever directory
+ is specified by `semanticdb-default-save-directory'."
+ (interactive "DDirectory: ")
+ (setq dir (file-name-as-directory dir)) ;; for / on end
+ (let* ((savein (semanticdb-ebrowse-file-for-directory dir))
+ (filebuff (get-buffer-create "*SEMANTICDB EBROWSE TMP*"))
+ (files (directory-files (expand-file-name dir) t))
+ (mma auto-mode-alist)
+ (regexp nil)
+ )
+ ;; Create the input to the ebrowse command
+ (save-excursion
+ (set-buffer filebuff)
+ (buffer-disable-undo filebuff)
+ (setq default-directory (expand-file-name dir))
+
+ ;;; @TODO - convert to use semanticdb-collect-matching-filenames
+ ;; to get the file names.
+
+
+ (mapc (lambda (f)
+ (when (semanticdb-ebrowse-C-file-p f)
+ (insert f)
+ (insert "\n")))
+ files)
+ ;; Cleanup the ebrowse output buffer.
+ (save-excursion
+ (set-buffer (get-buffer-create "*EBROWSE OUTPUT*"))
+ (erase-buffer))
+ ;; Call the EBROWSE command.
+ (message "Creating ebrowse file: %s ..." savein)
+ (call-process-region (point-min) (point-max)
+ "ebrowse" nil "*EBROWSE OUTPUT*" nil
+ (concat "--output-file=" savein)
+ "--very-verbose")
+ )
+ ;; Create a short LOADER program for loading in this database.
+ (let* ((lfn (concat savein "-load.el"))
+ (lf (find-file-noselect lfn)))
+ (save-excursion
+ (set-buffer lf)
+ (erase-buffer)
+ (insert "(semanticdb-ebrowse-load-helper \""
+ (expand-file-name dir)
+ "\")\n")
+ (save-buffer)
+ (kill-buffer (current-buffer)))
+ (message "Creating ebrowse file: %s ... done" savein)
+ ;; Reload that database
+ (load lfn nil t)
+ )))
+
+ (defun semanticdb-load-ebrowse-caches ()
+ "Load all semanticdb controlled EBROWSE caches."
+ (interactive)
+ (let ((f (directory-files semanticdb-default-save-directory
+ t (concat semanticdb-ebrowse-default-file-name "-load.el$") t)))
+ (while f
+ (load (car f) nil t)
+ (setq f (cdr f)))
+ ))
+
+ (defun semanticdb-ebrowse-load-helper (directory)
+ "Create the semanticdb database via ebrowse for directory.
+ If DIRECTORY is found to be defunct, it won't load the DB, and will
+ warn instead."
+ (if (file-directory-p directory)
+ (semanticdb-create-database semanticdb-project-database-ebrowse
+ directory)
+ (let* ((BF (semanticdb-ebrowse-file-for-directory directory))
+ (BFL (concat BF "-load.el"))
+ (BFLB (concat BF "-load.el~")))
+ (save-window-excursion
+ (with-output-to-temp-buffer "*FILES TO DELETE*"
+ (princ "The following BROWSE files are obsolete.\n\n")
+ (princ BF)
+ (princ "\n")
+ (princ BFL)
+ (princ "\n")
+ (when (file-exists-p BFLB)
+ (princ BFLB)
+ (princ "\n"))
+ )
+ (when (y-or-n-p (format
+ "Warning: Obsolete BROWSE file for: %s\nDelete? "
+ directory))
+ (delete-file BF)
+ (delete-file BFL)
+ (when (file-exists-p BFLB)
+ (delete-file BFLB))
+ )))))
+
+ ;JAVE this just instantiates a default empty ebrowse struct?
+ ; how would new instances wind up here?
+ ; the ebrowse class isnt singleton, unlike the emacs lisp one
+ (defvar-mode-local c++-mode semanticdb-project-system-databases
+ ()
+ "Search Ebrowse for symbols.")
+
+ (defmethod semanticdb-needs-refresh-p ((table semanticdb-table-ebrowse))
+ "EBROWSE database do not need to be refreshed.
+
+ JAVE: stub for needs-refresh, because, how do we know if BROWSE files
+ are out of date?
+
+ EML: Our database should probably remember the timestamp/checksum of
+ the most recently read EBROWSE file, and use that."
+ nil
+ )
+
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+ ;;; EBROWSE code
+ ;;
+ ;; These routines deal with part of the ebrowse interface.
+ (defun semanticdb-ebrowse-file-for-directory (dir)
+ "Return the file name for DIR where the ebrowse BROWSE file is.
+ This file should reside in `semanticdb-default-save-directory'."
+ (let* ((semanticdb-default-save-directory
+ semanticdb-default-save-directory)
+ (B (semanticdb-file-name-directory
+ 'semanticdb-project-database-file
+ (concat (expand-file-name dir)
+ semanticdb-ebrowse-default-file-name)))
+ )
+ B))
+
+ (defun semanticdb-ebrowse-get-ebrowse-structure (dir)
+ "Return the ebrowse structure for directory DIR.
+ This assumes semantic manages the BROWSE files, so they are assumed to live
+ where semantic cache files live, depending on your settings.
+
+ For instance: /home/<username>/.semanticdb/!usr!include!BROWSE"
+ (let* ((B (semanticdb-ebrowse-file-for-directory dir))
+ (buf (get-buffer-create "*semanticdb ebrowse*")))
+ (message "semanticdb-ebrowse %s" B)
+ (when (file-exists-p B)
+ (set-buffer buf)
+ (buffer-disable-undo buf)
+ (erase-buffer)
+ (insert-file-contents B)
+ (let ((ans nil)
+ (efcn (symbol-function 'ebrowse-show-progress)))
+ (fset 'ebrowse-show-progress #'(lambda (&rest junk) nil))
+ (unwind-protect ;; Protect against errors w/ ebrowse
+ (setq ans (list B (ebrowse-read)))
+ ;; These items must always happen
+ (erase-buffer)
+ (fset 'ebrowse-show-fcn efcn)
+ )
+ ans))))
+
+ ;;; Methods for creating a database or tables
+ ;;
+ (defmethod semanticdb-create-database :STATIC ((dbeC semanticdb-project-database-ebrowse)
+ directory)
+ "Create a new semantic database for DIRECTORY based on ebrowse.
+ If there is no database for DIRECTORY available, then
+ {not implemented yet} create one. Return nil if that is not possible."
+ ;; MAKE SURE THAT THE FILE LOADED DOESN'T ALREADY EXIST.
+ (require 'semantic/dep)
+ (let ((dbs semanticdb-database-list)
+ (found nil))
+ (while (and (not found) dbs)
+ (when (semanticdb-project-database-ebrowse-p (car dbs))
+ (when (string= (oref (car dbs) reference-directory) directory)
+ (setq found (car dbs))))
+ (setq dbs (cdr dbs)))
+ ;;STATIC means DBE cant be used as object, only as a class
+ (let* ((ebrowse-data (semanticdb-ebrowse-get-ebrowse-structure directory))
+ (dat (car (cdr ebrowse-data)))
+ (ebd (car dat))
+ (db nil)
+ (default-directory directory)
+ )
+ (if found
+ (setq db found)
+ (setq db (make-instance
+ dbeC
+ directory
+ :ebrowse-struct ebd
+ ))
+ (oset db reference-directory directory))
+
+ ;; Once we recycle or make a new DB, refresh the
+ ;; contents from the BROWSE file.
+ (oset db tables nil)
+ ;; only possible after object creation, tables inited to nil.
+ (semanticdb-ebrowse-strip-trees db dat)
+
+ ;; Once our database is loaded, if we are a system DB, we
+ ;; add ourselves to the include list for C++.
+ (semantic-add-system-include directory 'c++-mode)
+ (semantic-add-system-include directory 'c-mode)
+
+ db)))
+
+ (defmethod semanticdb-ebrowse-strip-trees ((dbe semanticdb-project-database-ebrowse)
+ data)
+ "For the ebrowse database DBE, strip all tables from DATA."
+ ;JAVE what it actually seems to do is split the original tree in "tables" associated with files
+ ; im not sure it actually works:
+ ; the filename slot sometimes gets to be nil,
+ ; apparently for classes which definition cant be found, yet needs to be included in the tree
+ ; like library baseclasses
+ ; a file can define several classes
+ (let ((T (car (cdr data))));1st comes a header, then the tree
+ (while T
+
+ (let* ((tree (car T))
+ (class (ebrowse-ts-class tree)); root class of tree
+ ;; Something funny going on with this file thing...
+ (filename (or (ebrowse-cs-source-file class)
+ (ebrowse-cs-file class)))
+ )
+ (cond
+ ((ebrowse-globals-tree-p tree)
+ ;; We have the globals tree.. save this special.
+ (semanticdb-ebrowse-add-globals-to-table dbe tree)
+ )
+ (t
+ ;; ebrowse will collect all the info from multiple files
+ ;; into one tree. Semantic wants all the bits to be tied
+ ;; into different files. We need to do a full dissociation
+ ;; into semantic parsable tables.
+ (semanticdb-ebrowse-add-tree-to-table dbe tree)
+ ))
+ (setq T (cdr T))))
+ ))
+
+ ;;; Filename based methods
+ ;;
+ (defun semanticdb-ebrowse-add-globals-to-table (dbe tree)
+ "For database DBE, add the ebrowse TREE into the table."
+ (if (or (not (ebrowse-ts-p tree))
+ (not (ebrowse-globals-tree-p tree)))
+ (signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
+
+ (let* ((class (ebrowse-ts-class tree))
+ (fname (or (ebrowse-cs-source-file class)
+ (ebrowse-cs-file class)
+ ;; Not def'd here, assume our current
+ ;; file
+ (concat default-directory "/unknown-proxy.hh")))
+ (vars (ebrowse-ts-member-functions tree))
+ (fns (ebrowse-ts-member-variables tree))
+ (toks nil)
+ )
+ (while vars
+ (let ((nt (semantic-tag (ebrowse-ms-name (car vars))
+ 'variable))
+ (defpoint (ebrowse-bs-point class)))
+ (when defpoint
+ (semantic--tag-set-overlay nt
+ (vector defpoint defpoint)))
+ (setq toks (cons nt toks)))
+ (setq vars (cdr vars)))
+ (while fns
+ (let ((nt (semantic-tag (ebrowse-ms-name (car fns))
+ 'function))
+ (defpoint (ebrowse-bs-point class)))
+ (when defpoint
+ (semantic--tag-set-overlay nt
+ (vector defpoint defpoint)))
+ (setq toks (cons nt toks)))
+ (setq fns (cdr fns)))
+
+ ))
+
+ (defun semanticdb-ebrowse-add-tree-to-table (dbe tree &optional fname baseclasses)
+ "For database DBE, add the ebrowse TREE into the table for FNAME.
+ Optional argument BASECLASSES specifyies a baseclass to the tree being provided."
+ (if (not (ebrowse-ts-p tree))
+ (signal 'wrong-type-argument (list 'ebrowse-ts-p tree)))
+
+ ;; Strategy overview:
+ ;; 1) Calculate the filename for this tree.
+ ;; 2) Find a matching namespace in TAB, or create a new one.
+ ;; 3) Fabricate a tag proxy for CLASS
+ ;; 4) Add it to the namespace
+ ;; 5) Add subclasses
+
+ ;; 1 - Find the filename
+ (if (not fname)
+ (setq fname (or (ebrowse-cs-source-file (ebrowse-ts-class tree))
+ (ebrowse-cs-file (ebrowse-ts-class tree))
+ ;; Not def'd here, assume our current
+ ;; file
+ (concat default-directory "/unknown-proxy.hh"))))
+
+ (let* ((tab (or (semanticdb-file-table dbe fname)
+ (semanticdb-create-table dbe fname)))
+ (class (ebrowse-ts-class tree))
+ (scope (ebrowse-cs-scope class))
+ (ns (when scope (split-string scope ":" t)))
+ (nst nil)
+ (cls nil)
+ )
+
+ ;; 2 - Get the namespace tag
+ (when ns
+ (let ((taglst (if (slot-boundp tab 'tags) (oref tab tags) nil)))
+ (setq nst (semantic-find-first-tag-by-name (car ns) taglst))
+ (when (not nst)
+ (setq nst (semantic-tag (car ns) 'type :type "namespace"))
+ (oset tab tags (cons nst taglst))
+ )))
+
+ ;; 3 - Create a proxy tg.
+ (setq cls (semantic-tag (ebrowse-cs-name class)
+ 'type
+ :type "class"
+ :superclasses baseclasses
+ :faux t
+ :filename fname
+ ))
+ (let ((defpoint (ebrowse-bs-point class)))
+ (when defpoint
+ (semantic--tag-set-overlay cls
+ (vector defpoint defpoint))))
+
+ ;; 4 - add to namespace
+ (if nst
+ (semantic-tag-put-attribute
+ nst :members (cons cls (semantic-tag-get-attribute nst :members)))
+ (oset tab tags (cons cls (when (slot-boundp tab 'tags)
+ (oref tab tags)))))
+
+ ;; 5 - Subclasses
+ (let* ((subclass (ebrowse-ts-subclasses tree))
+ (pname (ebrowse-cs-name class)))
+ (when (ebrowse-cs-scope class)
+ (setq pname (concat (mapconcat (lambda (a) a) (cdr ns) "::") "::" pname)))
+
+ (while subclass
+ (let* ((scc (ebrowse-ts-class (car subclass)))
+ (fname (or (ebrowse-cs-source-file scc)
+ (ebrowse-cs-file scc)
+ ;; Not def'd here, assume our current
+ ;; file
+ fname
+ )))
+ (when fname
+ (semanticdb-ebrowse-add-tree-to-table
+ dbe (car subclass) fname pname)))
+ (setq subclass (cdr subclass))))
+ ))
+
+ ;;;
+ ;; Overload for converting the simple faux tag into something better.
+ ;;
+ (defmethod semanticdb-normalize-tags ((obj semanticdb-table-ebrowse) tags)
+ "Convert in Ebrowse database OBJ a list of TAGS into a complete tag.
+ The default tag provided by searches exclude many features of a
+ semantic parsed tag. Look up the file for OBJ, and match TAGS
+ against a semantic parsed tag that has all the info needed, and
+ return that."
+ (let ((tagret nil)
+ )
+ ;; SemanticDB will automatically create a regular database
+ ;; on top of the file just loaded by ebrowse during the set
+ ;; buffer. Fetch that table, and use it's tag list to look
+ ;; up the tag we just got, and thus turn it into a full semantic
+ ;; tag.
+ (while tags
+ (let ((tag (car tags)))
+ (save-excursion
+ (semanticdb-set-buffer obj)
+ (let ((ans nil))
+ ;; Gee, it would be nice to do this, but ebrowse LIES. Oi.
+ (when (semantic-tag-with-position-p tag)
+ (goto-char (semantic-tag-start tag))
+ (let ((foundtag (semantic-current-tag)))
+ ;; Make sure the discovered tag is the same as what we started with.
+ (when (string= (semantic-tag-name tag)
+ (semantic-tag-name foundtag))
+ ;; We have a winner!
+ (setq ans foundtag))))
+ ;; Sometimes ebrowse lies. Do a generic search
+ ;; to find it within this file.
+ (when (not ans)
+ ;; We might find multiple hits for this tag, and we have no way
+ ;; of knowing which one the user wanted. Return the first one.
+ (setq ans (semantic-deep-find-tags-by-name
+ (semantic-tag-name tag)
+ (semantic-fetch-tags))))
+ (if (semantic-tag-p ans)
+ (setq tagret (cons ans tagret))
+ (setq tagret (append ans tagret)))
+ ))
+ (setq tags (cdr tags))))
+ tagret))
+
+ (defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-ebrowse) tag)
+ "Convert in Ebrowse database OBJ one TAG into a complete tag.
+ The default tag provided by searches exclude many features of a
+ semantic parsed tag. Look up the file for OBJ, and match TAG
+ against a semantic parsed tag that has all the info needed, and
+ return that."
+ (let ((tagret nil)
+ (objret nil))
+ ;; SemanticDB will automatically create a regular database
+ ;; on top of the file just loaded by ebrowse during the set
+ ;; buffer. Fetch that table, and use it's tag list to look
+ ;; up the tag we just got, and thus turn it into a full semantic
+ ;; tag.
+ (save-excursion
+ (semanticdb-set-buffer obj)
+ (setq objret semanticdb-current-table)
+ (when (not objret)
+ ;; What to do??
+ (debug))
+ (let ((ans nil))
+ ;; Gee, it would be nice to do this, but ebrowse LIES. Oi.
+ (when (semantic-tag-with-position-p tag)
+ (goto-char (semantic-tag-start tag))
+ (let ((foundtag (semantic-current-tag)))
+ ;; Make sure the discovered tag is the same as what we started with.
+ (when (string= (semantic-tag-name tag)
+ (semantic-tag-name foundtag))
+ ;; We have a winner!
+ (setq ans foundtag))))
+ ;; Sometimes ebrowse lies. Do a generic search
+ ;; to find it within this file.
+ (when (not ans)
+ ;; We might find multiple hits for this tag, and we have no way
+ ;; of knowing which one the user wanted. Return the first one.
+ (setq ans (semantic-deep-find-tags-by-name
+ (semantic-tag-name tag)
+ (semantic-fetch-tags))))
+ (if (semantic-tag-p ans)
+ (setq tagret ans)
+ (setq tagret (car ans)))
+ ))
+ (cons objret tagret)))
+
+ ;;; Search Overrides
+ ;;
+ ;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining
+ ;; how your new search routines are implemented.
+ ;;
+ (defmethod semanticdb-find-tags-by-name-method
+ ((table semanticdb-table-ebrowse) name &optional tags)
+ "Find all tags named NAME in TABLE.
+ Return a list of tags."
+ ;;(message "semanticdb-find-tags-by-name-method name -- %s" name)
+ (if tags
+ ;; If TAGS are passed in, then we don't need to do work here.
+ (call-next-method)
+ ;; If we ever need to do something special, add here.
+ ;; Since ebrowse tags are converted into semantic tags, we can
+ ;; get away with this sort of thing.
+ (call-next-method)
+ )
+ )
+
+ (defmethod semanticdb-find-tags-by-name-regexp-method
+ ((table semanticdb-table-ebrowse) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+ Optional argument TAGS is a list of tags to search.
+ Return a list of tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (call-next-method)
+ ))
+
+ (defmethod semanticdb-find-tags-for-completion-method
+ ((table semanticdb-table-ebrowse) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+ Optional argument TAGS is a list of tags to search.
+ Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (call-next-method)
+ ))
+
+ (defmethod semanticdb-find-tags-by-class-method
+ ((table semanticdb-table-ebrowse) class &optional tags)
+ "In TABLE, find all occurances of tags of CLASS.
+ Optional argument TAGS is a list of tags to search.
+ Returns a table of all matching tags."
+ (if tags (call-next-method)
+ (call-next-method)))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;;; Deep Searches
+ ;;
+ ;; If your language does not have a `deep' concept, these can be left
+ ;; alone, otherwise replace with implementations similar to those
+ ;; above.
+ ;;
+
+ (defmethod semanticdb-deep-find-tags-by-name-method
+ ((table semanticdb-table-ebrowse) name &optional tags)
+ "Find all tags name NAME in TABLE.
+ Optional argument TAGS is a list of tags t
+ Like `semanticdb-find-tags-by-name-method' for ebrowse."
+ ;;(semanticdb-find-tags-by-name-method table name tags)
+ (call-next-method))
+
+ (defmethod semanticdb-deep-find-tags-by-name-regexp-method
+ ((table semanticdb-table-ebrowse) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+ Optional argument TAGS is a list of tags to search.
+ Like `semanticdb-find-tags-by-name-method' for ebrowse."
+ ;;(semanticdb-find-tags-by-name-regexp-method table regex tags)
+ (call-next-method))
+
+ (defmethod semanticdb-deep-find-tags-for-completion-method
+ ((table semanticdb-table-ebrowse) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+ Optional argument TAGS is a list of tags to search.
+ Like `semanticdb-find-tags-for-completion-method' for ebrowse."
+ ;;(semanticdb-find-tags-for-completion-method table prefix tags)
+ (call-next-method))
+
+ ;;; Advanced Searches
+ ;;
+ (defmethod semanticdb-find-tags-external-children-of-type-method
+ ((table semanticdb-table-ebrowse) type &optional tags)
+ "Find all nonterminals which are child elements of TYPE
+ Optional argument TAGS is a list of tags to search.
+ Return a list of tags."
+ (if tags (call-next-method)
+ ;; Ebrowse collects all this type of stuff together for us.
+ ;; but we can't use it.... yet.
+ nil
+ ))
+
+ (provide 'semantic/db-ebrowse)
+
+ ;;; semantic/db-ebrowse.el ends here
--- /dev/null
- (require 'eieio)
+ ;;; semantic/db-find.el --- Searching through semantic databases.
+
+ ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+ ;;; 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: tags
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Databases of various forms can all be searched.
+ ;; There are a few types of searches that can be done:
+ ;;
+ ;; Basic Name Search:
+ ;; These searches scan a database table collection for tags based
+ ;; on name.
+ ;;
+ ;; Basic Attribute Search:
+ ;; These searches allow searching on specific attributes of tags,
+ ;; such as name, type, or other attribute.
+ ;;
+ ;; Advanced Search:
+ ;; These are searches that were needed to accomplish some
+ ;; specialized tasks as discovered in utilities. Advanced searches
+ ;; include matching methods defined outside some parent class.
+ ;;
+ ;; The reason for advanced searches are so that external
+ ;; repositories such as the Emacs obarray, or java .class files can
+ ;; quickly answer these needed questions without dumping the entire
+ ;; symbol list into Emacs for additional refinement searches via
+ ;; regular semanticdb search.
+ ;;
+ ;; How databases are decided upon is another important aspect of a
+ ;; database search. When it comes to searching for a name, there are
+ ;; these types of searches:
+ ;;
+ ;; Basic Search:
+ ;; Basic search means that tags looking for a given name start
+ ;; with a specific search path. Names are sought on that path
+ ;; until it is empty or items on the path can no longer be found.
+ ;; Use `semanticdb-dump-all-table-summary' to test this list.
+ ;; Use `semanticdb-find-throttle-custom-list' to refine this list.
+ ;;
+ ;; Deep Search:
+ ;; A deep search will search more than just the global namespace.
+ ;; It will recurse into tags that contain more tags, and search
+ ;; those too.
+ ;;
+ ;; Brute Search:
+ ;; Brute search means that all tables in all databases in a given
+ ;; project are searched. Brute searches are the search style as
+ ;; written for semantic version 1.x.
+ ;;
+ ;; How does the search path work?
+ ;;
+ ;; A basic search starts with three parameters:
+ ;;
+ ;; (FINDME &optional PATH FIND-FILE-MATCH)
+ ;;
+ ;; FINDME is key to be searched for dependent on the type of search.
+ ;; PATH is an indicator of which tables are to be searched.
+ ;; FIND-FILE-MATCH indicates that any time a match is found, the
+ ;; file associated with the tag should be read into a file.
+ ;;
+ ;; The PATH argument is then the most interesting argument. It can
+ ;; have these values:
+ ;;
+ ;; nil - Take the current buffer, and use it's include list
+ ;; buffer - Use that buffer's include list.
+ ;; filename - Use that file's include list. If the file is not
+ ;; in a buffer, see of there is a semanticdb table for it. If
+ ;; not, read that file into a buffer.
+ ;; tag - Get that tag's buffer of file file. See above.
+ ;; table - Search that table, and it's include list.
+ ;;
+ ;; Search Results:
+ ;;
+ ;; Semanticdb returns the results in a specific format. There are a
+ ;; series of routines for using those results, and results can be
+ ;; passed in as a search-path for refinement searches with
+ ;; semanticdb. Apropos for semanticdb.*find-result for more.
+ ;;
+ ;; Application:
+ ;;
+ ;; Here are applications where different searches are needed which
+ ;; exist as of semantic 1.4.x
+ ;;
+ ;; eldoc - popup help
+ ;; => Requires basic search using default path. (Header files ok)
+ ;; tag jump - jump to a named tag
+ ;; => Requires a brute search useing whole project. (Source files only)
+ ;; completion - Completing symbol names in a smart way
+ ;; => Basic search (headers ok)
+ ;; type analysis - finding type definitions for variables & fcns
+ ;; => Basic search (headers ok)
+ ;; Class browser - organize types into some structure
+ ;; => Brute search, or custom navigation.
+
+ ;; TODO:
+ ;; During a search, load any unloaded DB files based on paths in the
+ ;; current project.
+
+ (require 'semantic/db)
+ (require 'semantic/db-ref)
+ (eval-when-compile
-\f
-;;; FIND results and edebug
-;;
-(eval-after-load "cedet-edebug"
- '(progn
- (cedet-edebug-add-print-override
- '(semanticdb-find-results-p object)
- '(semanticdb-find-result-prin1-to-string object) )
- ))
-
-
+ (require 'semantic/find))
+
+ ;;; Code:
+
+ (defvar data-debug-thing-alist)
+ (declare-function data-debug-insert-stuff-list "data-debug")
+ (declare-function data-debug-insert-tag-list "data-debug")
+ (declare-function semantic-scope-reset-cache "semantic/scope")
+ (declare-function semanticdb-typecache-notify-reset "semantic/db-typecache")
+ (declare-function ede-current-project "ede")
+
+ (defvar semanticdb-find-throttle-custom-list
+ '(repeat (radio (const 'local)
+ (const 'project)
+ (const 'unloaded)
+ (const 'system)
+ (const 'recursive)
+ (const 'omniscience)))
+ "Customization values for semanticdb find throttle.
+ See `semanticdb-find-throttle' for details.")
+
+ ;;;###autoload
+ (defcustom semanticdb-find-default-throttle
+ '(local project unloaded system recursive)
+ "The default throttle for `semanticdb-find' routines.
+ The throttle controls how detailed the list of database
+ tables is for a symbol lookup. The value is a list with
+ the following keys:
+ `file' - The file the search is being performed from.
+ This option is here for completeness only, and
+ is assumed to always be on.
+ `local' - Tables from the same local directory are included.
+ This includes files directly referenced by a file name
+ which might be in a different directory.
+ `project' - Tables from the same local project are included
+ If `project' is specified, then `local' is assumed.
+ `unloaded' - If a table is not in memory, load it. If it is not cached
+ on disk either, get the source, parse it, and create
+ the table.
+ `system' - Tables from system databases. These are specifically
+ tables from system header files, or language equivalent.
+ `recursive' - For include based searches, includes tables referenced
+ by included files.
+ `omniscience' - Included system databases which are omniscience, or
+ somehow know everything. Omniscience databases are found
+ in `semanticdb-project-system-databases'.
+ The Emacs Lisp system DB is an omniscience database."
+ :group 'semanticdb
+ :type semanticdb-find-throttle-custom-list)
+
+ (defun semanticdb-find-throttle-active-p (access-type)
+ "Non-nil if ACCESS-TYPE is an active throttle type."
+ (or (memq access-type semanticdb-find-default-throttle)
+ (eq access-type 'file)
+ (and (eq access-type 'local)
+ (memq 'project semanticdb-find-default-throttle))
+ ))
+
+ ;;; Index Class
+ ;;
+ ;; The find routines spend a lot of time looking stuff up.
+ ;; Use this handy search index to cache data between searches.
+ ;; This should allow searches to start running faster.
+ (defclass semanticdb-find-search-index (semanticdb-abstract-search-index)
+ ((include-path :initform nil
+ :documentation
+ "List of semanticdb tables from the include path.")
+ (type-cache :initform nil
+ :documentation
+ "Cache of all the data types accessible from this file.
+ Includes all types from all included files, merged namespaces, and
+ expunge duplicates.")
+ )
+ "Concrete search index for `semanticdb-find'.
+ This class will cache data derived during various searches.")
+
+ (defmethod semantic-reset ((idx semanticdb-find-search-index))
+ "Reset the object IDX."
+ (require 'semantic/scope)
+ ;; Clear the include path.
+ (oset idx include-path nil)
+ (when (oref idx type-cache)
+ (semantic-reset (oref idx type-cache)))
+ ;; Clear the scope. Scope doesn't have the data it needs to track
+ ;; it's own reset.
+ (semantic-scope-reset-cache)
+ )
+
+ (defmethod semanticdb-synchronize ((idx semanticdb-find-search-index)
+ new-tags)
+ "Synchronize the search index IDX with some NEW-TAGS."
+ ;; Reset our parts.
+ (semantic-reset idx)
+ ;; Notify dependants by clearning their indicies.
+ (semanticdb-notify-references
+ (oref idx table)
+ (lambda (tab me)
+ (semantic-reset (semanticdb-get-table-index tab))))
+ )
+
+ (defmethod semanticdb-partial-synchronize ((idx semanticdb-find-search-index)
+ new-tags)
+ "Synchronize the search index IDX with some changed NEW-TAGS."
+ ;; Only reset if include statements changed.
+ (if (semantic-find-tags-by-class 'include new-tags)
+ (progn
+ (semantic-reset idx)
+ ;; Notify dependants by clearning their indicies.
+ (semanticdb-notify-references
+ (oref idx table)
+ (lambda (tab me)
+ (semantic-reset (semanticdb-get-table-index tab))))
+ )
+ ;; Else, not an include, by just a type.
+ (when (oref idx type-cache)
+ (when (semanticdb-partial-synchronize (oref idx type-cache) new-tags)
+ ;; If the synchronize returns true, we need to notify.
+ ;; Notify dependants by clearning their indicies.
+ (semanticdb-notify-references
+ (oref idx table)
+ (lambda (tab me)
+ (let ((tab-idx (semanticdb-get-table-index tab)))
+ ;; Not a full reset?
+ (when (oref tab-idx type-cache)
+ (require 'db-typecache)
+ (semanticdb-typecache-notify-reset
+ (oref tab-idx type-cache)))
+ )))
+ ))
+ ))
+
+
+ ;;; Path Translations
+ ;;
+ ;;; OVERLOAD Functions
+ ;;
+ ;; These routines needed to be overloaded by specific language modes.
+ ;; They are needed for translating an INCLUDE tag into a semanticdb
+ ;; TABLE object.
+ ;;;###autoload
+ (define-overloadable-function semanticdb-find-translate-path (path brutish)
+ "Translate PATH into a list of semantic tables.
+ Path translation involves identifying the PATH input argument
+ in one of the following ways:
+ nil - Take the current buffer, and use it's include list
+ buffer - Use that buffer's include list.
+ filename - Use that file's include list. If the file is not
+ in a buffer, see of there is a semanticdb table for it. If
+ not, read that file into a buffer.
+ tag - Get that tag's buffer of file file. See above.
+ table - Search that table, and it's include list.
+ find result - Search the results of a previous find.
+
+ In addition, once the base path is found, there is the possibility of
+ each added table adding yet more tables to the path, so this routine
+ can return a lengthy list.
+
+ If argument BRUTISH is non-nil, then instead of using the include
+ list, use all tables found in the parent project of the table
+ identified by translating PATH. Such searches use brute force to
+ scan every available table.
+
+ The return value is a list of objects of type `semanticdb-table' or
+ it's children. In the case of passing in a find result, the result
+ is returned unchanged.
+
+ This routine uses `semanticdb-find-table-for-include' to translate
+ specific include tags into a semanticdb table.
+
+ Note: When searching using a non-brutish method, the list of
+ included files will be cached between runs. Database-references
+ are used to track which files need to have their include lists
+ refreshed when things change. See `semanticdb-ref-test'.
+
+ Note for overloading: If you opt to overload this function for your
+ major mode, and your routine takes a long time, be sure to call
+
+ (semantic-throw-on-input 'your-symbol-here)
+
+ so that it can be called from the idle work handler."
+ )
+
+ (defun semanticdb-find-translate-path-default (path brutish)
+ "Translate PATH into a list of semantic tables.
+ If BRUTISH is non nil, return all tables associated with PATH.
+ Default action as described in `semanticdb-find-translate-path'."
+ (if (semanticdb-find-results-p path)
+ ;; nil means perform the search over these results.
+ nil
+ (if brutish
+ (semanticdb-find-translate-path-brutish-default path)
+ (semanticdb-find-translate-path-includes-default path))))
+
+ ;;;###autoload
+ (define-overloadable-function semanticdb-find-table-for-include (includetag &optional table)
+ "For a single INCLUDETAG found in TABLE, find a `semanticdb-table' object
+ INCLUDETAG is a semantic TAG of class 'include.
+ TABLE is a semanticdb table that identifies where INCLUDETAG came from.
+ TABLE is optional if INCLUDETAG has an overlay of :filename attribute."
+ )
+
+ (defun semanticdb-find-translate-path-brutish-default (path)
+ "Translate PATH into a list of semantic tables.
+ Default action as described in `semanticdb-find-translate-path'."
+ (let ((basedb
+ (cond ((null path) semanticdb-current-database)
+ ((semanticdb-table-p path) (oref path parent-db))
+ (t (let ((tt (semantic-something-to-tag-table path)))
+ (save-excursion
+ ;; @todo - What does this DO ??!?!
+ (set-buffer (semantic-tag-buffer (car tt)))
+ semanticdb-current-database))))))
+ (apply
+ #'nconc
+ (mapcar
+ (lambda (db)
+ (let ((tabs (semanticdb-get-database-tables db))
+ (ret nil))
+ ;; Only return tables of the same language (major-mode)
+ ;; as the current search environment.
+ (while tabs
+
+ (semantic-throw-on-input 'translate-path-brutish)
+
+ (if (semanticdb-equivalent-mode-for-search (car tabs)
+ (current-buffer))
+ (setq ret (cons (car tabs) ret)))
+ (setq tabs (cdr tabs)))
+ ret))
+ ;; FIXME:
+ ;; This should scan the current project directory list for all
+ ;; semanticdb files, perhaps handling proxies for them.
+ (semanticdb-current-database-list
+ (if basedb (oref basedb reference-directory)
+ default-directory))))
+ ))
+
+ (defun semanticdb-find-incomplete-cache-entries-p (cache)
+ "Are there any incomplete entries in CACHE?"
+ (let ((ans nil))
+ (dolist (tab cache)
+ (when (and (semanticdb-table-child-p tab)
+ (not (number-or-marker-p (oref tab pointmax))))
+ (setq ans t))
+ )
+ ans))
+
+ (defun semanticdb-find-need-cache-update-p (table)
+ "Non nil if the semanticdb TABLE cache needs to be updated."
+ ;; If we were passed in something related to a TABLE,
+ ;; do a caching lookup.
+ (let* ((index (semanticdb-get-table-index table))
+ (cache (when index (oref index include-path)))
+ (incom (semanticdb-find-incomplete-cache-entries-p cache))
+ (unl (semanticdb-find-throttle-active-p 'unloaded))
+ )
+ (if (and
+ cache ;; Must have a cache
+ (or
+ ;; If all entries are "full", or if 'unloaded
+ ;; OR
+ ;; is not in the throttle, it is ok to use the cache.
+ (not incom) (not unl)
+ ))
+ nil
+ ;;cache
+ ;; ELSE
+ ;;
+ ;; We need an update.
+ t))
+ )
+
+ (defun semanticdb-find-translate-path-includes-default (path)
+ "Translate PATH into a list of semantic tables.
+ Default action as described in `semanticdb-find-translate-path'."
+ (let ((table (cond ((null path)
+ semanticdb-current-table)
+ ((bufferp path)
+ (semantic-buffer-local-value 'semanticdb-current-table path))
+ ((and (stringp path) (file-exists-p path))
+ (semanticdb-file-table-object path t))
+ ((semanticdb-abstract-table-child-p path)
+ path)
+ (t nil))))
+ (if table
+ ;; If we were passed in something related to a TABLE,
+ ;; do a caching lookup.
+ (let ((index (semanticdb-get-table-index table)))
+ (if (semanticdb-find-need-cache-update-p table)
+ ;; Lets go look up our indicies
+ (let ((ans (semanticdb-find-translate-path-includes--internal path)))
+ (oset index include-path ans)
+ ;; Once we have our new indicies set up, notify those
+ ;; who depend on us if we found something for them to
+ ;; depend on.
+ (when ans (semanticdb-refresh-references table))
+ ans)
+ ;; ELSE
+ ;;
+ ;; Just return the cache.
+ (oref index include-path)))
+ ;; If we were passed in something like a tag list, or other boring
+ ;; searchable item, then instead do the regular thing without caching.
+ (semanticdb-find-translate-path-includes--internal path))))
+
+ (defvar semanticdb-find-lost-includes nil
+ "Include files that we cannot find associated with this buffer.")
+ (make-variable-buffer-local 'semanticdb-find-lost-includes)
+
+ (defvar semanticdb-find-scanned-include-tags nil
+ "All include tags scanned, plus action taken on the tag.
+ Each entry is an alist:
+ (ACTION . TAG)
+ where ACTION is one of 'scanned, 'duplicate, 'lost.
+ and TAG is a clone of the include tag that was found.")
+ (make-variable-buffer-local 'semanticdb-find-scanned-include-tags)
+
+ (defvar semanticdb-implied-include-tags nil
+ "Include tags implied for all files of a given mode.
+ Set this variable with `defvar-mode-local' for a particular mode so
+ that any symbols that exist for all files for that mode are included.
+
+ Note: This could be used as a way to write a file in a langauge
+ to declare all the built-ins for that language.")
+
+ (defun semanticdb-find-translate-path-includes--internal (path)
+ "Internal implementation of `semanticdb-find-translate-path-includes-default'.
+ This routine does not depend on the cache, but will always derive
+ a new path from the provided PATH."
+ (let ((includetags nil)
+ (curtable nil)
+ (matchedtables (list semanticdb-current-table))
+ (matchedincludes nil)
+ (lostincludes nil)
+ (scannedincludes nil)
+ (incfname nil)
+ nexttable)
+ (cond ((null path)
+ (semantic-refresh-tags-safe)
+ (setq includetags (append
+ (semantic-find-tags-included (current-buffer))
+ semanticdb-implied-include-tags)
+ curtable semanticdb-current-table
+ incfname (buffer-file-name))
+ )
+ ((semanticdb-table-p path)
+ (setq includetags (semantic-find-tags-included path)
+ curtable path
+ incfname (semanticdb-full-filename path))
+ )
+ ((bufferp path)
+ (save-excursion
+ (set-buffer path)
+ (semantic-refresh-tags-safe))
+ (setq includetags (semantic-find-tags-included path)
+ curtable (save-excursion (set-buffer path)
+ semanticdb-current-table)
+ incfname (buffer-file-name path)))
+ (t
+ (setq includetags (semantic-find-tags-included path))
+ (when includetags
+ ;; If we have some tags, derive a table from them.
+ ;; else we will do nothing, so the table is useless.
+
+ ;; @todo - derive some tables
+ (message "Need to derive tables for %S in translate-path-includes--default."
+ path)
+ )))
+
+ ;; Make sure each found include tag has an originating file name associated
+ ;; with it.
+ (when incfname
+ (dolist (it includetags)
+ (semantic--tag-put-property it :filename incfname)))
+
+ ;; Loop over all include tags adding to matchedtables
+ (while includetags
+ (semantic-throw-on-input 'semantic-find-translate-path-includes-default)
+
+ ;; If we've seen this include string before, lets skip it.
+ (if (member (semantic-tag-name (car includetags)) matchedincludes)
+ (progn
+ (setq nexttable nil)
+ (push (cons 'duplicate (semantic-tag-clone (car includetags)))
+ scannedincludes)
+ )
+ (setq nexttable (semanticdb-find-table-for-include (car includetags) curtable))
+ (when (not nexttable)
+ ;; Save the lost include.
+ (push (car includetags) lostincludes)
+ (push (cons 'lost (semantic-tag-clone (car includetags)))
+ scannedincludes)
+ )
+ )
+
+ ;; Push the include file, so if we can't find it, we only
+ ;; can't find it once.
+ (push (semantic-tag-name (car includetags)) matchedincludes)
+
+ ;; (message "Scanning %s" (semantic-tag-name (car includetags)))
+ (when (and nexttable
+ (not (memq nexttable matchedtables))
+ (semanticdb-equivalent-mode-for-search nexttable
+ (current-buffer))
+ )
+ ;; Add to list of tables
+ (push nexttable matchedtables)
+
+ ;; Queue new includes to list
+ (if (semanticdb-find-throttle-active-p 'recursive)
+ ;; @todo - recursive includes need to have the originating
+ ;; buffer's location added to the path.
+ (let ((newtags
+ (cond
+ ((semanticdb-table-p nexttable)
+ (semanticdb-refresh-table nexttable)
+ ;; Use the method directly, or we will recurse
+ ;; into ourselves here.
+ (semanticdb-find-tags-by-class-method
+ nexttable 'include))
+ (t ;; @todo - is this ever possible???
+ (message "semanticdb-ftp - how did you do that?")
+ (semantic-find-tags-included
+ (semanticdb-get-tags nexttable)))
+ ))
+ (newincfname (semanticdb-full-filename nexttable))
+ )
+
+ (push (cons 'scanned (semantic-tag-clone (car includetags)))
+ scannedincludes)
+
+ ;; Setup new tags so we know where they are.
+ (dolist (it newtags)
+ (semantic--tag-put-property it :filename
+ newincfname))
+
+ (setq includetags (nconc includetags newtags)))
+ ;; ELSE - not recursive throttle
+ (push (cons 'scanned-no-recurse
+ (semantic-tag-clone (car includetags)))
+ scannedincludes)
+ )
+ )
+ (setq includetags (cdr includetags)))
+
+ (setq semanticdb-find-lost-includes lostincludes)
+ (setq semanticdb-find-scanned-include-tags (reverse scannedincludes))
+
+ ;; Find all the omniscient databases for this major mode, and
+ ;; add them if needed
+ (when (and (semanticdb-find-throttle-active-p 'omniscience)
+ semanticdb-search-system-databases)
+ ;; We can append any mode-specific omniscience databases into
+ ;; our search list here.
+ (let ((systemdb semanticdb-project-system-databases)
+ (ans nil))
+ (while systemdb
+ (setq ans (semanticdb-file-table
+ (car systemdb)
+ ;; I would expect most omniscient to return the same
+ ;; thing reguardless of filename, but we may have
+ ;; one that can return a table of all things the
+ ;; current file needs.
+ (buffer-file-name (current-buffer))))
+ (when (not (memq ans matchedtables))
+ (setq matchedtables (cons ans matchedtables)))
+ (setq systemdb (cdr systemdb))))
+ )
+ (nreverse matchedtables)))
+
+ (define-overloadable-function semanticdb-find-load-unloaded (filename)
+ "Create a database table for FILENAME if it hasn't been parsed yet.
+ Assumes that FILENAME exists as a source file.
+ Assumes that a preexisting table does not exist, even if it
+ isn't in memory yet."
+ (if (semanticdb-find-throttle-active-p 'unloaded)
+ (:override)
+ (semanticdb-file-table-object filename t)))
+
+ (defun semanticdb-find-load-unloaded-default (filename)
+ "Load an unloaded file in FILENAME using the default semanticdb loader."
+ (semanticdb-file-table-object filename))
+
+ ;; The creation of the overload occurs above.
+ (defun semanticdb-find-table-for-include-default (includetag &optional table)
+ "Default implementation of `semanticdb-find-table-for-include'.
+ Uses `semanticdb-current-database-list' as the search path.
+ INCLUDETAG and TABLE are documented in `semanticdb-find-table-for-include'.
+ Included databases are filtered based on `semanticdb-find-default-throttle'."
+ (if (not (eq (semantic-tag-class includetag) 'include))
+ (signal 'wrong-type-argument (list includetag 'include)))
+
+ (let ((name
+ ;; Note, some languages (like Emacs or Java) use include tag names
+ ;; that don't represent files! We want to have file names.
+ (semantic-tag-include-filename includetag))
+ (originfiledir nil)
+ (roots nil)
+ (tmp nil)
+ (ans nil))
+
+ ;; INCLUDETAG should have some way to reference where it came
+ ;; from! If not, TABLE should provide the way. Each time we
+ ;; look up a tag, we may need to find it in some relative way
+ ;; and must set our current buffer eto the origin of includetag
+ ;; or nothing may work.
+ (setq originfiledir
+ (cond ((semantic-tag-file-name includetag)
+ ;; A tag may have a buffer, or a :filename property.
+ (file-name-directory (semantic-tag-file-name includetag)))
+ (table
+ (file-name-directory (semanticdb-full-filename table)))
+ (t
+ ;; @todo - what to do here? Throw an error maybe
+ ;; and fix usage bugs?
+ default-directory)))
+
+ (cond
+ ;; Step 1: Relative path name
+ ;;
+ ;; If the name is relative, then it should be findable as relative
+ ;; to the source file that this tag originated in, and be fast.
+ ;;
+ ((and (semanticdb-find-throttle-active-p 'local)
+ (file-exists-p (expand-file-name name originfiledir)))
+
+ (setq ans (semanticdb-find-load-unloaded
+ (expand-file-name name originfiledir)))
+ )
+ ;; Step 2: System or Project level includes
+ ;;
+ ((or
+ ;; First, if it a system include, we can investigate that tags
+ ;; dependency file
+ (and (semanticdb-find-throttle-active-p 'system)
+
+ ;; Sadly, not all languages make this distinction.
+ ;;(semantic-tag-include-system-p includetag)
+
+ ;; Here, we get local and system files.
+ (setq tmp (semantic-dependency-tag-file includetag))
+ )
+ ;; Second, project files are active, we and we have EDE,
+ ;; we can find it using the same tool.
+ (and (semanticdb-find-throttle-active-p 'project)
+ ;; Make sure EDE is available, and we have a project
+ (featurep 'ede) (ede-current-project originfiledir)
+ ;; The EDE query is hidden in this call.
+ (setq tmp (semantic-dependency-tag-file includetag))
+ )
+ )
+ (setq ans (semanticdb-find-load-unloaded tmp))
+ )
+ ;; Somewhere in our project hierarchy
+ ;;
+ ;; Remember: Roots includes system databases which can create
+ ;; specialized tables we can search.
+ ;;
+ ;; NOTE: Not used if EDE is active!
+ ((and (semanticdb-find-throttle-active-p 'project)
+ ;; And dont do this if it is a system include. Not supported by all languages,
+ ;; but when it is, this is a nice fast way to skip this step.
+ (not (semantic-tag-include-system-p includetag))
+ ;; Don't do this if we have an EDE project.
+ (not (and (featurep 'ede)
+ ;; Note: We don't use originfiledir here because
+ ;; we want to know about the source file we are
+ ;; starting from.
+ (ede-current-project)))
+ )
+
+ (setq roots (semanticdb-current-database-list))
+
+ (while (and (not ans) roots)
+ (let* ((ref (if (slot-boundp (car roots) 'reference-directory)
+ (oref (car roots) reference-directory)))
+ (fname (cond ((null ref) nil)
+ ((file-exists-p (expand-file-name name ref))
+ (expand-file-name name ref))
+ ((file-exists-p (expand-file-name (file-name-nondirectory name) ref))
+ (expand-file-name (file-name-nondirectory name) ref)))))
+ (when (and ref fname)
+ ;; There is an actual file. Grab it.
+ (setq ans (semanticdb-find-load-unloaded fname)))
+
+ ;; ELSE
+ ;;
+ ;; NOTE: We used to look up omniscient databases here, but that
+ ;; is now handled one layer up.
+ ;;
+ ;; Missing: a database that knows where missing files are. Hmm.
+ ;; perhaps I need an override function for that?
+
+ )
+
+ (setq roots (cdr roots))))
+ )
+ ans))
+
+ \f
+ ;;; Perform interactive tests on the path/search mechanisms.
+ ;;
+ ;;;###autoload
+ (defun semanticdb-find-test-translate-path (&optional arg)
+ "Call and output results of `semanticdb-find-translate-path'.
+ With ARG non-nil, specify a BRUTISH translation.
+ See `semanticdb-find-default-throttle' and `semanticdb-project-roots'
+ for details on how this list is derived."
+ (interactive "P")
+ (semantic-fetch-tags)
+ (require 'data-debug)
+ (let ((start (current-time))
+ (p (semanticdb-find-translate-path nil arg))
+ (end (current-time))
+ )
+ (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*")
+ (message "Search of tags took %.2f seconds."
+ (semantic-elapsed-time start end))
+
+ (data-debug-insert-stuff-list p "*")))
+
+ (defun semanticdb-find-test-translate-path-no-loading (&optional arg)
+ "Call and output results of `semanticdb-find-translate-path'.
+ With ARG non-nil, specify a BRUTISH translation.
+ See `semanticdb-find-default-throttle' and `semanticdb-project-roots'
+ for details on how this list is derived."
+ (interactive "P")
+ (semantic-fetch-tags)
+ (require 'data-debug)
+ (let* ((semanticdb-find-default-throttle
+ (if (featurep 'semantic/db-find)
+ (remq 'unloaded semanticdb-find-default-throttle)
+ nil))
+ (start (current-time))
+ (p (semanticdb-find-translate-path nil arg))
+ (end (current-time))
+ )
+ (data-debug-new-buffer "*SEMANTICDB FTP ADEBUG*")
+ (message "Search of tags took %.2f seconds."
+ (semantic-elapsed-time start end))
+
+ (data-debug-insert-stuff-list p "*")))
+
+ ;;;###autoload
+ (defun semanticdb-find-adebug-lost-includes ()
+ "Translate the current path, then display the lost includes.
+ Examines the variable `semanticdb-find-lost-includes'."
+ (interactive)
+ (require 'data-debug)
+ (semanticdb-find-translate-path nil nil)
+ (let ((lost semanticdb-find-lost-includes)
+ )
+
+ (if (not lost)
+ (message "There are no unknown includes for %s"
+ (buffer-name))
+
+ (data-debug-new-buffer "*SEMANTICDB lost-includes ADEBUG*")
+ (data-debug-insert-tag-list lost "*")
+ )))
+
+ (defun semanticdb-find-adebug-insert-scanned-tag-cons (consdata prefix prebuttontext)
+ "Insert a button representing scanned include CONSDATA.
+ PREFIX is the text that preceeds the button.
+ PREBUTTONTEXT is some text between prefix and the overlay button."
+ (let* ((start (point))
+ (end nil)
+ (mode (car consdata))
+ (tag (cdr consdata))
+ (name (semantic-tag-name tag))
+ (file (semantic-tag-file-name tag))
+ (str1 (format "%S %s" mode name))
+ (str2 (format " : %s" file))
+ (tip nil))
+ (insert prefix prebuttontext str1)
+ (setq end (point))
+ (insert str2)
+ (put-text-property start end 'face
+ (cond ((eq mode 'scanned)
+ 'font-lock-function-name-face)
+ ((eq mode 'duplicate)
+ 'font-lock-comment-face)
+ ((eq mode 'lost)
+ 'font-lock-variable-name-face)
+ ((eq mode 'scanned-no-recurse)
+ 'font-lock-type-face)))
+ (put-text-property start end 'ddebug (cdr consdata))
+ (put-text-property start end 'ddebug-indent(length prefix))
+ (put-text-property start end 'ddebug-prefix prefix)
+ (put-text-property start end 'help-echo tip)
+ (put-text-property start end 'ddebug-function
+ 'data-debug-insert-tag-parts-from-point)
+ (insert "\n")
+ )
+ )
+
+ (defun semanticdb-find-adebug-scanned-includes ()
+ "Translate the current path, then display the lost includes.
+ Examines the variable `semanticdb-find-lost-includes'."
+ (interactive)
+ (require 'data-debug)
+ (semanticdb-find-translate-path nil nil)
+ (let ((scanned semanticdb-find-scanned-include-tags)
+ (data-debug-thing-alist
+ (cons
+ '((lambda (thing) (and (consp thing)
+ (symbolp (car thing))
+ (memq (car thing)
+ '(scanned scanned-no-recurse
+ lost duplicate))))
+ . semanticdb-find-adebug-insert-scanned-tag-cons)
+ data-debug-thing-alist))
+ )
+
+ (if (not scanned)
+ (message "There are no includes scanned %s"
+ (buffer-name))
+
+ (data-debug-new-buffer "*SEMANTICDB scanned-includes ADEBUG*")
+ (data-debug-insert-stuff-list scanned "*")
+ )))
+ \f
+ ;;; API Functions
+ ;;
+ ;; Once you have a search result, use these routines to operate
+ ;; on the search results at a higher level
+
+ ;;;###autoload
+ (defun semanticdb-strip-find-results (results &optional find-file-match)
+ "Strip a semanticdb search RESULTS to exclude objects.
+ This makes it appear more like the results of a `semantic-find-' call.
+ Optional FIND-FILE-MATCH loads all files associated with RESULTS
+ into buffers. This has the side effect of enabling `semantic-tag-buffer' to
+ return a value.
+ If FIND-FILE-MATCH is 'name, then only the filename is stored
+ in each tag instead of loading each file into a buffer.
+ If the input RESULTS are not going to be used again, and if
+ FIND-FILE-MATCH is nil, you can use `semanticdb-fast-strip-find-results'
+ instead."
+ (if find-file-match
+ ;; Load all files associated with RESULTS.
+ (let ((tmp results)
+ (output nil))
+ (while tmp
+ (let ((tab (car (car tmp)))
+ (tags (cdr (car tmp))))
+ (dolist (T tags)
+ ;; Normilzation gives specialty database tables a chance
+ ;; to convert into a more stable tag format.
+ (let* ((norm (semanticdb-normalize-one-tag tab T))
+ (ntab (car norm))
+ (ntag (cdr norm))
+ (nametable ntab))
+
+ ;; If it didn't normalize, use what we had.
+ (if (not norm)
+ (setq nametable tab)
+ (setq output (append output (list ntag))))
+
+ ;; Find-file-match allows a tool to make sure the tag is
+ ;; 'live', somewhere in a buffer.
+ (cond ((eq find-file-match 'name)
+ (let ((f (semanticdb-full-filename nametable)))
+ (semantic--tag-put-property ntag :filename f)))
+ ((and find-file-match ntab)
+ (semanticdb-get-buffer ntab))
+ )
+ ))
+ )
+ (setq tmp (cdr tmp)))
+ output)
+ ;; @todo - I could use nconc, but I don't know what the caller may do with
+ ;; RESULTS after this is called. Right now semantic-complete will
+ ;; recycling the input after calling this routine.
+ (apply #'append (mapcar #'cdr results))))
+
+ (defun semanticdb-fast-strip-find-results (results)
+ "Destructively strip a semanticdb search RESULTS to exclude objects.
+ This makes it appear more like the results of a `semantic-find-' call.
+ This is like `semanticdb-strip-find-results', except the input list RESULTS
+ will be changed."
+ (apply #'nconc (mapcar #'cdr results)))
+
+ (defun semanticdb-find-results-p (resultp)
+ "Non-nil if RESULTP is in the form of a semanticdb search result.
+ This query only really tests the first entry in the list that is RESULTP,
+ but should be good enough for debugging assertions."
+ (and (listp resultp)
+ (listp (car resultp))
+ (semanticdb-abstract-table-child-p (car (car resultp)))
+ (or (semantic-tag-p (car (cdr (car resultp))))
+ (null (car (cdr (car resultp)))))))
+
+ (defun semanticdb-find-result-prin1-to-string (result)
+ "Presuming RESULT satisfies `semanticdb-find-results-p', provide a short PRIN1 output."
+ (if (< (length result) 2)
+ (concat "#<FIND RESULT "
+ (mapconcat (lambda (a)
+ (concat "(" (object-name (car a) ) " . "
+ "#<TAG LIST " (number-to-string (length (cdr a))) ">)"))
+ result
+ " ")
+ ">")
+ ;; Longer results should have an abreviated form.
+ (format "#<FIND RESULT %d TAGS in %d FILES>"
+ (semanticdb-find-result-length result)
+ (length result))))
+
+ (defun semanticdb-find-result-with-nil-p (resultp)
+ "Non-nil of RESULTP is in the form of a semanticdb search result.
+ nil is a valid value where a TABLE usually is, but only if the TAG
+ results include overlays.
+ This query only really tests the first entry in the list that is RESULTP,
+ but should be good enough for debugging assertions."
+ (and (listp resultp)
+ (listp (car resultp))
+ (let ((tag-to-test (car-safe (cdr (car resultp)))))
+ (or (and (semanticdb-abstract-table-child-p (car (car resultp)))
+ (or (semantic-tag-p tag-to-test)
+ (null tag-to-test)))
+ (and (null (car (car resultp)))
+ (or (semantic-tag-with-position-p tag-to-test)
+ (null tag-to-test))))
+ )))
+
+ ;;;###autoload
+ (defun semanticdb-find-result-length (result)
+ "Number of tags found in RESULT."
+ (let ((count 0))
+ (mapc (lambda (onetable)
+ (setq count (+ count (1- (length onetable)))))
+ result)
+ count))
+
+ ;;;###autoload
+ (defun semanticdb-find-result-nth (result n)
+ "In RESULT, return the Nth search result.
+ This is a 0 based search result, with the first match being element 0.
+
+ The returned value is a cons cell: (TAG . TABLE) where TAG
+ is the tag at the Nth position. TABLE is the semanticdb table where
+ the TAG was found. Sometimes TABLE can be nil."
+ (let ((ans nil)
+ (anstable nil))
+ ;; Loop over each single table hit.
+ (while (and (not ans) result)
+ ;; For each table result, get local length, and modify
+ ;; N to be that much less.
+ (let ((ll (length (cdr (car result))))) ;; local length
+ (if (> ll n)
+ ;; We have a local match.
+ (setq ans (nth n (cdr (car result)))
+ anstable (car (car result)))
+ ;; More to go. Decrement N.
+ (setq n (- n ll))))
+ ;; Keep moving.
+ (setq result (cdr result)))
+ (cons ans anstable)))
+
+ (defun semanticdb-find-result-test (result)
+ "Test RESULT by accessing all the tags in the list."
+ (if (not (semanticdb-find-results-p result))
+ (error "Does not pass `semanticdb-find-results-p.\n"))
+ (let ((len (semanticdb-find-result-length result))
+ (i 0))
+ (while (< i len)
+ (let ((tag (semanticdb-find-result-nth result i)))
+ (if (not (semantic-tag-p (car tag)))
+ (error "%d entry is not a tag" i)))
+ (setq i (1+ i)))))
+
+ ;;;###autoload
+ (defun semanticdb-find-result-nth-in-buffer (result n)
+ "In RESULT, return the Nth search result.
+ Like `semanticdb-find-result-nth', except that only the TAG
+ is returned, and the buffer it is found it will be made current.
+ If the result tag has no position information, the originating buffer
+ is still made current."
+ (let* ((ret (semanticdb-find-result-nth result n))
+ (ans (car ret))
+ (anstable (cdr ret)))
+ ;; If we have a hit, double-check the find-file
+ ;; entry. If the file must be loaded, then gat that table's
+ ;; source file into a buffer.
+
+ (if anstable
+ (let ((norm (semanticdb-normalize-one-tag anstable ans)))
+ (when norm
+ ;; The normalized tags can now be found based on that
+ ;; tags table.
+ (semanticdb-set-buffer (car norm))
+ ;; Now reset ans
+ (setq ans (cdr norm))
+ ))
+ )
+ ;; Return the tag.
+ ans))
+
+ (defun semanticdb-find-result-mapc (fcn result)
+ "Apply FCN to each element of find RESULT for side-effects only.
+ FCN takes two arguments. The first is a TAG, and the
+ second is a DB from wence TAG originated.
+ Returns result."
+ (mapc (lambda (sublst)
+ (mapc (lambda (tag)
+ (funcall fcn tag (car sublst)))
+ (cdr sublst)))
+ result)
+ result)
+
+ ;;; Search Logging
+ ;;
+ ;; Basic logging to see what the search routines are doing.
+ (defvar semanticdb-find-log-flag nil
+ "Non-nil means log the process of searches.")
+
+ (defvar semanticdb-find-log-buffer-name "*SemanticDB Find Log*"
+ "The name of the logging buffer.")
+
+ (defun semanticdb-find-toggle-logging ()
+ "Toggle sematnicdb logging."
+ (interactive)
+ (setq semanticdb-find-log-flag (null semanticdb-find-log-flag))
+ (message "Semanticdb find logging is %sabled"
+ (if semanticdb-find-log-flag "en" "dis")))
+
+ (defun semanticdb-reset-log ()
+ "Reset the log buffer."
+ (interactive)
+ (when semanticdb-find-log-flag
+ (save-excursion
+ (set-buffer (get-buffer-create semanticdb-find-log-buffer-name))
+ (erase-buffer)
+ )))
+
+ (defun semanticdb-find-log-move-to-end ()
+ "Move to the end of the semantic log."
+ (let ((cb (current-buffer))
+ (cw (selected-window)))
+ (unwind-protect
+ (progn
+ (set-buffer semanticdb-find-log-buffer-name)
+ (if (get-buffer-window (current-buffer) 'visible)
+ (select-window (get-buffer-window (current-buffer) 'visible)))
+ (goto-char (point-max)))
+ (if cw (select-window cw))
+ (set-buffer cb))))
+
+ (defun semanticdb-find-log-new-search (forwhat)
+ "Start a new search FORWHAT."
+ (when semanticdb-find-log-flag
+ (save-excursion
+ (set-buffer (get-buffer-create semanticdb-find-log-buffer-name))
+ (insert (format "New Search: %S\n" forwhat))
+ )
+ (semanticdb-find-log-move-to-end)))
+
+ (defun semanticdb-find-log-activity (table result)
+ "Log that TABLE has been searched and RESULT was found."
+ (when semanticdb-find-log-flag
+ (save-excursion
+ (set-buffer semanticdb-find-log-buffer-name)
+ (insert "Table: " (object-print table)
+ " Result: " (int-to-string (length result)) " tags"
+ "\n")
+ )
+ (semanticdb-find-log-move-to-end)))
+
+ ;;; Semanticdb find API functions
+ ;; These are the routines actually used to perform searches.
+ ;;
+ (defun semanticdb-find-tags-collector (function &optional path find-file-match
+ brutish)
+ "Collect all tags returned by FUNCTION over PATH.
+ The FUNCTION must take two arguments. The first is TABLE,
+ which is a semanticdb table containing tags. The second argument
+ to FUNCTION is TAGS. TAGS may be a list of tags. If TAGS is non-nil, then
+ FUNCTION should search the TAG list, not through TABLE.
+
+ See `semanticdb-find-translate-path' for details on PATH.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer.
+
+ Note: You should leave FIND-FILE-MATCH as nil. It is far more
+ efficient to take the results from any search and use
+ `semanticdb-strip-find-results' instead. This argument is here
+ for backward compatibility.
+
+ If optional argument BRUTISH is non-nil, then ignore include statements,
+ and search all tables in this project tree."
+ (let (found match)
+ (save-excursion
+ ;; If path is a buffer, set ourselves up in that buffer
+ ;; so that the override methods work correctly.
+ (when (bufferp path) (set-buffer path))
+ (if (semanticdb-find-results-p path)
+ ;; When we get find results, loop over that.
+ (dolist (tableandtags path)
+ (semantic-throw-on-input 'semantic-find-translate-path)
+ ;; If FIND-FILE-MATCH is non-nil, skip tables of class
+ ;; `semanticdb-search-results-table', since those are system
+ ;; databases and not associated with a file.
+ (unless (and find-file-match
+ (obj-of-class-p
+ (car tableandtags) semanticdb-search-results-table))
+ (when (setq match (funcall function
+ (car tableandtags) (cdr tableandtags)))
+ (when find-file-match
+ (save-excursion (semanticdb-set-buffer (car tableandtags))))
+ (push (cons (car tableandtags) match) found)))
+ )
+ ;; Only log searches across data bases.
+ (semanticdb-find-log-new-search nil)
+ ;; If we get something else, scan the list of tables resulting
+ ;; from translating it into a list of objects.
+ (dolist (table (semanticdb-find-translate-path path brutish))
+ (semantic-throw-on-input 'semantic-find-translate-path)
+ ;; If FIND-FILE-MATCH is non-nil, skip tables of class
+ ;; `semanticdb-search-results-table', since those are system
+ ;; databases and not associated with a file.
+ (unless (and find-file-match
+ (obj-of-class-p table semanticdb-search-results-table))
+ (when (and table (setq match (funcall function table nil)))
+ (semanticdb-find-log-activity table match)
+ (when find-file-match
+ (save-excursion (semanticdb-set-buffer table)))
+ (push (cons table match) found))))))
+ ;; At this point, FOUND has had items pushed onto it.
+ ;; This means items are being returned in REVERSE order
+ ;; of the tables searched, so if you just get th CAR, then
+ ;; too-bad, you may have some system-tag that has no
+ ;; buffer associated with it.
+
+ ;; It must be reversed.
+ (nreverse found)))
+
+ ;;;###autoload
+ (defun semanticdb-find-tags-by-name (name &optional path find-file-match)
+ "Search for all tags matching NAME on PATH.
+ See `semanticdb-find-translate-path' for details on PATH.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-by-name-method table name tags))
+ path find-file-match))
+
+ ;;;###autoload
+ (defun semanticdb-find-tags-by-name-regexp (regexp &optional path find-file-match)
+ "Search for all tags matching REGEXP on PATH.
+ See `semanticdb-find-translate-path' for details on PATH.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-by-name-regexp-method table regexp tags))
+ path find-file-match))
+
+ ;;;###autoload
+ (defun semanticdb-find-tags-for-completion (prefix &optional path find-file-match)
+ "Search for all tags matching PREFIX on PATH.
+ See `semanticdb-find-translate-path' for details on PATH.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-for-completion-method table prefix tags))
+ path find-file-match))
+
+ ;;;###autoload
+ (defun semanticdb-find-tags-by-class (class &optional path find-file-match)
+ "Search for all tags of CLASS on PATH.
+ See `semanticdb-find-translate-path' for details on PATH.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-by-class-method table class tags))
+ path find-file-match))
+
+ ;;; Deep Searches
+ (defun semanticdb-deep-find-tags-by-name (name &optional path find-file-match)
+ "Search for all tags matching NAME on PATH.
+ Search also in all components of top level tags founds.
+ See `semanticdb-find-translate-path' for details on PATH.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-deep-find-tags-by-name-method table name tags))
+ path find-file-match))
+
+ (defun semanticdb-deep-find-tags-by-name-regexp (regexp &optional path find-file-match)
+ "Search for all tags matching REGEXP on PATH.
+ Search also in all components of top level tags founds.
+ See `semanticdb-find-translate-path' for details on PATH.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-deep-find-tags-by-name-regexp-method table regexp tags))
+ path find-file-match))
+
+ (defun semanticdb-deep-find-tags-for-completion (prefix &optional path find-file-match)
+ "Search for all tags matching PREFIX on PATH.
+ Search also in all components of top level tags founds.
+ See `semanticdb-find-translate-path' for details on PATH.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-deep-find-tags-for-completion-method table prefix tags))
+ path find-file-match))
+
+ ;;; Brutish Search Routines
+ ;;
+ (defun semanticdb-brute-deep-find-tags-by-name (name &optional path find-file-match)
+ "Search for all tags matching NAME on PATH.
+ See `semanticdb-find-translate-path' for details on PATH.
+ The argument BRUTISH will be set so that searching includes all tables
+ in the current project.
+ FIND-FILE-MATCH indicates that any time a matchi is found, the file
+ associated wit that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-deep-find-tags-by-name-method table name tags))
+ path find-file-match t))
+
+ (defun semanticdb-brute-deep-find-tags-for-completion (prefix &optional path find-file-match)
+ "Search for all tags matching PREFIX on PATH.
+ See `semanticdb-find-translate-path' for details on PATH.
+ The argument BRUTISH will be set so that searching includes all tables
+ in the current project.
+ FIND-FILE-MATCH indicates that any time a matchi is found, the file
+ associated wit that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-deep-find-tags-for-completion-method table prefix tags))
+ path find-file-match t))
+
+ (defun semanticdb-brute-find-tags-by-class (class &optional path find-file-match)
+ "Search for all tags of CLASS on PATH.
+ See `semanticdb-find-translate-path' for details on PATH.
+ The argument BRUTISH will be set so that searching includes all tables
+ in the current project.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-by-class-method table class tags))
+ path find-file-match t))
+
+ ;;; Specialty Search Routines
+ (defun semanticdb-find-tags-external-children-of-type
+ (type &optional path find-file-match)
+ "Search for all tags defined outside of TYPE w/ TYPE as a parent.
+ See `semanticdb-find-translate-path' for details on PATH.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-external-children-of-type-method table type tags))
+ path find-file-match))
+
+ (defun semanticdb-find-tags-subclasses-of-type
+ (type &optional path find-file-match)
+ "Search for all tags of class type defined that subclass TYPE.
+ See `semanticdb-find-translate-path' for details on PATH.
+ FIND-FILE-MATCH indicates that any time a match is found, the file
+ associated with that tag should be loaded into a buffer."
+ (semanticdb-find-tags-collector
+ (lambda (table tags)
+ (semanticdb-find-tags-subclasses-of-type-method table type tags))
+ path find-file-match t))
+ \f
+ ;;; METHODS
+ ;;
+ ;; Default methods for semanticdb database and table objects.
+ ;; Override these with system databases to as new types of back ends.
+
+ ;;; Top level Searches
+ (defmethod semanticdb-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags)
+ "In TABLE, find all occurances of tags with NAME.
+ Optional argument TAGS is a list of tags to search.
+ Returns a table of all matching tags."
+ (semantic-find-tags-by-name name (or tags (semanticdb-get-tags table))))
+
+ (defmethod semanticdb-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags)
+ "In TABLE, find all occurances of tags matching REGEXP.
+ Optional argument TAGS is a list of tags to search.
+ Returns a table of all matching tags."
+ (semantic-find-tags-by-name-regexp regexp (or tags (semanticdb-get-tags table))))
+
+ (defmethod semanticdb-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+ Optional argument TAGS is a list of tags to search.
+ Returns a table of all matching tags."
+ (semantic-find-tags-for-completion prefix (or tags (semanticdb-get-tags table))))
+
+ (defmethod semanticdb-find-tags-by-class-method ((table semanticdb-abstract-table) class &optional tags)
+ "In TABLE, find all occurances of tags of CLASS.
+ Optional argument TAGS is a list of tags to search.
+ Returns a table of all matching tags."
+ (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table))))
+
+ (defmethod semanticdb-find-tags-external-children-of-type-method ((table semanticdb-abstract-table) parent &optional tags)
+ "In TABLE, find all occurances of tags whose parent is the PARENT type.
+ Optional argument TAGS is a list of tags to search.
+ Returns a table of all matching tags."
++ (require 'semantic/find)
+ (semantic-find-tags-external-children-of-type parent (or tags (semanticdb-get-tags table))))
+
+ (defmethod semanticdb-find-tags-subclasses-of-type-method ((table semanticdb-abstract-table) parent &optional tags)
+ "In TABLE, find all occurances of tags whose parent is the PARENT type.
+ Optional argument TAGS is a list of tags to search.
+ Returns a table of all matching tags."
++ (require 'semantic/find)
+ (semantic-find-tags-subclasses-of-type parent (or tags (semanticdb-get-tags table))))
+
+ ;;; Deep Searches
+ (defmethod semanticdb-deep-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags)
+ "In TABLE, find all occurances of tags with NAME.
+ Search in all tags in TABLE, and all components of top level tags in
+ TABLE.
+ Optional argument TAGS is a list of tags to search.
+ Return a table of all matching tags."
+ (semantic-find-tags-by-name name (semantic-flatten-tags-table (or tags (semanticdb-get-tags table)))))
+
+ (defmethod semanticdb-deep-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags)
+ "In TABLE, find all occurances of tags matching REGEXP.
+ Search in all tags in TABLE, and all components of top level tags in
+ TABLE.
+ Optional argument TAGS is a list of tags to search.
+ Return a table of all matching tags."
+ (semantic-find-tags-by-name-regexp regexp (semantic-flatten-tags-table (or tags (semanticdb-get-tags table)))))
+
+ (defmethod semanticdb-deep-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+ Search in all tags in TABLE, and all components of top level tags in
+ TABLE.
+ Optional argument TAGS is a list of tags to search.
+ Return a table of all matching tags."
+ (semantic-find-tags-for-completion prefix (semantic-flatten-tags-table (or tags (semanticdb-get-tags table)))))
+
+ (provide 'semantic/db-find)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/db-find"
+ ;; End:
+
+ ;;; semantic/db-find.el ends here
--- /dev/null
- (require 'eieio-opt)
- )
+ ;;; semantic/db-javascript.el --- Semantic database extensions for javascript
+
+ ;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Joakim Verona
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Semanticdb database for Javascript.
+ ;;
+ ;; This is an omniscient database with a hard-coded list of symbols for
+ ;; Javascript. See the doc at the end of this file for adding or modifying
+ ;; the list of tags.
+ ;;
+
+ (require 'semantic/db)
+ (require 'semantic/db-find)
+
+ (eval-when-compile
+ ;; For generic function searching.
+ (require 'eieio)
++ (require 'eieio-opt))
++
+ ;;; Code:
+ (defvar semanticdb-javascript-tags
+ '(("eval" function
+ (:arguments
+ (("x" variable nil nil nil)))
+ nil nil)
+ ("parseInt" function
+ (:arguments
+ (("string" variable nil nil nil)
+ ("radix" variable nil nil nil)))
+ nil nil)
+ ("parseFloat" function
+ (:arguments
+ (("string" variable nil nil nil)))
+ nil nil)
+ ("isNaN" function
+ (:arguments
+ (("number" variable nil nil nil)))
+ nil nil)
+ ("isFinite" function
+ (:arguments
+ (("number" variable nil nil nil)))
+ nil nil)
+ ("decodeURI" function
+ (:arguments
+ (("encodedURI" variable nil nil nil)))
+ nil nil)
+ ("decodeURIComponent" function
+ (:arguments
+ (("encodedURIComponent" variable nil nil nil)))
+ nil nil)
+ ("encodeURI" function
+ (:arguments
+ (("uri" variable nil nil nil)))
+ nil nil)
+ ("encodeURIComponent" function
+ (:arguments
+ (("uriComponent" variable nil nil nil)))
+ nil nil))
+ "Hard-coded list of javascript tags for semanticdb.
+ See bottom of this file for instruction on managing this list.")
+
+ ;;; Classes:
+ (defclass semanticdb-table-javascript (semanticdb-search-results-table)
+ ((major-mode :initform javascript-mode)
+ )
+ "A table for returning search results from javascript.")
+
+ (defclass semanticdb-project-database-javascript
+ (semanticdb-project-database
+ eieio-singleton ;this db is for js globals, so singleton is apropriate
+ )
+ ((new-table-class :initform semanticdb-table-javascript
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ )
+ "Database representing javascript.")
+
+ ;; Create the database, and add it to searchable databases for javascript mode.
+ (defvar-mode-local javascript-mode semanticdb-project-system-databases
+ (list
+ (semanticdb-project-database-javascript "Javascript"))
+ "Search javascript for symbols.")
+
+ ;; NOTE: Be sure to modify this to the best advantage of your
+ ;; language.
+ (defvar-mode-local javascript-mode semanticdb-find-default-throttle
+ '(project omniscience)
+ "Search project files, then search this omniscience database.
+ It is not necessary to to system or recursive searching because of
+ the omniscience database.")
+
+ ;;; Filename based methods
+ ;;
+ (defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-javascript))
+ "For a javascript database, there are no explicit tables.
+ Create one of our special tables that can act as an intermediary."
+ ;; NOTE: This method overrides an accessor for the `tables' slot in
+ ;; a database. You can either construct your own (like tmp here
+ ;; or you can manage any number of tables.
+
+ ;; We need to return something since there is always the "master table"
+ ;; The table can then answer file name type questions.
+ (when (not (slot-boundp obj 'tables))
+ (let ((newtable (semanticdb-table-javascript "tmp")))
+ (oset obj tables (list newtable))
+ (oset newtable parent-db obj)
+ (oset newtable tags nil)
+ ))
+ (call-next-method)
+ )
+
+ (defmethod semanticdb-file-table ((obj semanticdb-project-database-javascript) filename)
+ "From OBJ, return FILENAME's associated table object."
+ ;; NOTE: See not for `semanticdb-get-database-tables'.
+ (car (semanticdb-get-database-tables obj))
+ )
+
+ (defmethod semanticdb-get-tags ((table semanticdb-table-javascript ))
+ "Return the list of tags belonging to TABLE."
+ ;; NOTE: Omniscient databases probably don't want to keep large tabes
+ ;; lolly-gagging about. Keep internal Emacs tables empty and
+ ;; refer to alternate databases when you need something.
+ semanticdb-javascript-tags)
+
+ (defmethod semanticdb-equivalent-mode ((table semanticdb-table-javascript) &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
+ (set-buffer buffer)
+ (eq (or mode-local-active-mode major-mode) 'javascript-mode)))
+
+ ;;; Usage
+ ;;
+ ;; Unlike other tables, an omniscent database does not need to
+ ;; be associated with a path. Use this routine to always add ourselves
+ ;; to a search list.
+ (define-mode-local-override semanticdb-find-translate-path javascript-mode
+ (path brutish)
+ "Return a list of semanticdb tables asociated with PATH.
+ If brutish, do the default action.
+ If not brutish, do the default action, and append the system
+ database (if available.)"
+ (let ((default
+ ;; When we recurse, disable searching of system databases
+ ;; so that our Javascript database only shows up once when
+ ;; we append it in this iteration.
+ (let ((semanticdb-search-system-databases nil)
+ )
+ (semanticdb-find-translate-path-default path brutish))))
+ ;; Don't add anything if BRUTISH is on (it will be added in that fcn)
+ ;; or if we aren't supposed to search the system.
+ (if (or brutish (not semanticdb-search-system-databases))
+ default
+ (let ((tables (apply #'append
+ (mapcar
+ (lambda (db) (semanticdb-get-database-tables db))
+ semanticdb-project-system-databases))))
+ (append default tables)))))
+
+ ;;; Search Overrides
+ ;;
+ ;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining
+ ;; how your new search routines are implemented.
+ ;;
+ (defun semanticdb-javascript-regexp-search (regexp)
+ "Search for REGEXP in our fixed list of javascript tags."
+ (let* ((tags semanticdb-javascript-tags)
+ (result nil))
+ (while tags
+ (if (string-match regexp (caar tags))
+ (setq result (cons (car tags) result)))
+ (setq tags (cdr tags)))
+ result))
+
+ (defmethod semanticdb-find-tags-by-name-method
+ ((table semanticdb-table-javascript) name &optional tags)
+ "Find all tags named NAME in TABLE.
+ Return a list of tags."
+ (if tags
+ ;; If TAGS are passed in, then we don't need to do work here.
+ (call-next-method)
+ (assoc-string name semanticdb-javascript-tags)
+ ))
+
+ (defmethod semanticdb-find-tags-by-name-regexp-method
+ ((table semanticdb-table-javascript) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+ Optional argument TAGS is a list of tags to search.
+ Return a list of tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (semanticdb-javascript-regexp-search regex)
+
+ ))
+
+ (defmethod semanticdb-find-tags-for-completion-method
+ ((table semanticdb-table-javascript) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+ Optional argument TAGS is a list of tags to search.
+ Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ (semanticdb-javascript-regexp-search (concat "^" prefix ".*"))
+ ))
+
+ (defmethod semanticdb-find-tags-by-class-method
+ ((table semanticdb-table-javascript) class &optional tags)
+ "In TABLE, find all occurances of tags of CLASS.
+ Optional argument TAGS is a list of tags to search.
+ Returns a table of all matching tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ ;;
+ ;; Note: This search method could be considered optional in an
+ ;; omniscient database. It may be unwise to return all tags
+ ;; that exist for a language that are a variable or function.
+ ;;
+ ;; If it is optional, you can just delete this method.
+ nil))
+
+ ;;; Deep Searches
+ ;;
+ ;; If your language does not have a `deep' concept, these can be left
+ ;; alone, otherwise replace with implementations similar to those
+ ;; above.
+ ;;
+ (defmethod semanticdb-deep-find-tags-by-name-method
+ ((table semanticdb-table-javascript) name &optional tags)
+ "Find all tags name NAME in TABLE.
+ Optional argument TAGS is a list of tags t
+ Like `semanticdb-find-tags-by-name-method' for javascript."
+ (semanticdb-find-tags-by-name-method table name tags))
+
+ (defmethod semanticdb-deep-find-tags-by-name-regexp-method
+ ((table semanticdb-table-javascript) regex &optional tags)
+ "Find all tags with name matching REGEX in TABLE.
+ Optional argument TAGS is a list of tags to search.
+ Like `semanticdb-find-tags-by-name-method' for javascript."
+ (semanticdb-find-tags-by-name-regexp-method table regex tags))
+
+ (defmethod semanticdb-deep-find-tags-for-completion-method
+ ((table semanticdb-table-javascript) prefix &optional tags)
+ "In TABLE, find all occurances of tags matching PREFIX.
+ Optional argument TAGS is a list of tags to search.
+ Like `semanticdb-find-tags-for-completion-method' for javascript."
+ (semanticdb-find-tags-for-completion-method table prefix tags))
+
+ ;;; Advanced Searches
+ ;;
+ (defmethod semanticdb-find-tags-external-children-of-type-method
+ ((table semanticdb-table-javascript) type &optional tags)
+ "Find all nonterminals which are child elements of TYPE
+ Optional argument TAGS is a list of tags to search.
+ Return a list of tags."
+ (if tags (call-next-method)
+ ;; YOUR IMPLEMENTATION HERE
+ ;;
+ ;; OPTIONAL: This could be considered an optional function. It is
+ ;; used for `semantic-adopt-external-members' and may not
+ ;; be possible to do in your language.
+ ;;
+ ;; If it is optional, you can just delete this method.
+ ))
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (defun semanticdb-javascript-strip-tags (tags)
+ "Strip TAGS from overlays and reparse symbols."
+ (cond ((and (consp tags) (eq 'reparse-symbol (car tags)))
+ nil)
+ ((overlayp tags) nil)
+ ((atom tags) tags)
+ (t (cons (semanticdb-javascript-strip-tags
+ (car tags)) (semanticdb-javascript-strip-tags
+ (cdr tags))))))
+
+ ;this list was made from a javascript file, and the above function
+ ;; function eval(x){}
+ ;; function parseInt(string,radix){}
+ ;; function parseFloat(string){}
+ ;; function isNaN(number){}
+ ;; function isFinite(number){}
+ ;; function decodeURI(encodedURI){}
+ ;; function decodeURIComponent (encodedURIComponent){}
+ ;; function encodeURI (uri){}
+ ;; function encodeURIComponent (uriComponent){}
+
+ (provide 'semantic/db-javascript)
+
+ ;;; semantic/db-javascript.el ends here
--- /dev/null
-(require 'semantic/db)
+ ;;; semantic/db-mode.el --- Semanticdb Minor Mode
+
+ ;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Major mode for managing Semantic Databases automatically.
+
-;; Moved into semantic/db.el:
-;; (defvar semanticdb-current-database nil
-;; "For a given buffer, this is the currently active database.")
-;; (make-variable-buffer-local 'semanticdb-current-database)
-
-;; (defvar semanticdb-current-table nil
-;; "For a given buffer, this is the currently active database table.")
-;; (make-variable-buffer-local 'semanticdb-current-table)
+ ;;; Code:
+
++(require 'semantic/db)
+
+ (declare-function semantic-lex-spp-set-dynamic-table "semantic/lex-spp")
+
+ ;;; Start/Stop database use
+ ;;
+ (defvar semanticdb-hooks
+ '((semanticdb-semantic-init-hook-fcn semantic-init-db-hook)
+ (semanticdb-synchronize-table semantic-after-toplevel-cache-change-hook)
+ (semanticdb-partial-synchronize-table semantic-after-partial-cache-change-hook)
+ (semanticdb-revert-hook before-revert-hook)
+ (semanticdb-kill-hook kill-buffer-hook)
+ (semanticdb-kill-hook change-major-mode-hook) ;; Not really a kill, but we need the same effect.
+ (semanticdb-kill-emacs-hook kill-emacs-hook)
+ (semanticdb-save-all-db-idle auto-save-hook)
+ )
+ "List of hooks and values to add/remove when configuring semanticdb.")
+
+ ;;; SEMANTICDB-MODE
+ ;;
+ ;;;###autoload
+ (defun semanticdb-minor-mode-p ()
+ "Return non-nil if `semanticdb-minor-mode' is active."
+ (member (car (car semanticdb-hooks))
+ (symbol-value (car (cdr (car semanticdb-hooks))))))
+
+ ;;;###autoload
+ (define-minor-mode global-semanticdb-minor-mode
+ "Toggle Semantic DB mode.
+ With ARG, turn Semantic DB mode on if ARG is positive, off otherwise.
+
+ In Semantic DB mode, Semantic parsers store results in a
+ database, which can be saved for future Emacs sessions."
+ :global t
+ :group 'semantic
+ (if global-semanticdb-minor-mode
+ ;; Enable
+ (dolist (elt semanticdb-hooks)
+ (add-hook (cadr elt) (car elt)))
+ ;; Disable
+ (dolist (elt semanticdb-hooks)
+ (add-hook (cadr elt) (car elt)))))
+
+ (defvaralias 'semanticdb-mode-hook 'global-semanticdb-minor-mode-hook)
+ (defvaralias 'semanticdb-global-mode 'global-semanticdb-minor-mode)
+ (semantic-varalias-obsolete 'semanticdb-mode-hooks
+ 'global-semanticdb-minor-mode-hook)
+
+
+ (defun semanticdb-toggle-global-mode ()
+ "Toggle use of the Semantic Database feature.
+ Update the environment of Semantic enabled buffers accordingly."
+ (interactive)
+ (if (semanticdb-minor-mode-p)
+ ;; Save databases before disabling semanticdb.
+ (semanticdb-save-all-db))
+ ;; Toggle semanticdb minor mode.
+ (global-semanticdb-minor-mode))
+
+ ;;; Hook Functions:
+ ;;
+ ;; Functions used in hooks to keep SemanticDB operating.
+ ;;
+ (defun semanticdb-semantic-init-hook-fcn ()
+ "Function saved in `semantic-init-db-hook'.
+ Sets up the semanticdb environment."
+ ;; Only initialize semanticdb if we have a file name.
+ ;; There is no reason to cache a tag table if there is no
+ ;; way to load it back in later.
+ (when (buffer-file-name)
+ (let* ((ans (semanticdb-create-table-for-file (buffer-file-name)))
+ (cdb (car ans))
+ (ctbl (cdr ans))
+ )
+ ;; Get the current DB for this directory
+ (setq semanticdb-current-database cdb)
+ ;; We set the major mode because we know what it is.
+ (oset ctbl major-mode major-mode)
+ ;; Local state
+ (setq semanticdb-current-table ctbl)
+ ;; Try to swap in saved tags
+ (if (or (not (slot-boundp ctbl 'tags)) (not (oref ctbl tags))
+ (/= (or (oref ctbl pointmax) 0) (point-max))
+ )
+ (semantic-clear-toplevel-cache)
+ ;; Unmatched syntax
+ (condition-case nil
+ (semantic-set-unmatched-syntax-cache
+ (oref ctbl unmatched-syntax))
+ (unbound-slot
+ ;; Old version of the semanticdb table can miss the unmatched
+ ;; syntax slot. If so, just clear the unmatched syntax cache.
+ (semantic-clear-unmatched-syntax-cache)
+ ;; Make sure it has a value.
+ (oset ctbl unmatched-syntax nil)
+ ))
+ ;; Keep lexical tables up to date. Don't load
+ ;; semantic-spp if it isn't needed.
+ (let ((lt (oref ctbl lexical-table)))
+ (when lt
+ (require 'semantic/lex-spp)
+ (semantic-lex-spp-set-dynamic-table lt)))
+ ;; Set the main tag cache.
+ ;; This must happen after setting up buffer local variables
+ ;; since this will turn around and re-save those variables.
+ (semantic--set-buffer-cache (oref ctbl tags))
+ ;; Don't need it to be dirty. Set dirty due to hooks from above.
+ (oset ctbl dirty nil) ;; Special case here.
+ (oset ctbl buffer (current-buffer))
+ ;; Bind into the buffer.
+ (semantic--tag-link-cache-to-buffer)
+ )
+ )))
+
+ (defun semanticdb-revert-hook ()
+ "Hook run before a revert buffer.
+ We can't track incremental changes due to a revert, so just clear the cache.
+ This will prevent the next batch of hooks from wasting time parsing things
+ that don't need to be parsed."
+ (if (and (semantic-active-p)
+ semantic--buffer-cache
+ semanticdb-current-table)
+ (semantic-clear-toplevel-cache)))
+
+ (defun semanticdb-kill-hook ()
+ "Function run when a buffer is killed.
+ If there is a semantic cache, slurp out the overlays, and store
+ it in our database. If that buffer has no cache, ignore it, we'll
+ handle it later if need be."
+ (when (and (semantic-active-p)
+ semantic--buffer-cache
+ semanticdb-current-table)
+
+ ;; Try to get a fast update.
+ (semantic-fetch-tags-fast)
+
+ ;; If the buffer is in a bad state, don't save anything...
+ (if (semantic-parse-tree-needs-rebuild-p)
+ ;; If this is the case, don't save anything.
+ (progn
+ (semantic-clear-toplevel-cache)
+ (oset semanticdb-current-table pointmax 0)
+ (oset semanticdb-current-table fsize 0)
+ (oset semanticdb-current-table lastmodtime nil)
+ )
+ ;; We have a clean buffer, save it off.
+ (condition-case nil
+ (progn
+ (semantic--tag-unlink-cache-from-buffer)
+ ;; Set pointmax only if we had some success in the unlink.
+ (oset semanticdb-current-table pointmax (point-max))
+ (let ((fattr (file-attributes
+ (semanticdb-full-filename
+ semanticdb-current-table))))
+ (oset semanticdb-current-table fsize (nth 7 fattr))
+ (oset semanticdb-current-table lastmodtime (nth 5 fattr))
+ (oset semanticdb-current-table buffer nil)
+ ))
+ ;; If this messes up, just clear the system
+ (error
+ (semantic-clear-toplevel-cache)
+ (message "semanticdb: Failed to deoverlay tag cache.")))
+ )
+ ))
+
+ (defun semanticdb-kill-emacs-hook ()
+ "Function called when Emacs is killed.
+ Save all the databases."
+ (semanticdb-save-all-db))
+
+ ;;; SYNCHRONIZATION HOOKS
+ ;;
+ (defun semanticdb-synchronize-table (new-table)
+ "Function run after parsing.
+ Argument NEW-TABLE is the new table of tags."
+ (when semanticdb-current-table
+ (semanticdb-synchronize semanticdb-current-table new-table)))
+
+ (defun semanticdb-partial-synchronize-table (new-table)
+ "Function run after parsing.
+ Argument NEW-TABLE is the new table of tags."
+ (when semanticdb-current-table
+ (semanticdb-partial-synchronize semanticdb-current-table new-table)))
+
+
+ (provide 'semantic/db-mode)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/db-mode"
+ ;; End:
+
+ ;;; semantic/db-mode.el ends here
--- /dev/null
-(require 'eieio)
+ ;;; semantic/db.el --- Semantic tag database manager
+
+ ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
+ ;;; 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: tags
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Maintain a database of tags for a group of files and enable
+ ;; queries into the database.
+ ;;
+ ;; By default, assume one database per directory.
+ ;;
+
-(eval-when-compile
- (require 'semantic/lex-spp))
++;;; Code:
++
+ (require 'eieio-base)
+ (require 'semantic)
- :group 'semantic
- )
-;;; Code:
++
++(declare-function semantic-lex-spp-save-table "semantic/lex-spp")
+
+ ;;; Variables:
+ (defgroup semanticdb nil
+ "Parser Generator Persistent Database interface."
++ :group 'semantic)
++
+ (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)
+
+ ;;;###autoload
+ (defvar semanticdb-current-database nil
+ "For a given buffer, this is the currently active database.")
+ (make-variable-buffer-local 'semanticdb-current-database)
+
+ ;;;###autoload
+ (defvar semanticdb-current-table nil
+ "For a given buffer, this is the currently active database table.")
+ (make-variable-buffer-local 'semanticdb-current-table)
+
+ ;;; 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!
+ )
+
+
+ ;;; SEARCH RESULTS TABLE
+ ;;
+ ;; Needed for system databases that may not provide
+ ;; a semanticdb-table associated with a file.
+ ;;
+ (defclass semanticdb-search-results-table (semanticdb-abstract-table)
+ (
+ )
+ "Table used for search results when there is no file or table association.
+ Examples include search results from external sources such as from
+ Emacs' own symbol table, or from external libraries.")
+
+ (defmethod semanticdb-refresh-table ((obj semanticdb-search-results-table) &optional force)
+ "If the tag list associated with OBJ is loaded, refresh it.
+ This will call `semantic-fetch-tags' if that file is in memory."
+ nil)
+
+ ;;; 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)
+ ;; Save match data to protect against odd stuff in mode hooks.
+ (save-match-data
+ (find-file-noselect (semanticdb-full-filename obj) t))))
+
+ (defmethod semanticdb-set-buffer ((obj semanticdb-table))
+ "Set the current buffer to be a buffer owned by OBJ.
+ If OBJ's file is not loaded, read it in first."
+ (set-buffer (semanticdb-get-buffer obj)))
+
+ (defmethod semanticdb-full-filename ((obj semanticdb-table))
+ "Fetch the full filename that OBJ refers to."
+ (expand-file-name (oref obj file)
+ (oref (oref obj parent-db) reference-directory)))
+
+ (defmethod semanticdb-dirty-p ((obj semanticdb-table))
+ "Return non-nil if OBJ is 'dirty'."
+ (oref obj dirty))
+
+ (defmethod semanticdb-set-dirty ((obj semanticdb-table))
+ "Mark the abstract table OBJ dirty."
+ (oset obj dirty t)
+ )
+
+ (defmethod object-print ((obj semanticdb-table) &rest strings)
+ "Pretty printer extension for `semanticdb-table'.
+ Adds the number of tags in this file to the object print name."
+ (apply 'call-next-method obj
+ (cons (if (oref obj dirty) ", DIRTY" "") strings)))
+
+ ;;; DATABASE BASE CLASS
+ ;;
+ (defclass semanticdb-project-database (eieio-instance-tracker)
+ ((tracking-symbol :initform semanticdb-database-list)
+ (reference-directory :type string
+ :documentation "Directory this database refers to.
+ When a cache directory is specified, then this refers to the directory
+ this database contains symbols for.")
+ (new-table-class :initform semanticdb-table
+ :type class
+ :documentation
+ "New tables created for this database are of this class.")
+ (cache :type list
+ :initform nil
+ :documentation "List of cache information for tools.
+ Any particular tool can cache data to a database at runtime
+ with `semanticdb-cache-get'.
+
+ Using a semanticdb cache does not save any information to a file,
+ so your cache will need to be recalculated at runtime.
+
+ Note: This index will not be saved in a persistent file.")
+ (tables :initarg :tables
+ :type list
+ ;; Need this protection so apps don't try to access
+ ;; the tables without using the accessor.
+ :accessor semanticdb-get-database-tables
+ :protection :protected
+ :documentation "List of `semantic-db-table' objects."))
+ "Database of file tables.")
+
+ (defmethod semanticdb-full-filename ((obj semanticdb-project-database))
+ "Fetch the full filename that OBJ refers to.
+ Abstract tables do not have file names associated with them."
+ nil)
+
+ (defmethod semanticdb-dirty-p ((DB semanticdb-project-database))
+ "Return non-nil if DB is 'dirty'.
+ A database is dirty if the state of the database changed in a way
+ where it may need to resynchronize with some persistent storage."
+ (let ((dirty nil)
+ (tabs (oref DB tables)))
+ (while (and (not dirty) tabs)
+ (setq dirty (semanticdb-dirty-p (car tabs)))
+ (setq tabs (cdr tabs)))
+ dirty))
+
+ (defmethod object-print ((obj semanticdb-project-database) &rest strings)
+ "Pretty printer extension for `semanticdb-project-database'.
+ Adds the number of tables in this file to the object print name."
+ (apply 'call-next-method obj
+ (cons (format " (%d tables%s)"
+ (length (semanticdb-get-database-tables obj))
+ (if (semanticdb-dirty-p obj)
+ " DIRTY" "")
+ )
+ strings)))
+
+ (defmethod semanticdb-create-database :STATIC ((dbc semanticdb-project-database) directory)
+ "Create a new semantic database of class DBC for DIRECTORY and return it.
+ If a database for DIRECTORY has already been created, return it.
+ If DIRECTORY doesn't exist, create a new one."
+ (let ((db (semanticdb-directory-loaded-p directory)))
+ (unless db
+ (setq db (semanticdb-project-database
+ (file-name-nondirectory directory)
+ :tables nil))
+ ;; Set this up here. We can't put it in the constructor because it
+ ;; would be saved, and we want DB files to be portable.
+ (oset db reference-directory (file-truename directory)))
+ db))
+
+ (defmethod semanticdb-flush-database-tables ((db semanticdb-project-database))
+ "Reset the tables in DB to be empty."
+ (oset db tables nil))
+
+ (defmethod semanticdb-create-table ((db semanticdb-project-database) file)
+ "Create a new table in DB for FILE and return it.
+ The class of DB contains the class name for the type of table to create.
+ If the table for FILE exists, return it.
+ If the table for FILE does not exist, create one."
+ (let ((newtab (semanticdb-file-table db file)))
+ (unless newtab
+ ;; This implementation will satisfy autoloaded classes
+ ;; for tables.
+ (setq newtab (funcall (oref db new-table-class)
+ (file-name-nondirectory file)
+ :file (file-name-nondirectory file)
+ ))
+ (oset newtab parent-db db)
+ (object-add-to-list db 'tables newtab t))
+ newtab))
+
+ (defmethod semanticdb-file-table ((obj semanticdb-project-database) filename)
+ "From OBJ, return FILENAME's associated table object."
+ (object-assoc (file-relative-name (file-truename filename)
+ (oref obj reference-directory))
+ 'file (oref obj tables)))
+
+ ;; DATABASE FUNCTIONS
+ (defun semanticdb-get-database (filename)
+ "Get a database for FILENAME.
+ If one isn't found, create one."
+ (semanticdb-create-database semanticdb-new-database-class (file-truename filename)))
+
+ (defun semanticdb-directory-loaded-p (path)
+ "Return the project belonging to PATH if it was already loaded."
+ (eieio-instance-tracker-find path 'reference-directory 'semanticdb-database-list))
+
+ (defun semanticdb-create-table-for-file (filename)
+ "Initialize a database table for FILENAME, and return it.
+ If FILENAME exists in the database already, return that.
+ If there is no database for the table to live in, create one."
+ (let ((cdb nil)
+ (tbl nil)
+ (dd (file-name-directory filename))
+ )
+ ;; Allow a database override function
+ (setq cdb (semanticdb-create-database semanticdb-new-database-class
+ dd))
+ ;; Get a table for this file.
+ (setq tbl (semanticdb-create-table cdb filename))
+
+ ;; Return the pair.
+ (cons cdb tbl)
+ ))
+
+ ;;; Cache Cache.
+ ;;
+ (defclass semanticdb-abstract-cache ()
+ ((table :initarg :table
+ :type semanticdb-abstract-table
+ :documentation
+ "Cross reference to the table this belongs to.")
+ )
+ "Abstract baseclass for tools to use to cache information in semanticdb.
+ Tools needing a per-file cache must subclass this, and then get one as
+ needed. Cache objects are identified in semanticdb by subclass.
+ In order to keep your cache up to date, be sure to implement
+ `semanticdb-synchronize', and `semanticdb-partial-synchronize'.
+ See the file semantic-scope.el for an example."
+ :abstract t)
+
+ (defmethod semanticdb-cache-get ((table semanticdb-abstract-table)
+ desired-class)
+ "Get a cache object on TABLE of class DESIRED-CLASS.
+ This method will create one if none exists with no init arguments
+ other than :table."
+ (assert (child-of-class-p desired-class 'semanticdb-abstract-cache))
+ (let ((cache (oref table cache))
+ (obj nil))
+ (while (and (not obj) cache)
+ (if (eq (object-class-fast (car cache)) desired-class)
+ (setq obj (car cache)))
+ (setq cache (cdr cache)))
+ (if obj
+ obj ;; Just return it.
+ ;; No object, lets create a new one and return that.
+ (setq obj (funcall desired-class "Cache" :table table))
+ (object-add-to-list table 'cache obj)
+ obj)))
+
+ (defmethod semanticdb-cache-remove ((table semanticdb-abstract-table)
+ cache)
+ "Remove from TABLE the cache object CACHE."
+ (object-remove-from-list table 'cache cache))
+
+ (defmethod semanticdb-synchronize ((cache semanticdb-abstract-cache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+ (defmethod semanticdb-partial-synchronize ((cache semanticdb-abstract-cache)
+ new-tags)
+ "Synchronize a CACHE with some changed NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+ (defclass semanticdb-abstract-db-cache ()
+ ((db :initarg :db
+ :type semanticdb-project-database
+ :documentation
+ "Cross reference to the database this belongs to.")
+ )
+ "Abstract baseclass for tools to use to cache information in semanticdb.
+ Tools needing a database cache must subclass this, and then get one as
+ needed. Cache objects are identified in semanticdb by subclass.
+ In order to keep your cache up to date, be sure to implement
+ `semanticdb-synchronize', and `semanticdb-partial-synchronize'.
+ See the file semantic-scope.el for an example."
+ :abstract t)
+
+ (defmethod semanticdb-cache-get ((db semanticdb-project-database)
+ desired-class)
+ "Get a cache object on DB of class DESIRED-CLASS.
+ This method will create one if none exists with no init arguments
+ other than :table."
+ (assert (child-of-class-p desired-class 'semanticdb-abstract-db-cache))
+ (let ((cache (oref db cache))
+ (obj nil))
+ (while (and (not obj) cache)
+ (if (eq (object-class-fast (car cache)) desired-class)
+ (setq obj (car cache)))
+ (setq cache (cdr cache)))
+ (if obj
+ obj ;; Just return it.
+ ;; No object, lets create a new one and return that.
+ (setq obj (funcall desired-class "Cache" :db db))
+ (object-add-to-list db 'cache obj)
+ obj)))
+
+ (defmethod semanticdb-cache-remove ((db semanticdb-project-database)
+ cache)
+ "Remove from TABLE the cache object CACHE."
+ (object-remove-from-list db 'cache cache))
+
+
+ (defmethod semanticdb-synchronize ((cache semanticdb-abstract-db-cache)
+ new-tags)
+ "Synchronize a CACHE with some NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+ (defmethod semanticdb-partial-synchronize ((cache semanticdb-abstract-db-cache)
+ new-tags)
+ "Synchronize a CACHE with some changed NEW-TAGS."
+ ;; The abstract class will do... NOTHING!
+ )
+
+ ;;; REFRESH
+
+ (defmethod semanticdb-refresh-table ((obj semanticdb-table) &optional force)
+ "If the tag list associated with OBJ is loaded, refresh it.
+ Optional argument FORCE will force a refresh even if the file in question
+ is not in a buffer. Avoid using FORCE for most uses, as an old cache
+ may be sufficient for the general case. Forced updates can be slow.
+ This will call `semantic-fetch-tags' if that file is in memory."
+ (when (or (semanticdb-in-buffer-p obj) force)
+ (save-excursion
+ (semanticdb-set-buffer obj)
+ (semantic-fetch-tags))))
+
+ (defmethod semanticdb-needs-refresh-p ((obj semanticdb-table))
+ "Return non-nil of OBJ's tag list is out of date.
+ The file associated with OBJ does not need to be in a buffer."
+ (let* ((ff (semanticdb-full-filename obj))
+ (buff (semanticdb-in-buffer-p obj))
+ )
+ (if buff
+ (save-excursion
+ (set-buffer buff)
+ ;; Use semantic's magic tracker to determine of the buffer is up
+ ;; to date or not.
+ (not (semantic-parse-tree-up-to-date-p))
+ ;; We assume that semanticdb is keeping itself up to date.
+ ;; via all the clever hooks
+ )
+ ;; Buffer isn't loaded. The only clue we have is if the file
+ ;; is somehow different from our mark in the semanticdb table.
+ (let* ((stats (file-attributes ff))
+ (actualsize (nth 7 stats))
+ (actualmod (nth 5 stats))
+ )
+
+ (or (not (slot-boundp obj 'tags))
+ ;; (not (oref obj tags)) --> not needed anymore?
+ (/= (or (oref obj fsize) 0) actualsize)
+ (not (equal (oref obj lastmodtime) actualmod))
+ )
+ ))))
+
+ \f
+ ;;; Synchronization
+ ;;
+ (defmethod semanticdb-synchronize ((table semanticdb-abstract-table)
+ new-tags)
+ "Synchronize the table TABLE with some NEW-TAGS."
+ (oset table tags new-tags)
+ (oset table pointmax (point-max))
+ (let ((fattr (file-attributes (semanticdb-full-filename table))))
+ (oset table fsize (nth 7 fattr))
+ (oset table lastmodtime (nth 5 fattr))
+ )
+ ;; Assume it is now up to date.
+ (oset table unmatched-syntax semantic-unmatched-syntax-cache)
+ ;; The lexical table should be good too.
+ (when (featurep 'semantic/lex-spp)
+ (oset table lexical-table (semantic-lex-spp-save-table)))
+ ;; this implies dirtyness
+ (semanticdb-set-dirty table)
+
+ ;; Synchronize the index
+ (when (slot-boundp table 'index)
+ (let ((idx (oref table index)))
+ (when idx (semanticdb-synchronize idx new-tags))))
+
+ ;; Synchronize application caches.
+ (dolist (C (oref table cache))
+ (semanticdb-synchronize C new-tags)
+ )
+
+ ;; Update cross references
+ ;; (semanticdb-refresh-references table)
+ )
+
+ (defmethod semanticdb-partial-synchronize ((table semanticdb-abstract-table)
+ new-tags)
+ "Synchronize the table TABLE where some NEW-TAGS changed."
+ ;; You might think we need to reset the tags, but since the partial
+ ;; parser splices the lists, we don't need to do anything
+ ;;(oset table tags new-tags)
+ ;; We do need to mark ourselves dirty.
+ (semanticdb-set-dirty table)
+
+ ;; The lexical table may be modified.
+ (when (featurep 'semantic/lex-spp)
+ (oset table lexical-table (semantic-lex-spp-save-table)))
+
+ ;; Incremental parser doesn't mokey around with this.
+ (oset table unmatched-syntax semantic-unmatched-syntax-cache)
+
+ ;; Synchronize the index
+ (when (slot-boundp table 'index)
+ (let ((idx (oref table index)))
+ (when idx (semanticdb-partial-synchronize idx new-tags))))
+
+ ;; Synchronize application caches.
+ (dolist (C (oref table cache))
+ (semanticdb-synchronize C new-tags)
+ )
+
+ ;; Update cross references
+ ;;(when (semantic-find-tags-by-class 'include new-tags)
+ ;; (semanticdb-refresh-references table))
+ )
+
+ ;;; SAVE/LOAD
+ ;;
+ (defmethod semanticdb-save-db ((DB semanticdb-project-database)
+ &optional supress-questions)
+ "Cause a database to save itself.
+ The database base class does not save itself persistently.
+ Subclasses could save themselves to a file, or to a database, or other
+ form."
+ nil)
+
+ (defun semanticdb-save-current-db ()
+ "Save the current tag database."
+ (interactive)
+ (message "Saving current tag summaries...")
+ (semanticdb-save-db semanticdb-current-database)
+ (message "Saving current tag summaries...done"))
+
+ ;; This prevents Semanticdb from querying multiple times if the users
+ ;; answers "no" to creating the Semanticdb directory.
+ (defvar semanticdb--inhibit-create-file-directory)
+
+ (defun semanticdb-save-all-db ()
+ "Save all semantic tag databases."
+ (interactive)
+ (message "Saving tag summaries...")
+ (let ((semanticdb--inhibit-make-directory nil))
+ (mapc 'semanticdb-save-db semanticdb-database-list))
+ (message "Saving tag summaries...done"))
+
+ (defun semanticdb-save-all-db-idle ()
+ "Save all semantic tag databases from idle time.
+ Exit the save between databases if there is user input."
+ (semantic-safe "Auto-DB Save: %S"
+ (semantic-exit-on-input 'semanticdb-idle-save
+ (mapc (lambda (db)
+ (semantic-throw-on-input 'semanticdb-idle-save)
+ (semanticdb-save-db db t))
+ semanticdb-database-list))
+ ))
+
+ ;;; Directory Project support
+ ;;
+ (defvar semanticdb-project-predicate-functions nil
+ "List of predicates to try that indicate a directory belongs to a project.
+ This list is used when `semanticdb-persistent-path' contains the value
+ 'project. If the predicate list is nil, then presume all paths are valid.
+
+ Project Management software (such as EDE and JDE) should add their own
+ predicates with `add-hook' to this variable, and semanticdb will save tag
+ caches in directories controlled by them.")
+
+ (defmethod semanticdb-write-directory-p ((obj semanticdb-project-database))
+ "Return non-nil if OBJ should be written to disk.
+ Uses `semanticdb-persistent-path' to determine the return value."
+ nil)
+
+ ;;; Utilities
+ ;;
+ ;; What is the current database, are two tables of an equivalent mode,
+ ;; and what databases are a part of the same project.
+ (defun semanticdb-current-database ()
+ "Return the currently active database."
+ (or semanticdb-current-database
+ (and default-directory
+ (semanticdb-create-database semanticdb-new-database-class
+ default-directory)
+ )
+ nil))
+
+ (defvar semanticdb-match-any-mode nil
+ "Non-nil to temporarilly search any major mode for a tag.
+ If a particular major mode wants to search any mode, put the
+ `semantic-match-any-mode' symbol onto the symbol of that major mode.
+ Do not set the value of this variable permanently.")
+
+ (defmacro semanticdb-with-match-any-mode (&rest body)
+ "A Semanticdb search occuring withing BODY will search tags in all modes.
+ This temporarilly sets `semanticdb-match-any-mode' while executing BODY."
+ `(let ((semanticdb-match-any-mode t))
+ ,@body))
+ (put 'semanticdb-with-match-any-mode 'lisp-indent-function 0)
+
+ (defmethod semanticdb-equivalent-mode-for-search (table &optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+ See `semanticdb-equivalent-mode' for details.
+ This version is used during searches. Major-modes that opt
+ to set the `semantic-match-any-mode' property will be able to search
+ all files of any type."
+ (or (get major-mode 'semantic-match-any-mode)
+ semanticdb-match-any-mode
+ (semanticdb-equivalent-mode table buffer))
+ )
+
+ (defmethod semanticdb-equivalent-mode ((table semanticdb-abstract-table) &optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+ Equivalent modes are specified by by `semantic-equivalent-major-modes'
+ local variable."
+ nil)
+
+ (defmethod semanticdb-equivalent-mode ((table semanticdb-table) &optional buffer)
+ "Return non-nil if TABLE's mode is equivalent to BUFFER.
+ Equivalent modes are specified by by `semantic-equivalent-major-modes'
+ local variable."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (or
+ ;; nil major mode in table means we don't know yet. Assume yes for now?
+ (null (oref table major-mode))
+ ;; nil means the same as major-mode
+ (and (not semantic-equivalent-major-modes)
+ (mode-local-use-bindings-p major-mode (oref table major-mode)))
+ (and semantic-equivalent-major-modes
+ (member (oref table major-mode) semantic-equivalent-major-modes))
+ )
+ ))
+
+
+ ;;; Associations
+ ;;
+ ;; These routines determine associations between a file, and multiple
+ ;; associated databases.
+
+ (defcustom semanticdb-project-roots nil
+ "*List of directories, where each directory is the root of some project.
+ All subdirectories of a root project are considered a part of one project.
+ Values in this string can be overriden by project management programs
+ via the `semanticdb-project-root-functions' variable."
+ :group 'semanticdb
+ :type '(repeat string))
+
+ (defvar semanticdb-project-root-functions nil
+ "List of functions used to determine a given directories project root.
+ Functions in this variable can override `semanticdb-project-roots'.
+ Functions set in the variable are given one argument (a directory) and
+ must return a string, (the root directory) or a list of strings (multiple
+ root directories in a more complex system). This variable should be used
+ by project management programs like EDE or JDE.")
+
+ (defvar semanticdb-project-system-databases nil
+ "List of databases containing system library information.
+ Mode authors can create their own system databases which know
+ detailed information about the system libraries for querying purposes.
+ Put those into this variable as a buffer-local, or mode-local
+ value.")
+ (make-variable-buffer-local 'semanticdb-project-system-databases)
+
+ (defvar semanticdb-search-system-databases t
+ "Non nil if search routines are to include a system database.")
+
+ (defun semanticdb-current-database-list (&optional dir)
+ "Return a list of databases associated with the current buffer.
+ If optional argument DIR is non-nil, then use DIR as the starting directory.
+ If this buffer has a database, but doesn't have a project associated
+ with it, return nil.
+ First, it checks `semanticdb-project-root-functions', and if that
+ has no results, it checks `semanticdb-project-roots'. If that fails,
+ it returns the results of function `semanticdb-current-database'.
+ Always append `semanticdb-project-system-databases' if
+ `semanticdb-search-system' is non-nil."
+ (let ((root nil) ; found root directory
+ (dbs nil) ; collected databases
+ (roots semanticdb-project-roots) ;all user roots
+ (dir (file-truename (or dir default-directory)))
+ )
+ ;; Find the root based on project functions.
+ (setq root (run-hook-with-args-until-success
+ 'semanticdb-project-root-functions
+ dir))
+ ;; Find roots based on strings
+ (while (and roots (not root))
+ (let ((r (file-truename (car roots))))
+ (if (string-match (concat "^" (regexp-quote r)) dir)
+ (setq root r)))
+ (setq roots (cdr roots)))
+
+ ;; If no roots are found, use this directory.
+ (unless root (setq root dir))
+
+ ;; Find databases based on the root directory.
+ (when root
+ ;; The rootlist allows the root functions to possibly
+ ;; return several roots which are in different areas but
+ ;; all apart of the same system.
+ (let ((regexp (concat "^" (regexp-quote root)))
+ (adb semanticdb-database-list) ; all databases
+ )
+ (while adb
+ ;; I don't like this part, but close enough.
+ (if (and (slot-boundp (car adb) 'reference-directory)
+ (string-match regexp (oref (car adb) reference-directory)))
+ (setq dbs (cons (car adb) dbs)))
+ (setq adb (cdr adb))))
+ )
+ ;; Add in system databases
+ (when semanticdb-search-system-databases
+ (setq dbs (nconc dbs semanticdb-project-system-databases)))
+ ;; Return
+ dbs))
+
+ \f
+ ;;; Generic Accessor Routines
+ ;;
+ ;; These routines can be used to get at tags in files w/out
+ ;; having to know a lot about semanticDB.
+ (defvar semanticdb-file-table-hash (make-hash-table :test 'equal)
+ "Hash table mapping file names to database tables.")
+
+ (defun semanticdb-file-table-object-from-hash (file)
+ "Retrieve a DB table from the hash for FILE.
+ Does not use `file-truename'."
+ (gethash file semanticdb-file-table-hash 'no-hit))
+
+ (defun semanticdb-file-table-object-put-hash (file dbtable)
+ "For FILE, associate DBTABLE in the hash table."
+ (puthash file dbtable semanticdb-file-table-hash))
+
+ ;;;###autoload
+ (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)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/db"
+ ;; End:
+
+ ;;; semantic/db.el ends here
--- /dev/null
-;;; 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)
-
+ ;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens.
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2006, 2007, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Text representing a semantic tag is wrapped in an overlay.
+ ;; This overlay can be used for highlighting, or setting other
+ ;; editing properties on a tag, such as "read only."
+ ;;
+
+ (require 'semantic)
+ (require 'pulse)
+
+ ;;; Code:
+
+ ;;; Highlighting Basics
+ (defun semantic-highlight-tag (tag &optional face)
+ "Specify that TAG should be highlighted.
+ Optional FACE specifies the face to use."
+ (let ((o (semantic-tag-overlay tag)))
+ (semantic-overlay-put o 'old-face
+ (cons (semantic-overlay-get o 'face)
+ (semantic-overlay-get o 'old-face)))
+ (semantic-overlay-put o 'face (or face 'semantic-tag-highlight-face))
+ ))
+
+ (defun semantic-unhighlight-tag (tag)
+ "Unhighlight TAG, restoring it's previous face."
+ (let ((o (semantic-tag-overlay tag)))
+ (semantic-overlay-put o 'face (car (semantic-overlay-get o 'old-face)))
+ (semantic-overlay-put o 'old-face (cdr (semantic-overlay-get o 'old-face)))
+ ))
+
+ ;;; Momentary Highlighting - One line
+ (defun semantic-momentary-highlight-one-tag-line (tag &optional face)
+ "Highlight the first line of TAG, unhighlighting before next command.
+ Optional argument FACE specifies the face to do the highlighting."
+ (save-excursion
+ ;; Go to first line in tag
+ (semantic-go-to-tag tag)
+ (pulse-momentary-highlight-one-line (point))))
+
+ ;;; Momentary Highlighting - Whole Tag
+ (defun semantic-momentary-highlight-tag (tag &optional face)
+ "Highlight TAG, removing highlighting when the user hits a key.
+ Optional argument FACE is the face to use for highlighting.
+ If FACE is not specified, then `highlight' will be used."
+ (when (semantic-tag-with-position-p tag)
+ (if (not (semantic-overlay-p (semantic-tag-overlay tag)))
+ ;; No overlay, but a position. Highlight the first line only.
+ (semantic-momentary-highlight-one-tag-line tag face)
+ ;; The tag has an overlay, highlight the whole thing
+ (pulse-momentary-highlight-overlay (semantic-tag-overlay tag)
+ face)
+ )))
+
+ (defun semantic-set-tag-face (tag face)
+ "Specify that TAG should use FACE for display."
+ (semantic-overlay-put (semantic-tag-overlay tag) 'face face))
+
+ (defun semantic-set-tag-invisible (tag &optional visible)
+ "Enable the text in TAG to be made invisible.
+ If VISIBLE is non-nil, make the text visible."
+ (semantic-overlay-put (semantic-tag-overlay tag) 'invisible
+ (not visible)))
+
+ (defun semantic-tag-invisible-p (tag)
+ "Return non-nil if TAG is invisible."
+ (semantic-overlay-get (semantic-tag-overlay tag) 'invisible))
+
+ (defun semantic-set-tag-intangible (tag &optional tangible)
+ "Enable the text in TAG to be made intangible.
+ If TANGIBLE is non-nil, make the text visible.
+ This function does not have meaning in XEmacs because it seems that
+ the extent 'intangible' property does not exist."
+ (semantic-overlay-put (semantic-tag-overlay tag) 'intangible
+ (not tangible)))
+
+ (defun semantic-tag-intangible-p (tag)
+ "Return non-nil if TAG is intangible.
+ This function does not have meaning in XEmacs because it seems that
+ the extent 'intangible' property does not exist."
+ (semantic-overlay-get (semantic-tag-overlay tag) 'intangible))
+
+ (defun semantic-overlay-signal-read-only
+ (overlay after start end &optional len)
+ "Hook used in modification hooks to prevent modification.
+ Allows deletion of the entire text.
+ Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system."
+ ;; Stolen blithly from cpp.el in Emacs 21.1
+ (if (and (not after)
+ (or (< (semantic-overlay-start overlay) start)
+ (> (semantic-overlay-end overlay) end)))
+ (error "This text is read only")))
+
+ (defun semantic-set-tag-read-only (tag &optional writable)
+ "Enable the text in TAG to be made read-only.
+ Optional argument WRITABLE should be non-nil to make the text writable
+ instead of read-only."
+ (let ((o (semantic-tag-overlay tag))
+ (hook (if writable nil '(semantic-overlay-signal-read-only))))
+ (if (featurep 'xemacs)
+ ;; XEmacs extents have a 'read-only' property.
+ (semantic-overlay-put o 'read-only (not writable))
+ (semantic-overlay-put o 'modification-hooks hook)
+ (semantic-overlay-put o 'insert-in-front-hooks hook)
+ (semantic-overlay-put o 'insert-behind-hooks hook))))
+
+ (defun semantic-tag-read-only-p (tag)
+ "Return non-nil if the current TAG is marked read only."
+ (let ((o (semantic-tag-overlay tag)))
+ (if (featurep 'xemacs)
+ ;; XEmacs extents have a 'read-only' property.
+ (semantic-overlay-get o 'read-only)
+ (member 'semantic-overlay-signal-read-only
+ (semantic-overlay-get o 'modification-hooks)))))
+
+ ;;; 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)))
+ ))
+
+ (declare-function semantic-current-tag "semantic/find")
+
+ (defun semantic-set-tag-folded-isearch (overlay)
+ "Called by isearch if it discovers text in the folded region.
+ OVERLAY is passed in by isearch."
+ (semantic-set-tag-folded (semantic-current-tag) nil)
+ )
+
+ (defun semantic-tag-folded-p (tag)
+ "Non-nil if TAG is currently folded."
+ (semantic-tag-get-secondary-overlay tag 'semantic-folded)
+ )
+
+ (provide 'semantic/decorate)
+
+ ;;; semantic/decorate.el ends here
--- /dev/null
-(eval-when-compile (require 'cl))
+ ;;; semantic/decorate/mode.el --- Minor mode for decorating tags
+
+ ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; A minor mode for use in decorating tags.
+ ;;
+ ;; There are two types of decorations that can be performed on a tag.
+ ;; You can either highlight the full tag, or you can add an
+ ;; independent decoration on some part of the tag body.
+ ;;
+ ;; For independent decoration in particular, managing them so that they
+ ;; do not get corrupted is challenging. This major mode and
+ ;; corresponding macros will make handling those types of decorations
+ ;; easier.
+ ;;
+
+ ;;; Code:
+ (require 'semantic)
+ (require 'semantic/decorate)
+ (require 'semantic/tag-ls)
+ (require 'semantic/util-modes)
- "*List of active decoration styles.
+
+ ;;; Styles List
+ ;;
+ (defcustom semantic-decoration-styles nil
-;;;;###autoload
++ "List of active decoration styles.
+ It is an alist of \(NAME . FLAG) elements, where NAME is a style name
+ and FLAG is non-nil if the style is enabled.
+ See also `define-semantic-decoration-style' which will automatically
+ add items to this list."
+ :group 'semantic
+ :type '(repeat (cons (string :tag "Decoration Name")
+ (boolean :tag "Enabled")))
+ )
+
+ ;;; Misc.
+ ;;
+ (defsubst semantic-decorate-style-predicate (style)
+ "Return the STYLE's predicate function."
+ (intern (format "%s-p" style)))
+
+ (defsubst semantic-decorate-style-highlighter (style)
+ "Return the STYLE's highlighter function."
+ (intern (format "%s-highlight" style)))
+
+ ;;; Base decoration API
+ ;;
+ (defsubst semantic-decoration-p (object)
+ "Return non-nil if OBJECT is a tag decoration."
+ (and (semantic-overlay-p object)
+ (semantic-overlay-get object 'semantic-decoration)))
+
+ (defsubst semantic-decoration-set-property (deco property value)
+ "Set the DECO decoration's PROPERTY to VALUE.
+ Return DECO."
+ (assert (semantic-decoration-p deco))
+ (semantic-overlay-put deco property value)
+ deco)
+
+ (defsubst semantic-decoration-get-property (deco property)
+ "Return the DECO decoration's PROPERTY value."
+ (assert (semantic-decoration-p deco))
+ (semantic-overlay-get deco property))
+
+ (defsubst semantic-decoration-set-face (deco face)
+ "Set the face of the decoration DECO to FACE.
+ Return DECO."
+ (semantic-decoration-set-property deco 'face face))
+
+ (defsubst semantic-decoration-face (deco)
+ "Return the face of the decoration DECO."
+ (semantic-decoration-get-property deco 'face))
+
+ (defsubst semantic-decoration-set-priority (deco priority)
+ "Set the priority of the decoration DECO to PRIORITY.
+ Return DECO."
+ (assert (natnump priority))
+ (semantic-decoration-set-property deco 'priority priority))
+
+ (defsubst semantic-decoration-priority (deco)
+ "Return the priority of the decoration DECO."
+ (semantic-decoration-get-property deco 'priority))
+
+ (defsubst semantic-decoration-move (deco begin end)
+ "Move the decoration DECO on the region between BEGIN and END.
+ Return DECO."
+ (assert (semantic-decoration-p deco))
+ (semantic-overlay-move deco begin end)
+ deco)
+ \f
+ ;;; Tag decoration
+ ;;
+ (defun semantic-decorate-tag (tag begin end &optional face)
+ "Add a new decoration on TAG on the region between BEGIN and END.
+ If optional argument FACE is non-nil, set the decoration's face to
+ FACE.
+ Return the overlay that makes up the new decoration."
+ (let ((deco (semantic-tag-create-secondary-overlay tag)))
+ ;; We do not use the unlink property because we do not want to
+ ;; save the highlighting information in the DB.
+ (semantic-overlay-put deco 'semantic-decoration t)
+ (semantic-decoration-move deco begin end)
+ (semantic-decoration-set-face deco face)
+ deco))
+
+ (defun semantic-decorate-clear-tag (tag &optional deco)
+ "Remove decorations from TAG.
+ If optional argument DECO is non-nil, remove only that decoration."
+ (assert (or (null deco) (semantic-decoration-p deco)))
+ ;; Clear primary decorations.
+ ;; For now, just unhighlight the tag. How to deal with other
+ ;; primary decorations like invisibility, etc. ? Maybe just
+ ;; restoring default values will suffice?
+ (semantic-unhighlight-tag tag)
+ (semantic-tag-delete-secondary-overlay
+ tag (or deco 'semantic-decoration)))
+
+ (defun semantic-decorate-tag-decoration (tag)
+ "Return decoration found on TAG."
+ (semantic-tag-get-secondary-overlay tag 'semantic-decoration))
+ \f
+ ;;; Global setup of active decorations
+ ;;
+ (defun semantic-decorate-flush-decorations (&optional buffer)
+ "Flush decorations found in BUFFER.
+ BUFFER defaults to the current buffer.
+ Should be used to flush decorations that might remain in BUFFER, for
+ example, after tags have been refreshed."
+ (with-current-buffer (or buffer (current-buffer))
+ (dolist (o (semantic-overlays-in (point-min) (point-max)))
+ (and (semantic-decoration-p o)
+ (semantic-overlay-delete o)))))
+
+ (defun semantic-decorate-clear-decorations (tag-list)
+ "Remove decorations found in tags in TAG-LIST."
+ (dolist (tag tag-list)
+ (semantic-decorate-clear-tag tag)
+ ;; recurse over children
+ (semantic-decorate-clear-decorations
+ (semantic-tag-components-with-overlays tag))))
+
+ (defun semantic-decorate-add-decorations (tag-list)
+ "Add decorations to tags in TAG-LIST.
+ Also make sure old decorations in the area are completely flushed."
+ (dolist (tag tag-list)
+ ;; Cleanup old decorations.
+ (when (semantic-decorate-tag-decoration tag)
+ ;; Note on below comment. This happens more as decorations are refreshed
+ ;; mid-way through their use. Remove the message.
+
+ ;; It would be nice if this never happened, but it still does
+ ;; once in a while. Print a message to help flush these
+ ;; situations
+ ;;(message "Decorations still on %s" (semantic-format-tag-name tag))
+ (semantic-decorate-clear-tag tag))
+ ;; Add new decorations.
+ (dolist (style semantic-decoration-styles)
+ (let ((pred (semantic-decorate-style-predicate (car style)))
+ (high (semantic-decorate-style-highlighter (car style))))
+ (and (cdr style)
+ (fboundp pred)
+ (funcall pred tag)
+ (fboundp high)
+ (funcall high tag))))
+ ;; Recurse on the children of all tags
+ (semantic-decorate-add-decorations
+ (semantic-tag-components-with-overlays tag))))
+ \f
+ ;;; PENDING DECORATIONS
+ ;;
+ ;; Activities in Emacs may cause a decoration to change state. Any
+ ;; such identified change ought to be setup as PENDING. This means
+ ;; that the next idle step will do the decoration change, but at the
+ ;; time of the state change, minimal work would be done.
+ (defvar semantic-decorate-pending-decoration-hook nil
+ "Normal hook run to perform pending decoration changes.")
+
+ (semantic-varalias-obsolete 'semantic-decorate-pending-decoration-hooks
+ 'semantic-decorate-pending-decoration-hook)
+
+ (defun semantic-decorate-add-pending-decoration (fcn &optional buffer)
+ "Add a pending decoration change represented by FCN.
+ Applies only to the current BUFFER.
+ The setting of FCN will be removed after it is run."
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ (semantic-make-local-hook 'semantic-decorate-flush-pending-decorations)
+ (add-hook 'semantic-decorate-pending-decoration-hook fcn nil t)))
+
- "*Hook run at the end of function `semantic-decoration-mode'."
+ (defun semantic-decorate-flush-pending-decorations (&optional buffer)
+ "Flush any pending decorations for BUFFER.
+ Flush functions from `semantic-decorate-pending-decoration-hook'."
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ (run-hooks 'semantic-decorate-pending-decoration-hook)
+ ;; Always reset the hooks
+ (setq semantic-decorate-pending-decoration-hook nil)))
+
+ \f
+ ;;; DECORATION MODE
+ ;;
+ ;; Generic mode for handling basic highlighting and decorations.
+ ;;
+
+ (defcustom global-semantic-decoration-mode nil
+ "*If non-nil, enable global use of command `semantic-decoration-mode'.
+ When this mode is activated, decorations specified by
+ `semantic-decoration-styles'."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/decorate/mode
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-decoration-mode (if val 1 -1))))
+
+ ;;;###autoload
+ (defun global-semantic-decoration-mode (&optional arg)
+ "Toggle global use of option `semantic-decoration-mode'.
+ Decoration mode turns on all active decorations as specified
+ by `semantic-decoration-styles'.
+ If ARG is positive, enable, if it is negative, disable.
+ If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-decoration-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-decoration-mode arg)))
+
+ (defcustom semantic-decoration-mode-hook nil
-;;;;###autoload
++ "Hook run at the end of function `semantic-decoration-mode'."
+ :group 'semantic
+ :type 'hook)
+
+ ;;;;###autoload
+ (defvar semantic-decoration-mode nil
+ "Non-nil if command `semantic-decoration-mode' is enabled.
+ Use the command `semantic-decoration-mode' to change this variable.")
+ (make-variable-buffer-local 'semantic-decoration-mode)
+
+ (defun semantic-decoration-mode-setup ()
+ "Setup the `semantic-decoration-mode' minor mode.
+ The minor mode can be turned on only if the semantic feature is available
+ and the current buffer was set up for parsing. Return non-nil if the
+ minor mode is enabled."
+ (if semantic-decoration-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-decoration-mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ ;; Add hooks
+ (semantic-make-local-hook 'semantic-after-partial-cache-change-hook)
+ (add-hook 'semantic-after-partial-cache-change-hook
+ 'semantic-decorate-tags-after-partial-reparse nil t)
+ (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook)
+ (add-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-decorate-tags-after-full-reparse nil t)
+ ;; Add decorations to available tags. The above hooks ensure
+ ;; that new tags will be decorated when they become available.
+ (semantic-decorate-add-decorations (semantic-fetch-available-tags))
+ )
+ ;; Remove decorations from available tags.
+ (semantic-decorate-clear-decorations (semantic-fetch-available-tags))
+ ;; Cleanup any leftover crap too.
+ (semantic-decorate-flush-decorations)
+ ;; Remove hooks
+ (remove-hook 'semantic-after-partial-cache-change-hook
+ 'semantic-decorate-tags-after-partial-reparse t)
+ (remove-hook 'semantic-after-toplevel-cache-change-hook
+ 'semantic-decorate-tags-after-full-reparse t)
+ )
+ semantic-decoration-mode)
+
-;;;;###autoload
+ (defun semantic-decoration-mode (&optional arg)
+ "Minor mode for decorating tags.
+ Decorations are specified in `semantic-decoration-styles'.
+ You can define new decoration styles with
+ `define-semantic-decoration-style'.
+ 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-decoration-map}"
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-decoration-mode 0 1))))
+ (setq semantic-decoration-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-decoration-mode)))
+ (semantic-decoration-mode-setup)
+ (run-hooks 'semantic-decoration-mode-hook)
+ (if (interactive-p)
+ (message "decoration-mode minor mode %sabled"
+ (if semantic-decoration-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-decoration-mode)
+
+ (semantic-add-minor-mode 'semantic-decoration-mode
+ ""
+ nil)
+
+ (defun semantic-decorate-tags-after-full-reparse (tag-list)
+ "Add decorations after a complete reparse of the current buffer.
+ TAG-LIST is the list of tags recently parsed.
+ Flush all existing decorations and call `semantic-decorate-add-decorations' to
+ add decorations.
+ Called from `semantic-after-toplevel-cache-change-hook'."
+ ;; Flush everything
+ (semantic-decorate-flush-decorations)
+ ;; Add it back on
+ (semantic-decorate-add-decorations tag-list))
+
+ (defun semantic-decorate-tags-after-partial-reparse (tag-list)
+ "Add decorations when new tags are created in the current buffer.
+ TAG-LIST is the list of newly created tags.
+ Call `semantic-decorate-add-decorations' to add decorations.
+ Called from `semantic-after-partial-cache-change-hook'."
+ (semantic-decorate-add-decorations tag-list))
+
+ \f
+ ;;; Enable/Disable toggling
+ ;;
+ (defun semantic-decoration-style-enabled-p (style)
+ "Return non-nil if STYLE is currently enabled.
+ Return nil if the style is disabled, or does not exist."
+ (let ((pair (assoc style semantic-decoration-styles)))
+ (and pair (cdr pair))))
+
+ (defun semantic-toggle-decoration-style (name &optional arg)
+ "Turn on/off the decoration style with NAME.
+ Decorations are specified in `semantic-decoration-styles'.
+ With prefix argument ARG, turn on if positive, otherwise off.
+ Return non-nil if the decoration style is enabled."
+ (interactive
+ (list (completing-read "Decoration style: "
+ semantic-decoration-styles nil t)
+ current-prefix-arg))
+ (setq name (format "%s" name)) ;; Ensure NAME is a string.
+ (unless (equal name "")
+ (let* ((style (assoc name semantic-decoration-styles))
+ (flag (if arg
+ (> (prefix-numeric-value arg) 0)
+ (not (cdr style)))))
+ (unless (eq (cdr style) flag)
+ ;; Store the new flag.
+ (setcdr style flag)
+ ;; Refresh decorations is `semantic-decoration-mode' is on.
+ (when semantic-decoration-mode
+ (semantic-decoration-mode -1)
+ (semantic-decoration-mode 1))
+ (when (interactive-p)
+ (message "Decoration style %s turned %s" (car style)
+ (if flag "on" "off"))))
+ flag)))
+
+ (defvar semantic-decoration-menu-cache nil
+ "Cache of the decoration menu.")
+
+ (defun semantic-decoration-build-style-menu (style)
+ "Build a menu item for controlling a specific decoration STYLE."
+ (vector (car style)
+ `(lambda () (interactive)
+ (semantic-toggle-decoration-style
+ ,(car style)))
+ :style 'toggle
+ :selected `(semantic-decoration-style-enabled-p ,(car style))
+ ))
+
+ (defun semantic-build-decoration-mode-menu (&rest ignore)
+ "Create a menu listing all the known decorations for toggling.
+ IGNORE any input arguments."
+ (or semantic-decoration-menu-cache
+ (setq semantic-decoration-menu-cache
+ (mapcar 'semantic-decoration-build-style-menu
+ (reverse semantic-decoration-styles))
+ )))
+
+ \f
+ ;;; Defining decoration styles
+ ;;
+ (defmacro define-semantic-decoration-style (name doc &rest flags)
+ "Define a new decoration style with NAME.
+ DOC is a documentation string describing the decoration style NAME.
+ It is appended to auto-generated doc strings.
+ An Optional list of FLAGS can also be specified. Flags are:
+ :enabled <value> - specify the default enabled value for NAME.
+
+
+ This defines two new overload functions respectively called `NAME-p'
+ and `NAME-highlight', for which you must provide a default
+ implementation in respectively the functions `NAME-p-default' and
+ `NAME-highlight-default'. Those functions are passed a tag. `NAME-p'
+ must return non-nil to indicate that the tag should be decorated by
+ `NAME-highlight'.
+
+ To put primary decorations on a tag `NAME-highlight' must use
+ functions like `semantic-set-tag-face', `semantic-set-tag-intangible',
+ etc., found in the semantic-decorate library.
+
+ To add other kind of decorations on a tag, `NAME-highlight' must use
+ `semantic-decorate-tag', and other functions of the semantic
+ decoration API found in this library."
+ (let ((predicate (semantic-decorate-style-predicate name))
+ (highlighter (semantic-decorate-style-highlighter name))
+ (defaultenable (if (plist-member flags :enabled)
+ (plist-get flags :enabled)
+ t))
+ )
+ `(progn
+ ;; Clear the menu cache so that new items are added when
+ ;; needed.
+ (setq semantic-decoration-menu-cache nil)
+ ;; Create an override method to specify if a given tag belongs
+ ;; to this type of decoration
+ (define-overloadable-function ,predicate (tag)
+ ,(format "Return non-nil to decorate TAG with `%s' style.\n%s"
+ name doc))
+ ;; Create an override method that will perform the highlight
+ ;; operation if the -p method returns non-nil.
+ (define-overloadable-function ,highlighter (tag)
+ ,(format "Decorate TAG with `%s' style.\n%s"
+ name doc))
+ ;; Add this to the list of primary decoration modes.
+ (add-to-list 'semantic-decoration-styles
+ (cons ',(symbol-name name)
+ ,defaultenable))
+ )))
+ \f
+ ;;; Predefined decoration styles
+ ;;
+
+ ;;; Tag boundaries highlighting
+ ;;
+ (define-semantic-decoration-style semantic-tag-boundary
+ "Place an overline in front of each long tag.
+ Does not provide overlines for prototypes.")
+
+ (defface semantic-tag-boundary-face
+ '((((class color) (background dark))
+ (:overline "cyan"))
+ (((class color) (background light))
+ (:overline "blue")))
+ "*Face used to show long tags in.
+ Used by decoration style: `semantic-tag-boundary'."
+ :group 'semantic-faces)
+
+ (defun semantic-tag-boundary-p-default (tag)
+ "Return non-nil if TAG is a type, or a non-prototype function."
+ (let ((c (semantic-tag-class tag)))
+ (and
+ (or
+ ;; All types get a line?
+ (eq c 'type)
+ ;; Functions which aren't prototypes get a line.
+ (and (eq c 'function)
+ (not (semantic-tag-get-attribute tag :prototype-flag)))
+ )
+ ;; Note: The below restriction confused users.
+ ;;
+ ;; Nothing smaller than a few lines
+ ;;(> (- (semantic-tag-end tag) (semantic-tag-start tag)) 150)
+ ;; Random truth
+ t)
+ ))
+
+ (defun semantic-tag-boundary-highlight-default (tag)
+ "Highlight the first line of TAG as a boundary."
+ (when (bufferp (semantic-tag-buffer tag))
+ (with-current-buffer (semantic-tag-buffer tag)
+ (semantic-decorate-tag
+ tag
+ (semantic-tag-start tag)
+ (save-excursion
+ (goto-char (semantic-tag-start tag))
+ (end-of-line)
+ (forward-char 1)
+ (point))
+ 'semantic-tag-boundary-face))
+ ))
+
+ ;;; Private member highlighting
+ ;;
+ (define-semantic-decoration-style semantic-decoration-on-private-members
+ "Highlight class members that are designated as PRIVATE access."
+ :enabled nil)
+
+ (defface semantic-decoration-on-private-members-face
+ '((((class color) (background dark))
+ (:background "#200000"))
+ (((class color) (background light))
+ (:background "#8fffff")))
+ "*Face used to show privately scoped tags in.
+ Used by the decoration style: `semantic-decoration-on-private-members'."
+ :group 'semantic-faces)
+
+ (defun semantic-decoration-on-private-members-highlight-default (tag)
+ "Highlight TAG as designated to have PRIVATE access.
+ Use a primary decoration."
+ (semantic-set-tag-face
+ tag 'semantic-decoration-on-private-members-face))
+
+ (defun semantic-decoration-on-private-members-p-default (tag)
+ "Return non-nil if TAG has PRIVATE access."
+ (and (member (semantic-tag-class tag) '(function variable))
+ (eq (semantic-tag-protection tag) 'private)))
+
+ ;;; Protected member highlighting
+ ;;
+ (defface semantic-decoration-on-protected-members-face
+ '((((class color) (background dark))
+ (:background "#000020"))
+ (((class color) (background light))
+ (:background "#fffff8")))
+ "*Face used to show protected scoped tags in.
+ Used by the decoration style: `semantic-decoration-on-protected-members'."
+ :group 'semantic-faces)
+
+ (define-semantic-decoration-style semantic-decoration-on-protected-members
+ "Highlight class members that are designated as PROTECTED access."
+ :enabled nil)
+
+ (defun semantic-decoration-on-protected-members-p-default (tag)
+ "Return non-nil if TAG has PROTECTED access."
+ (and (member (semantic-tag-class tag) '(function variable))
+ (eq (semantic-tag-protection tag) 'protected)))
+
+ (defun semantic-decoration-on-protected-members-highlight-default (tag)
+ "Highlight TAG as designated to have PROTECTED access.
+ Use a primary decoration."
+ (semantic-set-tag-face
+ tag 'semantic-decoration-on-protected-members-face))
+
+ (provide 'semantic/decorate/mode)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "../loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/decorate/mode"
+ ;; End:
+
+ ;;; semantic/decorate/mode.el ends here
--- /dev/null
-(make-obsolete-overload 'semantic-find-documentation
- 'semantic-documentation-for-tag)
-
+ ;;; semantic/doc.el --- Routines for documentation strings
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2008, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; It is good practice to write documenation for your functions and
+ ;; variables. These core routines deal with these documentation
+ ;; comments or strings. They can exist either as a tag property
+ ;; (:documentation) or as a comment just before the symbol, or after
+ ;; the symbol on the same line.
+
+ (require 'semantic/tag)
+
+ ;;; Code:
+
+ ;;;###autoload
+ (define-overloadable-function semantic-documentation-for-tag (&optional tag nosnarf)
+ "Find documentation from TAG and return it as a clean string.
+ TAG might have DOCUMENTATION set in it already. If not, there may be
+ some documentation in a comment preceding TAG's definition which we
+ can look for. When appropriate, this can be overridden by a language specific
+ enhancement.
+ Optional argument NOSNARF means to only return the lexical analyzer token for it.
+ If nosnarf if 'lex, then only return the lex token."
+ (if (not tag) (setq tag (semantic-current-tag)))
+ (save-excursion
+ (when (semantic-tag-with-position-p tag)
+ (set-buffer (semantic-tag-buffer tag)))
+ (:override
+ ;; No override. Try something simple to find documentation nearby
+ (save-excursion
+ (semantic-go-to-tag tag)
+ (let ((doctmp (semantic-tag-docstring tag (current-buffer))))
+ (or
+ ;; Is there doc in the tag???
+ doctmp
+ ;; Check just before the definition.
+ (when (semantic-tag-with-position-p tag)
+ (semantic-documentation-comment-preceeding-tag tag nosnarf))
+ ;; Lets look for comments either after the definition, but before code:
+ ;; Not sure yet. Fill in something clever later....
+ nil))))))
+
+ (defun semantic-documentation-comment-preceeding-tag (&optional tag nosnarf)
+ "Find a comment preceeding TAG.
+ If TAG is nil. use the tag under point.
+ Searches the space between TAG and the preceeding tag for a comment,
+ and converts the comment into clean documentation.
+ Optional argument NOSNARF with a value of 'lex means to return
+ just the lexical token and not the string."
+ (if (not tag) (setq tag (semantic-current-tag)))
+ (save-excursion
+ ;; Find this tag.
+ (semantic-go-to-tag tag)
+ (let* ((starttag (semantic-find-tag-by-overlay-prev
+ (semantic-tag-start tag)))
+ (start (if starttag
+ (semantic-tag-end starttag)
+ (point-min))))
+ (when (re-search-backward comment-start-skip start t)
+ ;; We found a comment that doesn't belong to the body
+ ;; of a function.
+ (semantic-doc-snarf-comment-for-tag nosnarf)))
+ ))
+
-(semantic-alias-obsolete 'semantic-find-documentation
- 'semantic-documentation-for-tag)
-
+ (defun semantic-doc-snarf-comment-for-tag (nosnarf)
+ "Snarf up the comment at POINT for `semantic-documentation-for-tag'.
+ Attempt to strip out comment syntactic sugar.
+ Argument NOSNARF means don't modify the found text.
+ If NOSNARF is 'lex, then return the lex token."
+ (let* ((semantic-ignore-comments nil)
+ (semantic-lex-analyzer #'semantic-comment-lexer))
+ (if (memq nosnarf '(lex flex)) ;; keep `flex' for compatibility
+ (car (semantic-lex (point) (1+ (point))))
+ (let ((ct (semantic-lex-token-text
+ (car (semantic-lex (point) (1+ (point)))))))
+ (if nosnarf
+ nil
+ ;; ok, try to clean the text up.
+ ;; Comment start thingy
+ (while (string-match (concat "^\\s-*" comment-start-skip) ct)
+ (setq ct (concat (substring ct 0 (match-beginning 0))
+ (substring ct (match-end 0)))))
+ ;; Arbitrary punctuation at the beginning of each line.
+ (while (string-match "^\\s-*\\s.+\\s-*" ct)
+ (setq ct (concat (substring ct 0 (match-beginning 0))
+ (substring ct (match-end 0)))))
+ ;; End of a block comment.
+ (if (and (boundp 'block-comment-end)
+ block-comment-end
+ (string-match block-comment-end ct))
+ (setq ct (concat (substring ct 0 (match-beginning 0))
+ (substring ct (match-end 0)))))
+ ;; In case it's a real string, STRIPIT.
+ (while (string-match "\\s-*\\s\"+\\s-*" ct)
+ (setq ct (concat (substring ct 0 (match-beginning 0))
+ (substring ct (match-end 0))))))
+ ;; Now return the text.
+ ct))))
+
+ (provide 'semantic/doc)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/doc"
+ ;; End:
+
+ ;;; semantic/doc.el ends here
--- /dev/null
-;;; Code:
-\f
+ ;;; semantic/find.el --- Search routines for Semantic
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2008, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Routines for searching through lists of tags.
+ ;; There are several groups of tag search routines:
+ ;;
+ ;; 1) semantic-brute-find-tag-by-*
+ ;; These routines use brute force hierarchical search to scan
+ ;; through lists of tags. They include some parameters
+ ;; used for compatibility with the semantic 1.x search routines.
+ ;;
+ ;; 1.5) semantic-brute-find-first-tag-by-*
+ ;; Like 1, except seraching stops on the first match for the given
+ ;; information.
+ ;;
+ ;; 2) semantic-find-tag-by-*
+ ;; These prefered search routines attempt to scan through lists
+ ;; in an intelligent way based on questions asked.
+ ;;
+ ;; 3) semantic-find-*-overlay
+ ;; These routines use overlays to return tags based on a buffer position.
+ ;;
+ ;; 4) ...
+
++;;; Code:
++
+ (require 'semantic)
+ (require 'semantic/tag)
+
-(declare-function semantic-tag-protected-p "semantic/tag-ls")
-
++(declare-function semantic-tag-protected-p "semantic/tag-ls")
++
+ ;;; Overlay Search Routines
+ ;;
+ ;; These routines provide fast access to tokens based on a buffer that
+ ;; has parsed tokens in it. Uses overlays to perform the hard work.
+ ;;
+ ;;;###autoload
+ (defun semantic-find-tag-by-overlay (&optional positionormarker buffer)
+ "Find all tags covering POSITIONORMARKER by using overlays.
+ If POSITIONORMARKER is nil, use the current point.
+ Optional BUFFER is used if POSITIONORMARKER is a number, otherwise the current
+ buffer is used. This finds all tags covering the specified position
+ by checking for all overlays covering the current spot. They are then sorted
+ from largest to smallest via the start location."
+ (save-excursion
+ (when positionormarker
+ (if (markerp positionormarker)
+ (set-buffer (marker-buffer positionormarker))
+ (if (bufferp buffer)
+ (set-buffer buffer))))
+ (let ((ol (semantic-overlays-at (or positionormarker (point))))
+ (ret nil))
+ (while ol
+ (let ((tmp (semantic-overlay-get (car ol) 'semantic)))
+ (when (and tmp
+ ;; We don't need with-position because no tag w/out
+ ;; a position could exist in an overlay.
+ (semantic-tag-p tmp))
+ (setq ret (cons tmp ret))))
+ (setq ol (cdr ol)))
+ (sort ret (lambda (a b) (< (semantic-tag-start a)
+ (semantic-tag-start b)))))))
+
+ ;;;###autoload
+ (defun semantic-find-tag-by-overlay-in-region (start end &optional buffer)
+ "Find all tags which exist in whole or in part between START and END.
+ Uses overlays to determine positin.
+ Optional BUFFER argument specifies the buffer to use."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (let ((ol (semantic-overlays-in start end))
+ (ret nil))
+ (while ol
+ (let ((tmp (semantic-overlay-get (car ol) 'semantic)))
+ (when (and tmp
+ ;; See above about position
+ (semantic-tag-p tmp))
+ (setq ret (cons tmp ret))))
+ (setq ol (cdr ol)))
+ (sort ret (lambda (a b) (< (semantic-tag-start a)
+ (semantic-tag-start b)))))))
+
+ ;;;###autoload
+ (defun semantic-find-tag-by-overlay-next (&optional start buffer)
+ "Find the next tag after START in BUFFER.
+ If START is in an overlay, find the tag which starts next,
+ not the current tag."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (if (not start) (setq start (point)))
+ (let ((os start) (ol nil))
+ (while (and os (< os (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))
+ (if (and (semantic-overlay-get (car ol) 'semantic)
+ (semantic-tag-p
+ (semantic-overlay-get (car ol) 'semantic))
+ (= (semantic-overlay-start (car ol)) os))
+ (setq ol (car ol)))
+ (when (listp ol) (setq ol (cdr ol))))))
+ ;; convert ol to a tag
+ (when (and ol (semantic-tag-p (semantic-overlay-get ol 'semantic)))
+ (semantic-overlay-get ol 'semantic)))))
+
+ ;;;###autoload
+ (defun semantic-find-tag-by-overlay-prev (&optional start buffer)
+ "Find the next tag before START in BUFFER.
+ If START is in an overlay, find the tag which starts next,
+ not the current tag."
+ (save-excursion
+ (if buffer (set-buffer buffer))
+ (if (not start) (setq start (point)))
+ (let ((os start) (ol nil))
+ (while (and os (> os (point-min)) (not ol))
+ (setq os (semantic-overlay-previous-change os))
+ (when os
+ ;; Get overlays at position
+ (setq ol (semantic-overlays-at (1- os)))
+ ;; find the overlay that belongs to semantic
+ ;; and ENDS at the found position.
+ ;;
+ ;; Use end because we are going backward.
+ (while (and ol (listp ol))
+ (if (and (semantic-overlay-get (car ol) 'semantic)
+ (semantic-tag-p
+ (semantic-overlay-get (car ol) 'semantic))
+ (= (semantic-overlay-end (car ol)) os))
+ (setq ol (car ol)))
+ (when (listp ol) (setq ol (cdr ol))))))
+ ;; convert ol to a tag
+ (when (and ol
+ (semantic-tag-p (semantic-overlay-get ol 'semantic)))
+ (semantic-overlay-get ol 'semantic)))))
+
+ ;;;###autoload
+ (defun semantic-find-tag-parent-by-overlay (tag)
+ "Find the parent of TAG by overlays.
+ Overlays are a fast way of finding this information for active buffers."
+ (let ((tag (nreverse (semantic-find-tag-by-overlay
+ (semantic-tag-start tag)))))
+ ;; This is a lot like `semantic-current-tag-parent', but
+ ;; it uses a position to do it's work. Assumes two tags don't share
+ ;; the same start unless they are siblings.
+ (car (cdr tag))))
+
+ ;;;###autoload
+ (defun semantic-current-tag ()
+ "Return the current tag in the current buffer.
+ If there are more than one in the same location, return the
+ smallest tag. Return nil if there is no tag here."
+ (car (nreverse (semantic-find-tag-by-overlay))))
+
+ ;;;###autoload
+ (defun semantic-current-tag-parent ()
+ "Return the current tags parent in the current buffer.
+ A tag's parent would be a containing structure, such as a type
+ containing a field. Return nil if there is no parent."
+ (car (cdr (nreverse (semantic-find-tag-by-overlay)))))
+
+ (defun semantic-current-tag-of-class (class)
+ "Return the current (smallest) tags of CLASS in the current buffer.
+ If the smallest tag is not of type CLASS, keep going upwards until one
+ is found.
+ Uses `semantic-tag-class' for classification."
+ (let ((tags (nreverse (semantic-find-tag-by-overlay))))
+ (while (and tags
+ (not (eq (semantic-tag-class (car tags)) class)))
+ (setq tags (cdr tags)))
+ (car tags)))
+ \f
+ ;;; Search Routines
+ ;;
+ ;; These are routines that search a single tags table.
+ ;;
+ ;; The original API (see COMPATIBILITY section below) in semantic 1.4
+ ;; had these usage statistics:
+ ;;
+ ;; semantic-find-nonterminal-by-name 17
+ ;; semantic-find-nonterminal-by-name-regexp 8 - Most doing completion
+ ;; semantic-find-nonterminal-by-position 13
+ ;; semantic-find-nonterminal-by-token 21
+ ;; semantic-find-nonterminal-by-type 2
+ ;; semantic-find-nonterminal-standard 1
+ ;;
+ ;; semantic-find-nonterminal-by-function (not in other searches) 1
+ ;;
+ ;; New API: As above w/out `search-parts' or `search-includes' arguments.
+ ;; Extra fcn: Specific to completion which is what -name-regexp is
+ ;; mostly used for
+ ;;
+ ;; As for the sarguments "search-parts" and "search-includes" here
+ ;; are stats:
+ ;;
+ ;; search-parts: 4 - charting x2, find-doc, senator (sans db)
+ ;;
+ ;; Implement command to flatten a tag table. Call new API Fcn w/
+ ;; flattened table for same results.
+ ;;
+ ;; search-include: 2 - analyze x2 (sans db)
+ ;;
+ ;; Not used effectively. Not to be re-implemented here.
+
+ (defsubst semantic--find-tags-by-function (predicate &optional table)
+ "Find tags for which PREDICATE is non-nil in TABLE.
+ PREDICATE is a lambda expression which accepts on TAG.
+ TABLE is a semantic tags table. See `semantic-something-to-tag-table'."
+ (let ((tags (semantic-something-to-tag-table table))
+ (result nil))
+ ; (mapc (lambda (tag) (and (funcall predicate tag)
+ ; (setq result (cons tag result))))
+ ; tags)
+ ;; A while loop is actually faster. Who knew
+ (while tags
+ (and (funcall predicate (car tags))
+ (setq result (cons (car tags) result)))
+ (setq tags (cdr tags)))
+ (nreverse result)))
+
+ ;; I can shave off some time by removing the funcall (see above)
+ ;; and having the question be inlined in the while loop.
+ ;; Strangely turning the upper level fcns into macros had a larger
+ ;; impact.
+ (defmacro semantic--find-tags-by-macro (form &optional table)
+ "Find tags for which FORM is non-nil in TABLE.
+ TABLE is a semantic tags table. See `semantic-something-to-tag-table'."
+ `(let ((tags (semantic-something-to-tag-table ,table))
+ (result nil))
+ (while tags
+ (and ,form
+ (setq result (cons (car tags) result)))
+ (setq tags (cdr tags)))
+ (nreverse result)))
+
+ ;;; Top level Searches
+ ;;
+ ;;;###autoload
+ (defun semantic-find-first-tag-by-name (name &optional table)
+ "Find the first tag with NAME in TABLE.
+ NAME is a string.
+ TABLE is a semantic tags table. See `semantic-something-to-tag-table'.
+ This routine uses `assoc' to quickly find the first matching entry."
+ (funcall (if semantic-case-fold 'assoc-ignore-case 'assoc)
+ name (semantic-something-to-tag-table table)))
+
+ (defmacro semantic-find-tags-by-name (name &optional table)
+ "Find all tags with NAME in TABLE.
+ NAME is a string.
+ TABLE is a tag table. See `semantic-something-to-tag-table'."
+ `(let ((case-fold-search semantic-case-fold))
+ (semantic--find-tags-by-macro
+ (string= ,name (semantic-tag-name (car tags)))
+ ,table)))
+
+ (defmacro semantic-find-tags-for-completion (prefix &optional table)
+ "Find all tags whos name begins with PREFIX in TABLE.
+ PREFIX is a string.
+ TABLE is a tag table. See `semantic-something-to-tag-table'.
+ While it would be nice to use `try-completion' or `all-completions',
+ those functions do not return the tags, only a string.
+ Uses `compare-strings' for fast comparison."
+ `(let ((l (length ,prefix)))
+ (semantic--find-tags-by-macro
+ (eq (compare-strings ,prefix 0 nil
+ (semantic-tag-name (car tags)) 0 l
+ semantic-case-fold)
+ t)
+ ,table)))
+
+ (defmacro semantic-find-tags-by-name-regexp (regexp &optional table)
+ "Find all tags with name matching REGEXP in TABLE.
+ REGEXP is a string containing a regular expression,
+ TABLE is a tag table. See `semantic-something-to-tag-table'.
+ Consider using `semantic-find-tags-for-completion' if you are
+ attempting to do completions."
+ `(let ((case-fold-search semantic-case-fold))
+ (semantic--find-tags-by-macro
+ (string-match ,regexp (semantic-tag-name (car tags)))
+ ,table)))
+
+ (defmacro semantic-find-tags-by-class (class &optional table)
+ "Find all tags of class CLASS in TABLE.
+ CLASS is a symbol representing the class of the token, such as
+ 'variable, of 'function..
+ TABLE is a tag table. See `semantic-something-to-tag-table'."
+ `(semantic--find-tags-by-macro
+ (eq ,class (semantic-tag-class (car tags)))
+ ,table))
+
+ (defmacro semantic-find-tags-by-type (type &optional table)
+ "Find all tags of with a type TYPE in TABLE.
+ TYPE is a string or tag representing a data type as defined in the
+ language the tags were parsed from, such as \"int\", or perhaps
+ a tag whose name is that of a struct or class.
+ TABLE is a tag table. See `semantic-something-to-tag-table'."
+ `(semantic--find-tags-by-macro
+ (semantic-tag-of-type-p (car tags) ,type)
+ ,table))
+
+ (defmacro semantic-find-tags-of-compound-type (&optional table)
+ "Find all tags which are a compound type in TABLE.
+ Compound types are structures, or other data type which
+ is not of a primitive nature, such as int or double.
+ Used in completion."
+ `(semantic--find-tags-by-macro
+ (semantic-tag-type-compound-p (car tags))
+ ,table))
+
+ ;;;###autoload
+ (define-overloadable-function semantic-find-tags-by-scope-protection (scopeprotection parent &optional table)
+ "Find all tags accessable by SCOPEPROTECTION.
+ SCOPEPROTECTION is a symbol which can be returned by the method
+ `semantic-tag-protection'. A hard-coded order is used to determine a match.
+ PARENT is a tag representing the PARENT slot needed for
+ `semantic-tag-protection'.
+ TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil,
+ the type members of PARENT are used.
+ See `semantic-tag-protected-p' for details on which tags are returned."
+ (if (not (eq (semantic-tag-class parent) 'type))
+ (signal 'wrong-type-argument '(semantic-find-tags-by-scope-protection
+ parent
+ semantic-tag-class type))
+ (:override)))
+
-;;
-(declare-function semantic-tag-external-member-parent "semantic/sort")
+ (defun semantic-find-tags-by-scope-protection-default
+ (scopeprotection parent &optional table)
+ "Find all tags accessable by SCOPEPROTECTION.
+ SCOPEPROTECTION is a symbol which can be returned by the method
+ `semantic-tag-protection'. A hard-coded order is used to determine a match.
+ PARENT is a tag representing the PARENT slot needed for
+ `semantic-tag-protection'.
+ TABLE is a list of tags (a subset of PARENT members) to scan. If TABLE is nil,
+ the type members of PARENT are used.
+ See `semantic-tag-protected-p' for details on which tags are returned."
+ (if (not table) (setq table (semantic-tag-type-members parent)))
+ (if (null scopeprotection)
+ table
+ (require 'semantic/tag-ls)
+ (semantic--find-tags-by-macro
+ (not (semantic-tag-protected-p (car tags) scopeprotection parent))
+ table)))
+
+ (defsubst semantic-find-tags-included (&optional table)
+ "Find all tags in TABLE that are of the 'include class.
+ TABLE is a tag table. See `semantic-something-to-tag-table'."
+ (semantic-find-tags-by-class 'include table))
+
+ ;;; Deep Searches
+
+ (defmacro semantic-deep-find-tags-by-name (name &optional table)
+ "Find all tags with NAME in TABLE.
+ Search in top level tags, and their components, in TABLE.
+ NAME is a string.
+ TABLE is a tag table. See `semantic-flatten-tags-table'.
+ See also `semantic-find-tags-by-name'."
+ `(semantic-find-tags-by-name
+ ,name (semantic-flatten-tags-table ,table)))
+
+ (defmacro semantic-deep-find-tags-for-completion (prefix &optional table)
+ "Find all tags whos name begins with PREFIX in TABLE.
+ Search in top level tags, and their components, in TABLE.
+ TABLE is a tag table. See `semantic-flatten-tags-table'.
+ See also `semantic-find-tags-for-completion'."
+ `(semantic-find-tags-for-completion
+ ,prefix (semantic-flatten-tags-table ,table)))
+
+ (defmacro semantic-deep-find-tags-by-name-regexp (regexp &optional table)
+ "Find all tags with name matching REGEXP in TABLE.
+ Search in top level tags, and their components, in TABLE.
+ REGEXP is a string containing a regular expression,
+ TABLE is a tag table. See `semantic-flatten-tags-table'.
+ See also `semantic-find-tags-by-name-regexp'.
+ Consider using `semantic-deep-find-tags-for-completion' if you are
+ attempting to do completions."
+ `(semantic-find-tags-by-name-regexp
+ ,regexp (semantic-flatten-tags-table ,table)))
+
+ ;;; Specialty Searches
-\f
-;;; Compatibility Aliases
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay
- 'semantic-find-tag-by-overlay)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-in-region
- 'semantic-find-tag-by-overlay-in-region)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-next
- 'semantic-find-tag-by-overlay-next)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-overlay-prev
- 'semantic-find-tag-by-overlay-prev)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-parent-by-overlay
- 'semantic-find-tag-parent-by-overlay)
-
-(semantic-alias-obsolete 'semantic-current-nonterminal
- 'semantic-current-tag)
-
-(semantic-alias-obsolete 'semantic-current-nonterminal-parent
- 'semantic-current-tag-parent)
-
-(semantic-alias-obsolete 'semantic-current-nonterminal-of-type
- 'semantic-current-tag-of-class)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-name
- 'semantic-brute-find-first-tag-by-name)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-token
- 'semantic-brute-find-tag-by-class)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-standard
- 'semantic-brute-find-tag-standard)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-type
- 'semantic-brute-find-tag-by-type)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-type-regexp
- 'semantic-brute-find-tag-by-type-regexp)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-name-regexp
- 'semantic-brute-find-tag-by-name-regexp)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-property
- 'semantic-brute-find-tag-by-property)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-extra-spec
- 'semantic-brute-find-tag-by-attribute)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-extra-spec-value
- 'semantic-brute-find-tag-by-attribute-value)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-function
- 'semantic-brute-find-tag-by-function)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-function-first-match
- 'semantic-brute-find-first-tag-by-function)
-
-(semantic-alias-obsolete 'semantic-find-nonterminal-by-position
- 'semantic-brute-find-tag-by-position)
-
-(semantic-alias-obsolete 'semantic-find-innermost-nonterminal-by-position
- 'semantic-brute-find-innermost-tag-by-position)
-
-;;; TESTING
-;;
-(defun semantic-find-benchmark ()
- "Run some simple benchmarks to see how we are doing.
-Optional argument ARG is the number of iterations to run."
- (interactive)
- (require 'benchmark)
- (let ((f-name nil)
- (b-name nil)
- (f-comp)
- (b-comp)
- (f-regex)
- )
- (garbage-collect)
- (setq f-name
- (benchmark-run-compiled
- 1000 (semantic-find-first-tag-by-name "class3"
- "test/test.cpp")))
- (garbage-collect)
- (setq b-name
- (benchmark-run-compiled
- 1000 (semantic-brute-find-first-tag-by-name "class3"
- "test/test.cpp")))
- (garbage-collect)
- (setq f-comp
- (benchmark-run-compiled
- 1000 (semantic-find-tags-for-completion "method"
- "test/test.cpp")))
- (garbage-collect)
- (setq b-comp
- (benchmark-run-compiled
- 1000 (semantic-brute-find-tag-by-name-regexp "^method"
- "test/test.cpp")))
- (garbage-collect)
- (setq f-regex
- (benchmark-run-compiled
- 1000 (semantic-find-tags-by-name-regexp "^method"
- "test/test.cpp")))
-
- (message "Name [new old] [ %.3f %.3f ] Complete [newc/new old] [ %.3f/%.3f %.3f ]"
- (car f-name) (car b-name)
- (car f-comp) (car f-regex)
- (car b-comp))
- ))
+
+ (defun semantic-find-tags-external-children-of-type (type &optional table)
+ "Find all tags in whose parent is TYPE in TABLE.
+ These tags are defined outside the scope of the original TYPE declaration.
+ TABLE is a tag table. See `semantic-something-to-tag-table'."
+ (semantic--find-tags-by-macro
+ (equal (semantic-tag-external-member-parent (car tags))
+ type)
+ table))
+
+ (defun semantic-find-tags-subclasses-of-type (type &optional table)
+ "Find all tags of class type in whose parent is TYPE in TABLE.
+ These tags are defined outside the scope of the original TYPE declaration.
+ TABLE is a tag table. See `semantic-something-to-tag-table'."
+ (semantic--find-tags-by-macro
+ (and (eq (semantic-tag-class (car tags)) 'type)
+ (or (member type (semantic-tag-type-superclasses (car tags)))
+ (member type (semantic-tag-type-interfaces (car tags)))))
+ table))
+ \f
+ ;;
+ ;; ************************** Compatibility ***************************
+ ;;
+
+ ;;; Old Style Brute Force Search Routines
+ ;;
+ ;; These functions will search through tags lists explicity for
+ ;; desired information.
+
+ ;; The -by-name nonterminal search can use the built in fcn
+ ;; `assoc', which is faster than looping ourselves, so we will
+ ;; not use `semantic-brute-find-tag-by-function' to do this,
+ ;; instead erroring on the side of speed.
+
+ (defun semantic-brute-find-first-tag-by-name
+ (name streamorbuffer &optional search-parts search-include)
+ "Find a tag NAME within STREAMORBUFFER. NAME is a string.
+ If SEARCH-PARTS is non-nil, search children of tags.
+ If SEARCH-INCLUDE was never implemented.
+
+ Use `semantic-find-first-tag-by-name' instead."
+ (let* ((stream (semantic-something-to-tag-table streamorbuffer))
+ (assoc-fun (if semantic-case-fold
+ #'assoc-ignore-case
+ #'assoc))
+ (m (funcall assoc-fun name stream)))
+ (if m
+ m
+ (let ((toklst stream)
+ (children nil))
+ (while (and (not m) toklst)
+ (if search-parts
+ (progn
+ (setq children (semantic-tag-components-with-overlays
+ (car toklst)))
+ (if children
+ (setq m (semantic-brute-find-first-tag-by-name
+ name children search-parts search-include)))))
+ (setq toklst (cdr toklst)))
+ (if (not m)
+ ;; Go to dependencies, and search there.
+ nil)
+ m))))
+
+ (defmacro semantic-brute-find-tag-by-class
+ (class streamorbuffer &optional search-parts search-includes)
+ "Find all tags with a class CLASS within STREAMORBUFFER.
+ CLASS is a symbol representing the class of the tags to find.
+ See `semantic-tag-class'.
+ Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+ `semantic-brute-find-tag-by-function'.
+
+ Use `semantic-find-tag-by-class' instead."
+ `(semantic-brute-find-tag-by-function
+ (lambda (tag) (eq ,class (semantic-tag-class tag)))
+ ,streamorbuffer ,search-parts ,search-includes))
+
+ (defmacro semantic-brute-find-tag-standard
+ (streamorbuffer &optional search-parts search-includes)
+ "Find all tags in STREAMORBUFFER which define simple class types.
+ See `semantic-tag-class'.
+ Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+ `semantic-brute-find-tag-by-function'."
+ `(semantic-brute-find-tag-by-function
+ (lambda (tag) (member (semantic-tag-class tag)
+ '(function variable type)))
+ ,streamorbuffer ,search-parts ,search-includes))
+
+ (defun semantic-brute-find-tag-by-type
+ (type streamorbuffer &optional search-parts search-includes)
+ "Find all tags with type TYPE within STREAMORBUFFER.
+ TYPE is a string which is the name of the type of the tags returned.
+ See `semantic-tag-type'.
+ Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+ `semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag)
+ (let ((ts (semantic-tag-type tag)))
+ (if (and (listp ts)
+ (or (= (length ts) 1)
+ (eq (semantic-tag-class ts) 'type)))
+ (setq ts (semantic-tag-name ts)))
+ (equal type ts)))
+ streamorbuffer search-parts search-includes))
+
+ (defun semantic-brute-find-tag-by-type-regexp
+ (regexp streamorbuffer &optional search-parts search-includes)
+ "Find all tags with type matching REGEXP within STREAMORBUFFER.
+ REGEXP is a regular expression which matches the name of the type of the
+ tags returned. See `semantic-tag-type'.
+ Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+ `semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag)
+ (let ((ts (semantic-tag-type tag)))
+ (if (listp ts)
+ (setq ts
+ (if (eq (semantic-tag-class ts) 'type)
+ (semantic-tag-name ts)
+ (car ts))))
+ (and ts (string-match regexp ts))))
+ streamorbuffer search-parts search-includes))
+
+ (defun semantic-brute-find-tag-by-name-regexp
+ (regex streamorbuffer &optional search-parts search-includes)
+ "Find all tags whose name match REGEX in STREAMORBUFFER.
+ Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+ `semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag) (string-match regex (semantic-tag-name tag)))
+ streamorbuffer search-parts search-includes)
+ )
+
+ (defun semantic-brute-find-tag-by-property
+ (property value streamorbuffer &optional search-parts search-includes)
+ "Find all tags with PROPERTY equal to VALUE in STREAMORBUFFER.
+ Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+ `semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag) (equal (semantic--tag-get-property tag property) value))
+ streamorbuffer search-parts search-includes)
+ )
+
+ (defun semantic-brute-find-tag-by-attribute
+ (attr streamorbuffer &optional search-parts search-includes)
+ "Find all tags with a given ATTR in STREAMORBUFFER.
+ ATTR is a symbol key into the attributes list.
+ Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+ `semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag) (semantic-tag-get-attribute tag attr))
+ streamorbuffer search-parts search-includes)
+ )
+
+ (defun semantic-brute-find-tag-by-attribute-value
+ (attr value streamorbuffer &optional search-parts search-includes)
+ "Find all tags with a given ATTR equal to VALUE in STREAMORBUFFER.
+ ATTR is a symbol key into the attributes list.
+ VALUE is the value that ATTR should match.
+ Optional argument SEARCH-PARTS and SEARCH-INCLUDES are passed to
+ `semantic-brute-find-tag-by-function'."
+ (semantic-brute-find-tag-by-function
+ (lambda (tag) (equal (semantic-tag-get-attribute tag attr) value))
+ streamorbuffer search-parts search-includes)
+ )
+
+ (defun semantic-brute-find-tag-by-function
+ (function streamorbuffer &optional search-parts search-includes)
+ "Find all tags for which FUNCTION's value is non-nil within STREAMORBUFFER.
+ FUNCTION must return non-nil if an element of STREAM will be included
+ in the new list.
+
+ If optional argument SEARCH-PARTS is non-nil, all sub-parts of tags
+ are searched. The overloadable function `semantic-tag-componenets' is
+ used for the searching child lists. If SEARCH-PARTS is the symbol
+ 'positiononly, then only children that have positional information are
+ searched.
+
+ If SEARCH-INCLUDES has not been implemented.
+ This parameter hasn't be active for a while and is obsolete."
+ (let ((stream (semantic-something-to-tag-table streamorbuffer))
+ (sl nil) ;list of tag children
+ (nl nil) ;new list
+ (case-fold-search semantic-case-fold))
+ (dolist (tag stream)
+ (if (not (semantic-tag-p tag))
+ ;; `semantic-tag-components-with-overlays' can return invalid
+ ;; tags if search-parts is not equal to 'positiononly
+ nil ;; Ignore them!
+ (if (funcall function tag)
+ (setq nl (cons tag nl)))
+ (and search-parts
+ (setq sl (if (eq search-parts 'positiononly)
+ (semantic-tag-components-with-overlays tag)
+ (semantic-tag-components tag))
+ )
+ (setq nl (nconc nl
+ (semantic-brute-find-tag-by-function
+ function sl
+ search-parts))))))
+ (setq nl (nreverse nl))
+ nl))
+
+ (defun semantic-brute-find-first-tag-by-function
+ (function streamorbuffer &optional search-parts search-includes)
+ "Find the first tag which FUNCTION match within STREAMORBUFFER.
+ FUNCTION must return non-nil if an element of STREAM will be included
+ in the new list.
+
+ The following parameters were never implemented.
+
+ If optional argument SEARCH-PARTS, all sub-parts of tags are searched.
+ The overloadable function `semantic-tag-components' is used for
+ searching.
+ If SEARCH-INCLUDES is non-nil, then all include files are also
+ searched for matches."
+ (let ((stream (semantic-something-to-tag-table streamorbuffer))
+ (found nil)
+ (case-fold-search semantic-case-fold))
+ (while (and (not found) stream)
+ (if (funcall function (car stream))
+ (setq found (car stream)))
+ (setq stream (cdr stream)))
+ found))
+
+
+ ;;; Old Positional Searches
+ ;;
+ ;; Are these useful anymore?
+ ;;
+ (defun semantic-brute-find-tag-by-position (position streamorbuffer
+ &optional nomedian)
+ "Find a tag covering POSITION within STREAMORBUFFER.
+ POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do
+ the median calculation, and return nil."
+ (save-excursion
+ (if (markerp position) (set-buffer (marker-buffer position)))
+ (let* ((stream (if (bufferp streamorbuffer)
+ (save-excursion
+ (set-buffer streamorbuffer)
+ (semantic-fetch-tags))
+ streamorbuffer))
+ (prev nil)
+ (found nil))
+ (while (and stream (not found))
+ ;; perfect fit
+ (if (and (>= position (semantic-tag-start (car stream)))
+ (<= position (semantic-tag-end (car stream))))
+ (setq found (car stream))
+ ;; Median between to objects.
+ (if (and prev (not nomedian)
+ (>= position (semantic-tag-end prev))
+ (<= position (semantic-tag-start (car stream))))
+ (let ((median (/ (+ (semantic-tag-end prev)
+ (semantic-tag-start (car stream)))
+ 2)))
+ (setq found
+ (if (> position median)
+ (car stream)
+ prev)))))
+ ;; Next!!!
+ (setq prev (car stream)
+ stream (cdr stream)))
+ found)))
+
+ (defun semantic-brute-find-innermost-tag-by-position
+ (position streamorbuffer &optional nomedian)
+ "Find a list of tags covering POSITION within STREAMORBUFFER.
+ POSITION is a number, or marker. If NOMEDIAN is non-nil, don't do
+ the median calculation, and return nil.
+ This function will find the topmost item, and recurse until no more
+ details are available of findable."
+ (let* ((returnme nil)
+ (current (semantic-brute-find-tag-by-position
+ position streamorbuffer nomedian))
+ (nextstream (and current
+ (if (eq (semantic-tag-class current) 'type)
+ (semantic-tag-type-members current)
+ nil))))
+ (while nextstream
+ (setq returnme (cons current returnme))
+ (setq current (semantic-brute-find-tag-by-position
+ position nextstream nomedian))
+ (setq nextstream (and current
+ ;; NOTE TO SELF:
+ ;; Looking at this after several years away,
+ ;; what does this do???
+ (if (eq (semantic-tag-class current) 'token)
+ (semantic-tag-type-members current)
+ nil))))
+ (nreverse (cons current returnme))))
+
+ (provide 'semantic/find)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/find"
+ ;; End:
+
+ ;;; semantic/find.el ends here
--- /dev/null
-(semantic-varalias-obsolete 'semantic-token->text-functions
- 'semantic-format-tag-functions)
-
+ ;;; semantic/format.el --- Routines for formatting tags
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+ ;;; 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Once a language file has been parsed into a TAG, it is often useful
+ ;; then display that tag information in browsers, completion engines, or
+ ;; help routines. The functions and setup in this file provide ways
+ ;; to reformat a tag into different standard output types.
+ ;;
+ ;; In addition, macros for setting up customizable variables that let
+ ;; the user choose their default format type are also provided.
+ ;;
+
+ ;;; Code:
+ (eval-when-compile (require 'font-lock))
+ (require 'semantic)
+ (require 'semantic/tag-ls)
+ (require 'ezimage)
+
+ (eval-when-compile (require 'semantic/find))
+
+ ;;; Tag to text overload functions
+ ;;
+ ;; abbreviations, prototypes, and coloring support.
+ (defvar semantic-format-tag-functions
+ '(semantic-format-tag-name
+ semantic-format-tag-canonical-name
+ semantic-format-tag-abbreviate
+ semantic-format-tag-summarize
+ semantic-format-tag-summarize-with-file
+ semantic-format-tag-short-doc
+ semantic-format-tag-prototype
+ semantic-format-tag-concise-prototype
+ semantic-format-tag-uml-abbreviate
+ semantic-format-tag-uml-prototype
+ semantic-format-tag-uml-concise-prototype
+ semantic-format-tag-prin1
+ )
+ "List of functions which convert a tag to text.
+ Each function must take the parameters TAG &optional PARENT COLOR.
+ TAG is the tag to convert.
+ PARENT is a parent tag or name which refers to the structure
+ or class which contains TAG. PARENT is NOT a class which a TAG
+ would claim as a parent.
+ COLOR indicates that the generated text should be colored using
+ `font-lock'.")
+
-(semantic-varalias-obsolete 'semantic-token->text-custom-list
- 'semantic-format-tag-custom-list)
-
+ (defvar semantic-format-tag-custom-list
+ (append '(radio)
+ (mapcar (lambda (f) (list 'const f))
+ semantic-format-tag-functions)
+ '(function))
+ "A List used by customizeable variables to choose a tag to text function.
+ Use this variable in the :type field of a customizable variable.")
+
-(semantic-varalias-obsolete 'semantic-face-alist
- 'semantic-format-face-alist)
-
-
+ (defcustom semantic-format-use-images-flag ezimage-use-images
+ "Non-nil means semantic format functions use images.
+ Images can be used as icons instead of some types of text strings."
+ :group 'semantic
+ :type 'boolean)
+
+ (defvar semantic-function-argument-separator ","
+ "Text used to separate arguments when creating text from tags.")
+ (make-variable-buffer-local 'semantic-function-argument-separator)
+
+ (defvar semantic-format-parent-separator "::"
+ "Text used to separate names when between namespaces/classes and functions.")
+ (make-variable-buffer-local 'semantic-format-parent-separator)
+
+ (defvar semantic-format-face-alist
+ `( (function . font-lock-function-name-face)
+ (variable . font-lock-variable-name-face)
+ (type . font-lock-type-face)
+ ;; These are different between Emacsen.
+ (include . ,(if (featurep 'xemacs)
+ 'font-lock-preprocessor-face
+ 'font-lock-constant-face))
+ (package . ,(if (featurep 'xemacs)
+ 'font-lock-preprocessor-face
+ 'font-lock-constant-face))
+ ;; Not a tag, but instead a feature of output
+ (label . font-lock-string-face)
+ (comment . font-lock-comment-face)
+ (keyword . font-lock-keyword-face)
+ (abstract . italic)
+ (static . underline)
+ (documentation . font-lock-doc-face)
+ )
+ "Face used to colorize tags of different types.
+ Override the value locally if a language supports other tag types.
+ When adding new elements, try to use symbols also returned by the parser.
+ The form of an entry in this list is of the form:
+ ( SYMBOL . FACE )
+ where SYMBOL is a tag type symbol used with semantic. FACE
+ is a symbol representing a face.
+ Faces used are generated in `font-lock' for consistency, and will not
+ be used unless font lock is a feature.")
+
-FACE-CLASS is a tag type found in `semantic-face-alist'. See this variable
-for details on adding new types."
+ \f
+ ;;; Coloring Functions
+ ;;
+ (defun semantic--format-colorize-text (text face-class)
+ "Apply onto TEXT a color associated with FACE-CLASS.
-(make-obsolete 'semantic-colorize-text
- 'semantic--format-colorize-text)
-
++FACE-CLASS is a tag type found in `semantic-format-face-alist'.
++See that variable for details on adding new types."
+ (if (featurep 'font-lock)
+ (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
+ (newtext (concat text)))
+ (put-text-property 0 (length text) 'face face newtext)
+ newtext)
+ text))
+
-FACE-CLASS is a tag type found in 'semantic-face-alist'. See this
-variable for details on adding new types."
+ (defun semantic--format-colorize-merge-text (precoloredtext face-class)
+ "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS.
-;; Semantic 1.2.x had this misspelling. Keep it for backwards compatibiity.
-(semantic-alias-obsolete
- 'semantic-summerize-nonterminal 'semantic-format-tag-summarize)
-
++FACE-CLASS is a tag type found in `semantic-formatface-alist'.
++See that variable for details on adding new types."
+ (let ((face (cdr-safe (assoc face-class semantic-format-face-alist)))
+ (newtext (concat precoloredtext))
+ )
+ (if (featurep 'xemacs)
+ (add-text-properties 0 (length newtext) (list 'face face) newtext)
+ (alter-text-property 0 (length newtext) 'face
+ (lambda (current-face)
+ (let ((cf
+ (cond ((facep current-face)
+ (list current-face))
+ ((listp current-face)
+ current-face)
+ (t nil)))
+ (nf
+ (cond ((facep face)
+ (list face))
+ ((listp face)
+ face)
+ (t nil))))
+ (append cf nf)))
+ newtext))
+ newtext))
+
+ ;;; Function Arguments
+ ;;
+ (defun semantic--format-tag-arguments (args formatter color)
+ "Format the argument list ARGS with FORMATTER.
+ FORMATTER is a function used to format a tag.
+ COLOR specifies if color should be used."
+ (let ((out nil))
+ (while args
+ (push (if (and formatter
+ (semantic-tag-p (car args))
+ (not (string= (semantic-tag-name (car args)) ""))
+ )
+ (funcall formatter (car args) nil color)
+ (semantic-format-tag-name-from-anything
+ (car args) nil color 'variable))
+ out)
+ (setq args (cdr args)))
+ (mapconcat 'identity (nreverse out) semantic-function-argument-separator)
+ ))
+
+ ;;; Data Type
+ (define-overloadable-function semantic-format-tag-type (tag color)
+ "Convert the data type of TAG to a string usable in tag formatting.
+ It is presumed that TYPE is a string or semantic tag.")
+
+ (defun semantic-format-tag-type-default (tag color)
+ "Convert the data type of TAG to a string usable in tag formatting.
+ Argument COLOR specifies to colorize the text."
+ (let* ((type (semantic-tag-type tag))
+ (out (cond ((semantic-tag-p type)
+ (let* ((typetype (semantic-tag-type type))
+ (name (semantic-tag-name type))
+ (str (if typetype
+ (concat typetype " " name)
+ name)))
+ (if color
+ (semantic--format-colorize-text
+ str
+ 'type)
+ str)))
+ ((and (listp type)
+ (stringp (car type)))
+ (car type))
+ ((stringp type)
+ type)
+ (t nil))))
+ (if (and color out)
+ (setq out (semantic--format-colorize-text out 'type))
+ out)
+ ))
+
+ \f
+ ;;; Abstract formatting functions
+ ;;
+
+ (defun semantic-format-tag-prin1 (tag &optional parent color)
+ "Convert TAG to a string that is the print name for TAG.
+ PARENT and COLOR are ignored."
+ (format "%S" tag))
+
+ (defun semantic-format-tag-name-from-anything (anything &optional
+ parent color
+ colorhint)
+ "Convert just about anything into a name like string.
+ Argument ANYTHING is the thing to be converted.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.
+ Optional COLORHINT is the type of color to use if ANYTHING is not a tag
+ with a tag class. See `semantic--format-colorize-text' for a definition
+ of FACE-CLASS for which this is used."
+ (cond ((stringp anything)
+ (semantic--format-colorize-text anything colorhint))
+ ((semantic-tag-p anything)
+ (let ((ans (semantic-format-tag-name anything parent color)))
+ ;; If ANS is empty string or nil, then the name wasn't
+ ;; supplied. The implication is as in C where there is a data
+ ;; type but no name for a prototype from an include file, or
+ ;; an argument just wasn't used in the body of the fcn.
+ (if (or (null ans) (string= ans ""))
+ (setq ans (semantic-format-tag-type anything color)))
+ ans))
+ ((and (listp anything)
+ (stringp (car anything)))
+ (semantic--format-colorize-text (car anything) colorhint))))
+
+ ;;;###autoload
+ (define-overloadable-function semantic-format-tag-name (tag &optional parent color)
+ "Return the name string describing TAG.
+ The name is the shortest possible representation.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (defun semantic-format-tag-name-default (tag &optional parent color)
+ "Return an abbreviated string describing TAG.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let ((name (semantic-tag-name tag))
+ (destructor
+ (if (eq (semantic-tag-class tag) 'function)
+ (semantic-tag-function-destructor-p tag))))
+ (when destructor
+ (setq name (concat "~" name)))
+ (if color
+ (setq name (semantic--format-colorize-text name (semantic-tag-class tag))))
+ name))
+
+ (declare-function semantic-go-to-tag "semantic/tag-file")
+
+ (defun semantic--format-tag-parent-tree (tag parent)
+ "Under Consideration.
+
+ Return a list of parents for TAG.
+ PARENT is the first parent, or nil. If nil, then an attempt to
+ determine PARENT is made.
+ Once PARENT is identified, additional parents are looked for.
+ The return list first element is the nearest parent, and the last
+ item is the first parent which may be a string. The root parent may
+ not be the actual first parent as there may just be a failure to find
+ local definitions."
+ ;; First, validate the PARENT argument.
+ (unless parent
+ ;; All mechanisms here must be fast as often parent
+ ;; is nil because there isn't one.
+ (setq parent (or (semantic-tag-function-parent tag)
+ (save-excursion
+ (require 'semantic/tag-file)
+ (semantic-go-to-tag tag)
+ (semantic-current-tag-parent)))))
+ (when (stringp parent)
+ (setq parent (semantic-find-first-tag-by-name
+ parent (current-buffer))))
+ ;; Try and find a trail of parents from PARENT
+ (let ((rlist (list parent))
+ )
+ ;; IMPLELEMENT ME!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ (reverse rlist)))
+
+ (define-overloadable-function semantic-format-tag-canonical-name (tag &optional parent color)
+ "Return a canonical name for TAG.
+ A canonical name includes the names of any parents or namespaces preceeding
+ the tag.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (defun semantic-format-tag-canonical-name-default (tag &optional parent color)
+ "Return a canonical name for TAG.
+ A canonical name includes the names of any parents or namespaces preceeding
+ the tag with colons separating them.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let ((parent-input-str
+ (if (and parent
+ (semantic-tag-p parent)
+ (semantic-tag-of-class-p parent 'type))
+ (concat
+ ;; Choose a class of 'type as the default parent for something.
+ ;; Just a guess though.
+ (semantic-format-tag-name-from-anything parent nil color 'type)
+ ;; Default separator between class/namespace and others.
+ semantic-format-parent-separator)
+ ""))
+ (tag-parent-str
+ (or (when (and (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-function-parent tag))
+ (concat (semantic-tag-function-parent tag)
+ semantic-format-parent-separator))
+ ""))
+ )
+ (concat parent-input-str
+ tag-parent-str
+ (semantic-format-tag-name tag parent color))
+ ))
+
+ (define-overloadable-function semantic-format-tag-abbreviate (tag &optional parent color)
+ "Return an abbreviated string describing TAG.
+ The abbreviation is to be short, with possible symbols indicating
+ the type of tag, or other information.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (defun semantic-format-tag-abbreviate-default (tag &optional parent color)
+ "Return an abbreviated string describing TAG.
+ Optional argument PARENT is a parent tag in the tag hierarchy.
+ In this case PARENT refers to containment, not inheritance.
+ Optional argument COLOR means highlight the prototype with font-lock colors.
+ This is a simple C like default."
+ ;; Do lots of complex stuff here.
+ (let ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-canonical-name tag parent color))
+ (suffix "")
+ (prefix "")
+ str)
+ (cond ((eq class 'function)
+ (setq suffix "()"))
+ ((eq class 'include)
+ (setq suffix "<>"))
+ ((eq class 'variable)
+ (setq suffix (if (semantic-tag-variable-default tag)
+ "=" "")))
+ ((eq class 'label)
+ (setq suffix ":"))
+ ((eq class 'code)
+ (setq prefix "{"
+ suffix "}"))
+ ((eq class 'type)
+ (setq suffix "{}"))
+ )
+ (setq str (concat prefix name suffix))
+ str))
+
- text
- ))
-\f
-;;; Compatibility and aliases
-;;
-(semantic-alias-obsolete 'semantic-prin1-nonterminal
- 'semantic-format-tag-prin1)
-
-(semantic-alias-obsolete 'semantic-name-nonterminal
- 'semantic-format-tag-name)
-
-(semantic-alias-obsolete 'semantic-abbreviate-nonterminal
- 'semantic-format-tag-abbreviate)
-
-(semantic-alias-obsolete 'semantic-summarize-nonterminal
- 'semantic-format-tag-summarize)
-
-(semantic-alias-obsolete 'semantic-prototype-nonterminal
- 'semantic-format-tag-prototype)
-
-(semantic-alias-obsolete 'semantic-concise-prototype-nonterminal
- 'semantic-format-tag-concise-prototype)
-
-(semantic-alias-obsolete 'semantic-uml-abbreviate-nonterminal
- 'semantic-format-tag-uml-abbreviate)
-
-(semantic-alias-obsolete 'semantic-uml-prototype-nonterminal
- 'semantic-format-tag-uml-prototype)
-
-(semantic-alias-obsolete 'semantic-uml-concise-prototype-nonterminal
- 'semantic-format-tag-uml-concise-prototype)
-
+ ;;;###autoload
+ (define-overloadable-function semantic-format-tag-summarize (tag &optional parent color)
+ "Summarize TAG in a reasonable way.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (defun semantic-format-tag-summarize-default (tag &optional parent color)
+ "Summarize TAG in a reasonable way.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((proto (semantic-format-tag-prototype tag nil color))
+ (names (if parent
+ semantic-symbol->name-assoc-list-for-type-parts
+ semantic-symbol->name-assoc-list))
+ (tsymb (semantic-tag-class tag))
+ (label (capitalize (or (cdr-safe (assoc tsymb names))
+ (symbol-name tsymb)))))
+ (if color
+ (setq label (semantic--format-colorize-text label 'label)))
+ (concat label ": " proto)))
+
+ (define-overloadable-function semantic-format-tag-summarize-with-file (tag &optional parent color)
+ "Like `semantic-format-tag-summarize', but with the file name.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (defun semantic-format-tag-summarize-with-file-default (tag &optional parent color)
+ "Summarize TAG in a reasonable way.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((proto (semantic-format-tag-prototype tag nil color))
+ (file (semantic-tag-file-name tag))
+ )
+ ;; Nothing for tag? Try parent.
+ (when (and (not file) (and parent))
+ (setq file (semantic-tag-file-name parent)))
+ ;; Don't include the file name if we can't find one, or it is the
+ ;; same as the current buffer.
+ (if (or (not file)
+ (string= file (buffer-file-name (current-buffer))))
+ proto
+ (setq file (file-name-nondirectory file))
+ (when color
+ (setq file (semantic--format-colorize-text file 'label)))
+ (concat file ": " proto))))
+
+ (define-overloadable-function semantic-format-tag-short-doc (tag &optional parent color)
+ "Display a short form of TAG's documentation. (Comments, or docstring.)
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (declare-function semantic-documentation-for-tag "semantic/doc")
+
+ (defun semantic-format-tag-short-doc-default (tag &optional parent color)
+ "Display a short form of TAG's documentation. (Comments, or docstring.)
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((fname (or (semantic-tag-file-name tag)
+ (when parent (semantic-tag-file-name parent))))
+ (buf (or (semantic-tag-buffer tag)
+ (when parent (semantic-tag-buffer parent))))
+ (doc (semantic-tag-docstring tag buf)))
+ (when (and (not doc) (not buf) fname)
+ ;; If there is no doc, and no buffer, but we have a filename,
+ ;; lets try again.
+ (save-match-data
+ (setq buf (find-file-noselect fname)))
+ (setq doc (semantic-tag-docstring tag buf)))
+ (when (not doc)
+ (require 'semantic/doc)
+ (setq doc (semantic-documentation-for-tag tag))
+ )
+ (setq doc
+ (if (not doc)
+ ;; No doc, use summarize.
+ (semantic-format-tag-summarize tag parent color)
+ ;; We have doc. Can we devise a single line?
+ (if (string-match "$" doc)
+ (substring doc 0 (match-beginning 0))
+ doc)
+ ))
+ (when color
+ (setq doc (semantic--format-colorize-text doc 'documentation)))
+ doc
+ ))
+
+ ;;; Prototype generation
+ ;;
+ ;;;###autoload
+ (define-overloadable-function semantic-format-tag-prototype (tag &optional parent color)
+ "Return a prototype for TAG.
+ This function should be overloaded, though it need not be used.
+ This is because it can be used to create code by language independent
+ tools.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (defun semantic-format-tag-prototype-default (tag &optional parent color)
+ "Default method for returning a prototype for TAG.
+ This will work for C like languages.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color))
+ (type (if (member class '(function variable type))
+ (semantic-format-tag-type tag color)))
+ (args (if (member class '(function type))
+ (semantic--format-tag-arguments
+ (if (eq class 'function)
+ (semantic-tag-function-arguments tag)
+ (list "")
+ ;;(semantic-tag-type-members tag)
+ )
+ #'semantic-format-tag-prototype
+ color)))
+ (const (semantic-tag-get-attribute tag :constant-flag))
+ (tm (semantic-tag-get-attribute tag :typemodifiers))
+ (mods (append
+ (if const '("const") nil)
+ (cond ((stringp tm) (list tm))
+ ((consp tm) tm)
+ (t nil))
+ ))
+ (array (if (eq class 'variable)
+ (let ((deref
+ (semantic-tag-get-attribute
+ tag :dereference))
+ (r ""))
+ (while (and deref (/= deref 0))
+ (setq r (concat r "[]")
+ deref (1- deref)))
+ r)))
+ )
+ (if args
+ (setq args
+ (concat " "
+ (if (eq class 'type) "{" "(")
+ args
+ (if (eq class 'type) "}" ")"))))
+ (when mods
+ (setq mods (concat (mapconcat 'identity mods " ") " ")))
+ (concat (or mods "")
+ (if type (concat type " "))
+ name
+ (or args "")
+ (or array ""))))
+
+ ;;;###autoload
+ (define-overloadable-function semantic-format-tag-concise-prototype (tag &optional parent color)
+ "Return a concise prototype for TAG.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (defun semantic-format-tag-concise-prototype-default (tag &optional parent color)
+ "Return a concise prototype for TAG.
+ This default function will make a cheap concise prototype using C like syntax.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let ((class (semantic-tag-class tag)))
+ (cond
+ ((eq class 'type)
+ (concat (semantic-format-tag-name tag parent color) "{}"))
+ ((eq class 'function)
+ (concat (semantic-format-tag-name tag parent color)
+ " ("
+ (semantic--format-tag-arguments
+ (semantic-tag-function-arguments tag)
+ 'semantic-format-tag-concise-prototype
+ color)
+ ")"))
+ ((eq class 'variable)
+ (let* ((deref (semantic-tag-get-attribute
+ tag :dereference))
+ (array "")
+ )
+ (while (and deref (/= deref 0))
+ (setq array (concat array "[]")
+ deref (1- deref)))
+ (concat (semantic-format-tag-name tag parent color)
+ array)))
+ (t
+ (semantic-format-tag-abbreviate tag parent color)))))
+
+ ;;; UML display styles
+ ;;
+ (defcustom semantic-uml-colon-string " : "
+ "*String used as a color separator between parts of a UML string.
+ In UML, a variable may appear as `varname : type'.
+ Change this variable to change the output separator."
+ :group 'semantic
+ :type 'string)
+
+ (defcustom semantic-uml-no-protection-string ""
+ "*String used to describe when no protection is specified.
+ Used by `semantic-format-tag-uml-protection-to-string'."
+ :group 'semantic
+ :type 'string)
+
+ (defun semantic--format-uml-post-colorize (text tag parent)
+ "Add color to TEXT created from TAG and PARENT.
+ Adds augmentation for `abstract' and `static' entries."
+ (if (semantic-tag-abstract-p tag parent)
+ (setq text (semantic--format-colorize-merge-text text 'abstract)))
+ (if (semantic-tag-static-p tag parent)
+ (setq text (semantic--format-colorize-merge-text text 'static)))
+ text
+ )
+
+ (defun semantic-uml-attribute-string (tag &optional parent)
+ "Return a string for TAG, a child of PARENT representing a UML attribute.
+ UML attribute strings are things like {abstract} or {leaf}."
+ (cond ((semantic-tag-abstract-p tag parent)
+ "{abstract}")
+ ((semantic-tag-leaf-p tag parent)
+ "{leaf}")
+ ))
+
+ (defvar semantic-format-tag-protection-image-alist
+ '(("+" . ezimage-unlock)
+ ("#" . ezimage-key)
+ ("-" . ezimage-lock)
+ )
+ "Association of protection strings, and images to use.")
+
+ (defvar semantic-format-tag-protection-symbol-to-string-assoc-list
+ '((public . "+")
+ (protected . "#")
+ (private . "-")
+ )
+ "Association list of the form (SYMBOL . \"STRING\") for protection symbols.
+ This associates a symbol, such as 'public with the st ring \"+\".")
+
+ (define-overloadable-function semantic-format-tag-uml-protection-to-string (protection-symbol color)
+ "Convert PROTECTION-SYMBOL to a string for UML.
+ By default, uses `semantic-format-tag-protection-symbol-to-string-assoc-list'
+ to convert.
+ By defaul character returns are:
+ public -- +
+ private -- -
+ protected -- #.
+ If PROTECTION-SYMBOL is unknown, then the return value is
+ `semantic-uml-no-protection-string'.
+ COLOR indicates if we should use an image on the text.")
+
+ (defun semantic-format-tag-uml-protection-to-string-default (protection-symbol color)
+ "Convert PROTECTION-SYMBOL to a string for UML.
+ Uses `semantic-format-tag-protection-symbol-to-string-assoc-list' to convert.
+ If PROTECTION-SYMBOL is unknown, then the return value is
+ `semantic-uml-no-protection-string'.
+ COLOR indicates if we should use an image on the text."
+ (let* ((ezimage-use-images (and semantic-format-use-images-flag color))
+ (key (assoc protection-symbol
+ semantic-format-tag-protection-symbol-to-string-assoc-list))
+ (str (or (cdr-safe key) semantic-uml-no-protection-string)))
+ (ezimage-image-over-string
+ (copy-sequence str) ; make a copy to keep the original pristine.
+ semantic-format-tag-protection-image-alist)))
+
+ (defsubst semantic-format-tag-uml-protection (tag parent color)
+ "Retrieve the protection string for TAG with PARENT.
+ Argument COLOR specifies that color should be added to the string as
+ needed."
+ (semantic-format-tag-uml-protection-to-string
+ (semantic-tag-protection tag parent)
+ color))
+
+ (defun semantic--format-tag-uml-type (tag color)
+ "Format the data type of TAG to a string usable for formatting.
+ COLOR indicates if it should be colorized."
+ (let ((str (semantic-format-tag-type tag color)))
+ (if str
+ (concat semantic-uml-colon-string str))))
+
+ (define-overloadable-function semantic-format-tag-uml-abbreviate (tag &optional parent color)
+ "Return a UML style abbreviation for TAG.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (defun semantic-format-tag-uml-abbreviate-default (tag &optional parent color)
+ "Return a UML style abbreviation for TAG.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((name (semantic-format-tag-name tag parent color))
+ (type (semantic--format-tag-uml-type tag color))
+ (protstr (semantic-format-tag-uml-protection tag parent color))
+ (text nil))
+ (setq text
+ (concat
+ protstr
+ (if type (concat name type)
+ name)))
+ (if color
+ (setq text (semantic--format-uml-post-colorize text tag parent)))
+ text))
+
+ (define-overloadable-function semantic-format-tag-uml-prototype (tag &optional parent color)
+ "Return a UML style prototype for TAG.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (defun semantic-format-tag-uml-prototype-default (tag &optional parent color)
+ "Return a UML style prototype for TAG.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((class (semantic-tag-class tag))
+ (cp (semantic-format-tag-name tag parent color))
+ (type (semantic--format-tag-uml-type tag color))
+ (prot (semantic-format-tag-uml-protection tag parent color))
+ (argtext
+ (cond ((eq class 'function)
+ (concat
+ " ("
+ (semantic--format-tag-arguments
+ (semantic-tag-function-arguments tag)
+ #'semantic-format-tag-uml-prototype
+ color)
+ ")"))
+ ((eq class 'type)
+ "{}")))
+ (text nil))
+ (setq text (concat prot cp argtext type))
+ (if color
+ (setq text (semantic--format-uml-post-colorize text tag parent)))
+ text
+ ))
+
+ (define-overloadable-function semantic-format-tag-uml-concise-prototype (tag &optional parent color)
+ "Return a UML style concise prototype for TAG.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors.")
+
+ (defun semantic-format-tag-uml-concise-prototype-default (tag &optional parent color)
+ "Return a UML style concise prototype for TAG.
+ Optional argument PARENT is the parent type if TAG is a detail.
+ Optional argument COLOR means highlight the prototype with font-lock colors."
+ (let* ((cp (semantic-format-tag-concise-prototype tag parent color))
+ (type (semantic--format-tag-uml-type tag color))
+ (prot (semantic-format-tag-uml-protection tag parent color))
+ (text nil)
+ )
+ (setq text (concat prot cp type))
+ (if color
+ (setq text (semantic--format-uml-post-colorize text tag parent)))
++ text))
+
+ (provide 'semantic/format)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/format"
+ ;; End:
+
+ ;;; semantic/format.el ends here
--- /dev/null
-;;; semantic-fw.el --- Framework for Semantic
++;;; semantic/fw.el --- Framework for Semantic
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+ ;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Semantic has several core features shared across it's lex/parse/util
+ ;; stages. This used to clutter semantic.el some. These routines are all
+ ;; simple things that are not parser specific, but aid in making
+ ;; semantic flexible and compatible amongst different Emacs platforms.
+
+ ;;; Code:
+ ;;
+ (require 'mode-local)
+ (require 'eieio)
+ (require 'semantic/loaddefs)
+
+ ;;; Compatibility
-;;
-(if (featurep 'xemacs)
- (progn
- (defalias 'semantic-buffer-local-value 'symbol-value-in-buffer)
- (defalias 'semantic-overlay-live-p
- (lambda (o)
- (and (extent-live-p o)
- (not (extent-detached-p o))
- (bufferp (extent-buffer o)))))
- (defalias 'semantic-make-overlay
- (lambda (beg end &optional buffer &rest rest)
- "Xemacs `make-extent', supporting the front/rear advance options."
- (let ((ol (make-extent beg end buffer)))
- (when rest
- (set-extent-property ol 'start-open (car rest))
- (setq rest (cdr rest)))
- (when rest
- (set-extent-property ol 'end-open (car rest)))
- ol)))
- (defalias 'semantic-overlay-put 'set-extent-property)
- (defalias 'semantic-overlay-get 'extent-property)
- (defalias 'semantic-overlay-properties 'extent-properties)
- (defalias 'semantic-overlay-move 'set-extent-endpoints)
- (defalias 'semantic-overlay-delete 'delete-extent)
- (defalias 'semantic-overlays-at
- (lambda (pos)
- (condition-case nil
- (extent-list nil pos pos)
- (error nil))
- ))
- (defalias 'semantic-overlays-in
- (lambda (beg end) (extent-list nil beg end)))
- (defalias 'semantic-overlay-buffer 'extent-buffer)
- (defalias 'semantic-overlay-start 'extent-start-position)
- (defalias 'semantic-overlay-end 'extent-end-position)
- (defalias 'semantic-overlay-size 'extent-length)
- (defalias 'semantic-overlay-next-change 'next-extent-change)
- (defalias 'semantic-overlay-previous-change 'previous-extent-change)
- (defalias 'semantic-overlay-lists
- (lambda () (list (extent-list))))
- (defalias 'semantic-overlay-p 'extentp)
- (defalias 'semantic-event-window 'event-window)
- (defun semantic-read-event ()
- (let ((event (next-command-event)))
- (if (key-press-event-p event)
- (let ((c (event-to-character event)))
- (if (char-equal c (quit-char))
- (keyboard-quit)
- c)))
- event))
- (defun semantic-popup-menu (menu)
- "Blockinig version of `popup-menu'"
- (popup-menu menu)
- ;; Wait...
- (while (popup-up-p) (dispatch-event (next-event))))
- )
- ;; Emacs Bindings
- (defalias 'semantic-buffer-local-value 'buffer-local-value)
- (defalias 'semantic-overlay-live-p 'overlay-buffer)
- (defalias 'semantic-make-overlay 'make-overlay)
- (defalias 'semantic-overlay-put 'overlay-put)
- (defalias 'semantic-overlay-get 'overlay-get)
- (defalias 'semantic-overlay-properties 'overlay-properties)
- (defalias 'semantic-overlay-move 'move-overlay)
- (defalias 'semantic-overlay-delete 'delete-overlay)
- (defalias 'semantic-overlays-at 'overlays-at)
- (defalias 'semantic-overlays-in 'overlays-in)
- (defalias 'semantic-overlay-buffer 'overlay-buffer)
- (defalias 'semantic-overlay-start 'overlay-start)
- (defalias 'semantic-overlay-end 'overlay-end)
- (defalias 'semantic-overlay-size 'overlay-size)
- (defalias 'semantic-overlay-next-change 'next-overlay-change)
- (defalias 'semantic-overlay-previous-change 'previous-overlay-change)
- (defalias 'semantic-overlay-lists 'overlay-lists)
- (defalias 'semantic-overlay-p 'overlayp)
- (defalias 'semantic-read-event 'read-event)
- (defalias 'semantic-popup-menu 'popup-menu)
- (defun semantic-event-window (event)
- "Extract the window from EVENT."
- (car (car (cdr event))))
- )
-
-(if (and (not (featurep 'xemacs))
- (>= emacs-major-version 21))
- (defalias 'semantic-make-local-hook 'identity)
- (defalias 'semantic-make-local-hook 'make-local-hook)
- )
-
-(if (featurep 'xemacs)
- (defalias 'semantic-mode-line-update 'redraw-modeline)
- (defalias 'semantic-mode-line-update 'force-mode-line-update))
-
-;; Since Emacs 22 major mode functions should use `run-mode-hooks' to
-;; run major mode hooks.
-(defalias 'semantic-run-mode-hooks
- (if (fboundp 'run-mode-hooks)
- 'run-mode-hooks
- 'run-hooks))
-
-;; Fancy compat useage now handled in cedet-compat
-(defalias 'semantic-subst-char-in-string 'subst-char-in-string)
+
++(defalias 'semantic-buffer-local-value 'buffer-local-value)
++(defalias 'semantic-overlay-live-p 'overlay-buffer)
++(defalias 'semantic-make-overlay 'make-overlay)
++(defalias 'semantic-overlay-put 'overlay-put)
++(defalias 'semantic-overlay-get 'overlay-get)
++(defalias 'semantic-overlay-properties 'overlay-properties)
++(defalias 'semantic-overlay-move 'move-overlay)
++(defalias 'semantic-overlay-delete 'delete-overlay)
++(defalias 'semantic-overlays-at 'overlays-at)
++(defalias 'semantic-overlays-in 'overlays-in)
++(defalias 'semantic-overlay-buffer 'overlay-buffer)
++(defalias 'semantic-overlay-start 'overlay-start)
++(defalias 'semantic-overlay-end 'overlay-end)
++(defalias 'semantic-overlay-size 'overlay-size)
++(defalias 'semantic-overlay-next-change 'next-overlay-change)
++(defalias 'semantic-overlay-previous-change 'previous-overlay-change)
++(defalias 'semantic-overlay-lists 'overlay-lists)
++(defalias 'semantic-overlay-p 'overlayp)
++(defalias 'semantic-read-event 'read-event)
++(defalias 'semantic-popup-menu 'popup-menu)
++(defalias 'semantic-make-local-hook 'identity)
++(defalias 'semantic-mode-line-update 'force-mode-line-update)
++(defalias 'semantic-run-mode-hooks 'run-mode-hooks)
++(defalias 'semantic-compile-warn 'byte-compile-warn)
++(defalias 'semantic-menu-item 'identity)
++
++(defun semantic-event-window (event)
++ "Extract the window from EVENT."
++ (car (car (cdr event))))
+
+ (defun semantic-delete-overlay-maybe (overlay)
+ "Delete OVERLAY if it is a semantic token overlay."
+ (if (semantic-overlay-get overlay 'semantic)
+ (semantic-overlay-delete overlay)))
+
-(defalias 'semantic-compile-warn
- (eval-when-compile
- (if (fboundp 'byte-compile-warn)
- 'byte-compile-warn
- 'message)))
-
-(if (not (fboundp 'string-to-number))
- (defalias 'string-to-number 'string-to-int))
-
-;;; Menu Item compatibility
-;;
-(defun semantic-menu-item (item)
- "Build an XEmacs compatible menu item from vector ITEM.
-That is remove the unsupported :help stuff."
- (if (featurep 'xemacs)
- (let ((n (length item))
- (i 0)
- slot l)
- (while (< i n)
- (setq slot (aref item i))
- (if (and (keywordp slot)
- (eq slot :help))
- (setq i (1+ i))
- (setq l (cons slot l)))
- (setq i (1+ i)))
- (apply #'vector (nreverse l)))
- item))
-
+ ;;; Positional Data Cache
+ ;;
+ (defvar semantic-cache-data-overlays nil
+ "List of all overlays waiting to be flushed.")
+
+ (defun semantic-cache-data-to-buffer (buffer start end value name &optional lifespan)
+ "In BUFFER over the region START END, remember VALUE.
+ NAME specifies a special name that can be searched for later to
+ recover the cached data with `semantic-get-cache-data'.
+ LIFESPAN indicates how long the data cache will be remembered.
+ The default LIFESPAN is 'end-of-command.
+ Possible Lifespans are:
+ 'end-of-command - Remove the cache at the end of the currently
+ executing command.
+ 'exit-cache-zone - Remove when point leaves the overlay at the
+ end of the currently executing command."
+ ;; Check if LIFESPAN is valid before to create any overlay
+ (or lifespan (setq lifespan 'end-of-command))
+ (or (memq lifespan '(end-of-command exit-cache-zone))
+ (error "semantic-cache-data-to-buffer: Unknown LIFESPAN: %s"
+ lifespan))
+ (let ((o (semantic-make-overlay start end buffer)))
+ (semantic-overlay-put o 'cache-name name)
+ (semantic-overlay-put o 'cached-value value)
+ (semantic-overlay-put o 'lifespan lifespan)
+ (setq semantic-cache-data-overlays
+ (cons o semantic-cache-data-overlays))
+ ;;(message "Adding to cache: %s" o)
+ (add-hook 'post-command-hook 'semantic-cache-data-post-command-hook)
+ ))
+
+ (defun semantic-cache-data-post-command-hook ()
+ "Flush `semantic-cache-data-overlays' based 'lifespan property.
+ Remove self from `post-command-hook' if it is empty."
+ (let ((newcache nil)
+ (oldcache semantic-cache-data-overlays))
+ (while oldcache
+ (let* ((o (car oldcache))
+ (life (semantic-overlay-get o 'lifespan))
+ )
+ (if (or (eq life 'end-of-command)
+ (and (eq life 'exit-cache-zone)
+ (not (member o (semantic-overlays-at (point))))))
+ (progn
+ ;;(message "Removing from cache: %s" o)
+ (semantic-overlay-delete o)
+ )
+ (setq newcache (cons o newcache))))
+ (setq oldcache (cdr oldcache)))
+ (setq semantic-cache-data-overlays (nreverse newcache)))
+
+ ;; Remove ourselves if we have removed all overlays.
+ (unless semantic-cache-data-overlays
+ (remove-hook 'post-command-hook
+ 'semantic-cache-data-post-command-hook)))
+
+ (defun semantic-get-cache-data (name &optional point)
+ "Get cached data with NAME from optional POINT."
+ (save-excursion
+ (if point (goto-char point))
+ (let ((o (semantic-overlays-at (point)))
+ (ans nil))
+ (while (and (not ans) o)
+ (if (equal (semantic-overlay-get (car o) 'cache-name) name)
+ (setq ans (car o))
+ (setq o (cdr o))))
+ (when ans
+ (semantic-overlay-get ans 'cached-value)))))
+
+ ;;; Obsoleting various functions & variables
+ ;;
+ (defun semantic-overload-symbol-from-function (name)
+ "Return the symbol for overload used by NAME, the defined symbol."
+ (let ((sym-name (symbol-name name)))
+ (if (string-match "^semantic-" sym-name)
+ (intern (substring sym-name (match-end 0)))
+ name)))
+
+ (defun semantic-alias-obsolete (oldfnalias newfn)
+ "Make OLDFNALIAS an alias for NEWFN.
+ Mark OLDFNALIAS as obsolete, such that the byte compiler
+ will throw a warning when it encounters this symbol."
+ (defalias oldfnalias newfn)
+ (make-obsolete oldfnalias newfn)
+ (when (and (function-overload-p newfn)
+ (not (overload-obsoleted-by newfn))
+ ;; Only throw this warning when byte compiling things.
+ (boundp 'byte-compile-current-file)
+ byte-compile-current-file
+ (not (string-match "cedet" byte-compile-current-file))
+ )
+ (make-obsolete-overload oldfnalias newfn)
+ (semantic-compile-warn
+ "%s: `%s' obsoletes overload `%s'"
+ byte-compile-current-file
+ newfn
+ (semantic-overload-symbol-from-function oldfnalias))
+ ))
+
+ (defun semantic-varalias-obsolete (oldvaralias newvar)
+ "Make OLDVARALIAS an alias for variable NEWVAR.
+ Mark OLDVARALIAS as obsolete, such that the byte compiler
+ will throw a warning when it encounters this symbol."
+ (make-obsolete-variable oldvaralias newvar)
+ (condition-case nil
+ (defvaralias oldvaralias newvar)
+ (error
+ ;; Only throw this warning when byte compiling things.
+ (when (and (boundp 'byte-compile-current-file)
+ byte-compile-current-file)
+ (semantic-compile-warn
+ "variable `%s' obsoletes, but isn't alias of `%s'"
+ newvar oldvaralias)
+ ))))
+ \f
+ ;;; Help debugging
+ ;;
+ (defmacro semantic-safe (format &rest body)
+ "Turn into a FORMAT message any error caught during eval of BODY.
+ Return the value of last BODY form or nil if an error occurred.
+ FORMAT can have a %s escape which will be replaced with the actual
+ error message.
+ If `debug-on-error' is set, errors are not caught, so that you can
+ debug them.
+ Avoid using a large BODY since it is duplicated."
+ ;;(declare (debug t) (indent 1))
+ `(if debug-on-error
+ ;;(let ((inhibit-quit nil)) ,@body)
+ ;; Note to self: Doing the above screws up the wisent parser.
+ (progn ,@body)
+ (condition-case err
+ (progn ,@body)
+ (error
+ (message ,format (format "%S - %s" (current-buffer)
+ (error-message-string err)))
+ nil))))
+ (put 'semantic-safe 'lisp-indent-function 1)
+
+ ;;; Misc utilities
+ ;;
+ (defsubst semantic-map-buffers (function)
+ "Run FUNCTION for each Semantic enabled buffer found.
+ FUNCTION does not have arguments. When FUNCTION is entered
+ `current-buffer' is a selected Semantic enabled buffer."
+ (mode-local-map-file-buffers function #'semantic-active-p))
+
-(defalias 'semantic-map-mode-buffers
- 'mode-local-map-mode-buffers)
-
-(semantic-alias-obsolete 'semantic-fetch-overload
- 'fetch-overload)
++(defalias 'semantic-map-mode-buffers 'mode-local-map-mode-buffers)
+
+ (semantic-alias-obsolete 'define-mode-overload-implementation
+ 'define-mode-local-override)
+
-(semantic-alias-obsolete 'semantic-with-mode-bindings
- 'with-mode-local)
-
-(semantic-alias-obsolete 'define-semantic-child-mode
- 'define-child-mode)
-
+ (defun semantic-install-function-overrides (overrides &optional transient mode)
+ "Install the function OVERRIDES in the specified environment.
+ OVERRIDES must be an alist ((OVERLOAD . FUNCTION) ...) where OVERLOAD
+ is a symbol identifying an overloadable entry, and FUNCTION is the
+ function to override it with.
+ If optional argument TRANSIENT is non-nil, installed overrides can in
+ turn be overridden by next installation.
+ If optional argument MODE is non-nil, it must be a major mode symbol.
+ OVERRIDES will be installed globally for this major mode. If MODE is
+ nil, OVERRIDES will be installed locally in the current buffer. This
+ later installation should be done in MODE hook."
+ (mode-local-bind
+ ;; Add the semantic- prefix to OVERLOAD short names.
+ (mapcar
+ #'(lambda (e)
+ (let ((name (symbol-name (car e))))
+ (if (string-match "^semantic-" name)
+ e
+ (cons (intern (format "semantic-%s" name)) (cdr e)))))
+ overrides)
+ (list 'constant-flag (not transient)
+ 'override-flag t)
+ mode))
+ \f
+ ;;; User Interrupt handling
+ ;;
+ (defvar semantic-current-input-throw-symbol nil
+ "The current throw symbol for `semantic-exit-on-input'.")
+
+ (defmacro semantic-exit-on-input (symbol &rest forms)
+ "Using SYMBOL as an argument to `throw', execute FORMS.
+ If FORMS includes a call to `semantic-thow-on-input', then
+ if a user presses any key during execution, this form macro
+ will exit with the value passed to `semantic-throw-on-input'.
+ If FORMS completes, then the return value is the same as `progn'."
+ `(let ((semantic-current-input-throw-symbol ,symbol))
+ (catch ,symbol
+ ,@forms)))
+ (put 'semantic-exit-on-input 'lisp-indent-function 1)
+
+ (defmacro semantic-throw-on-input (from)
+ "Exit with `throw' when in `semantic-exit-on-input' on user input.
+ FROM is an indication of where this function is called from as a value
+ to pass to `throw'. It is recommended to use the name of the function
+ calling this one."
+ `(when (and semantic-current-input-throw-symbol
+ (or (input-pending-p) (accept-process-output)))
+ (throw semantic-current-input-throw-symbol ,from)))
+
+ \f
+ ;;; Special versions of Find File
+ ;;
+ (defun semantic-find-file-noselect (file &optional nowarn rawfile wildcards)
+ "Call `find-file-noselect' with various features turned off.
+ Use this when referencing a file that will be soon deleted.
+ FILE, NOWARN, RAWFILE, and WILDCARDS are passed into `find-file-noselect'"
+ (let* ((recentf-exclude '( (lambda (f) t) ))
+ ;; This is a brave statement. Don't waste time loading in
+ ;; lots of modes. Especially decoration mode can waste a lot
+ ;; of time for a buffer we intend to kill.
+ (semantic-init-hook nil)
+ ;; This disables the part of EDE that asks questions
+ (ede-auto-add-method 'never)
+ ;; Ask font-lock to not colorize these buffers, nor to
+ ;; whine about it either.
+ (font-lock-maximum-size 0)
+ (font-lock-verbose nil)
+ ;; Disable revision control
+ (vc-handled-backends nil)
+ ;; Don't prompt to insert a template if we visit an empty file
+ (auto-insert nil)
+ ;; We don't want emacs to query about unsafe local variables
+ (enable-local-variables
+ (if (featurep 'xemacs)
+ ;; XEmacs only has nil as an option?
+ nil
+ ;; Emacs 23 has the spiffy :safe option, nil otherwise.
+ (if (>= emacs-major-version 22)
+ nil
+ :safe)))
+ ;; ... or eval variables
+ (enable-local-eval nil)
+ )
+ (save-match-data
+ (if (featurep 'xemacs)
+ (find-file-noselect file nowarn rawfile)
+ (find-file-noselect file nowarn rawfile wildcards)))
+ ))
+
+ \f
-;;; Editor goodies ;-)
-;;
-(defconst semantic-fw-font-lock-keywords
- (eval-when-compile
- (let* (
- ;; Variable declarations
- (vl nil)
- (kv (if vl (regexp-opt vl t) ""))
- ;; Function declarations
- (vf '(
- "define-lex"
- "define-lex-analyzer"
- "define-lex-block-analyzer"
- "define-lex-regex-analyzer"
- "define-lex-spp-macro-declaration-analyzer"
- "define-lex-spp-macro-undeclaration-analyzer"
- "define-lex-spp-include-analyzer"
- "define-lex-simple-regex-analyzer"
- "define-lex-keyword-type-analyzer"
- "define-lex-sexp-type-analyzer"
- "define-lex-regex-type-analyzer"
- "define-lex-string-type-analyzer"
- "define-lex-block-type-analyzer"
- ;;"define-mode-overload-implementation"
- ;;"define-semantic-child-mode"
- "define-semantic-idle-service"
- "define-semantic-decoration-style"
- "define-wisent-lexer"
- "semantic-alias-obsolete"
- "semantic-varalias-obsolete"
- "semantic-make-obsolete-overload"
- "defcustom-mode-local-semantic-dependency-system-include-path"
- ))
- (kf (if vf (regexp-opt vf t) ""))
- ;; Regexp depths
- (kv-depth (if kv (regexp-opt-depth kv) nil))
- (kf-depth (if kf (regexp-opt-depth kf) nil))
- )
- `((,(concat
- ;; Declarative things
- "(\\(" kv "\\|" kf "\\)"
- ;; Whitespaces & names
- "\\>[ \t]*\\(\\sw+\\)?[ \t]*\\(\\sw+\\)?"
- )
- (1 font-lock-keyword-face)
- (,(+ 1 kv-depth kf-depth 1)
- (cond ((match-beginning 2)
- font-lock-type-face)
- ((match-beginning ,(+ 1 kv-depth 1))
- font-lock-function-name-face)
- )
- nil t)
- (,(+ 1 kv-depth kf-depth 1 1)
- (cond ((match-beginning 2)
- font-lock-variable-name-face)
- )
- nil t)))
- ))
- "Highlighted Semantic keywords.")
++;; ;;; Editor goodies ;-)
++;; ;;
++;; (defconst semantic-fw-font-lock-keywords
++;; (eval-when-compile
++;; (let* (
++;; ;; Variable declarations
++;; (vl nil)
++;; (kv (if vl (regexp-opt vl t) ""))
++;; ;; Function declarations
++;; (vf '(
++;; "define-lex"
++;; "define-lex-analyzer"
++;; "define-lex-block-analyzer"
++;; "define-lex-regex-analyzer"
++;; "define-lex-spp-macro-declaration-analyzer"
++;; "define-lex-spp-macro-undeclaration-analyzer"
++;; "define-lex-spp-include-analyzer"
++;; "define-lex-simple-regex-analyzer"
++;; "define-lex-keyword-type-analyzer"
++;; "define-lex-sexp-type-analyzer"
++;; "define-lex-regex-type-analyzer"
++;; "define-lex-string-type-analyzer"
++;; "define-lex-block-type-analyzer"
++;; ;;"define-mode-overload-implementation"
++;; ;;"define-semantic-child-mode"
++;; "define-semantic-idle-service"
++;; "define-semantic-decoration-style"
++;; "define-wisent-lexer"
++;; "semantic-alias-obsolete"
++;; "semantic-varalias-obsolete"
++;; "semantic-make-obsolete-overload"
++;; "defcustom-mode-local-semantic-dependency-system-include-path"
++;; ))
++;; (kf (if vf (regexp-opt vf t) ""))
++;; ;; Regexp depths
++;; (kv-depth (if kv (regexp-opt-depth kv) nil))
++;; (kf-depth (if kf (regexp-opt-depth kf) nil))
++;; )
++;; `((,(concat
++;; ;; Declarative things
++;; "(\\(" kv "\\|" kf "\\)"
++;; ;; Whitespaces & names
++;; "\\>[ \t]*\\(\\sw+\\)?[ \t]*\\(\\sw+\\)?"
++;; )
++;; (1 font-lock-keyword-face)
++;; (,(+ 1 kv-depth kf-depth 1)
++;; (cond ((match-beginning 2)
++;; font-lock-type-face)
++;; ((match-beginning ,(+ 1 kv-depth 1))
++;; font-lock-function-name-face)
++;; )
++;; nil t)
++;; (,(+ 1 kv-depth kf-depth 1 1)
++;; (cond ((match-beginning 2)
++;; font-lock-variable-name-face)
++;; )
++;; nil t)))
++;; ))
++;; "Highlighted Semantic keywords.")
+
+ ;; (when (fboundp 'font-lock-add-keywords)
+ ;; (font-lock-add-keywords 'emacs-lisp-mode
+ ;; semantic-fw-font-lock-keywords))
+ \f
+ ;;; Interfacing with edebug
+ ;;
+ (defun semantic-fw-add-edebug-spec ()
+ (def-edebug-spec semantic-exit-on-input 'def-body))
+
+ (add-hook 'edebug-setup-hook 'semantic-fw-add-edebug-spec)
+
+ (provide 'semantic/fw)
+
-;;; semantic-fw.el ends here
++;;; semantic/fw.el ends here
--- /dev/null
-
-;; (eval-when-compile
-;; (require 'semantic/analyze))
-
+ ;;; semantic/grammar.el --- Major mode framework for Semantic grammars
+
+ ;;; Copyright (C) 2002, 2003, 2004, 2005, 2007, 2008, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: David Ponce <david@dponce.com>
+ ;; Maintainer: David Ponce <david@dponce.com>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Major mode framework for editing Semantic's input grammar files.
+
+ ;;; History:
+ ;;
+
+ ;;; Code:
+
+ (require 'semantic)
+ (require 'semantic/ctxt)
+ (require 'semantic/format)
+ (require 'semantic/grammar-wy)
+ (require 'semantic/idle)
+ (declare-function semantic-momentary-highlight-tag "semantic/decorate")
+ (declare-function semantic-analyze-context "semantic/analyze")
+ (declare-function semantic-analyze-tags-of-class-list
+ "semantic/analyze/complete")
+
-;;(require 'semantic/wisent)
-;; (require 'font-lock)
-;; (require 'pp)
-
-;; (eval-when-compile
-;; ;; (require 'senator)
-;; (require 'semantic/edit)
-;; (require 'semantic/find)
-;; (require 'semantic/format)
-;; (require 'semantic/idle))
-
+ (eval-when-compile
+ (require 'eldoc)
+ (require 'semantic/edit)
+ (require 'semantic/find))
+
- ;; Append the Semantic keywords
- ,@semantic-fw-font-lock-keywords
+ \f
+ ;;;;
+ ;;;; Set up lexer
+ ;;;;
+
+ (defconst semantic-grammar-lex-c-char-re "'\\s\\?.'"
+ "Regexp matching C-like character literals.")
+
+ ;; Most of the analyzers are auto-generated from the grammar, but the
+ ;; following which need special handling code.
+ ;;
+ (define-lex-regex-analyzer semantic-grammar-lex-prologue
+ "Detect and create a prologue token."
+ "\\<%{"
+ ;; Zing to the end of this brace block.
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'PROLOGUE (point)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection 'PROLOGUE
+ (forward-char)
+ (forward-sexp 1)
+ (point))))))
+
+ (defsubst semantic-grammar-epilogue-start ()
+ "Return the start position of the grammar epilogue."
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward "^\\s-*\\<%%\\>\\s-*$" nil t 2)
+ (match-beginning 0)
+ (1+ (point-max)))))
+
+ (define-lex-regex-analyzer semantic-grammar-lex-epilogue
+ "Detect and create an epilogue or percent-percent token."
+ "\\<%%\\>"
+ (let ((start (match-beginning 0))
+ (end (match-end 0))
+ (class 'PERCENT_PERCENT))
+ (when (>= start (semantic-grammar-epilogue-start))
+ (setq class 'EPILOGUE
+ end (point-max)))
+ (semantic-lex-push-token
+ (semantic-lex-token class start end))))
+
+ (define-lex semantic-grammar-lexer
+ "Lexical analyzer that handles Semantic grammar buffers.
+ It ignores whitespaces, newlines and comments."
+ semantic-lex-ignore-newline
+ semantic-lex-ignore-whitespace
+ ;; Must detect prologue/epilogue before other symbols/keywords!
+ semantic-grammar-lex-prologue
+ semantic-grammar-lex-epilogue
+ semantic-grammar-wy--<keyword>-keyword-analyzer
+ semantic-grammar-wy--<symbol>-regexp-analyzer
+ semantic-grammar-wy--<char>-regexp-analyzer
+ semantic-grammar-wy--<string>-sexp-analyzer
+ ;; Must detect comments after strings because `comment-start-skip'
+ ;; regexp match semicolons inside strings!
+ semantic-lex-ignore-comments
+ ;; Must detect prefixed list before punctuation because prefix chars
+ ;; are also punctuations!
+ semantic-grammar-wy--<qlist>-sexp-analyzer
+ ;; Must detect punctuations after comments because the semicolon can
+ ;; be a punctuation or a comment start!
+ semantic-grammar-wy--<punctuation>-string-analyzer
+ semantic-grammar-wy--<block>-block-analyzer
+ semantic-grammar-wy--<sexp>-sexp-analyzer)
+
+ ;;; Test the lexer
+ ;;
+ (defun semantic-grammar-lex-buffer ()
+ "Run `semantic-grammar-lex' on current buffer."
+ (interactive)
+ (semantic-lex-init)
+ (setq semantic-lex-analyzer 'semantic-grammar-lexer)
+ (let ((token-stream
+ (semantic-lex (point-min) (point-max))))
+ (with-current-buffer (get-buffer-create "*semantic-grammar-lex*")
+ (erase-buffer)
+ (pp token-stream (current-buffer))
+ (goto-char (point-min))
+ (pop-to-buffer (current-buffer)))))
+ \f
+ ;;;;
+ ;;;; Semantic action expansion
+ ;;;;
+
+ (defun semantic-grammar-ASSOC (&rest args)
+ "Return expansion of built-in ASSOC expression.
+ ARGS are ASSOC's key value list."
+ (let ((key t))
+ `(semantic-tag-make-assoc-list
+ ,@(mapcar #'(lambda (i)
+ (prog1
+ (if key
+ (list 'quote i)
+ i)
+ (setq key (not key))))
+ args))))
+
+ (defsubst semantic-grammar-quote-p (sym)
+ "Return non-nil if SYM is bound to the `quote' function."
+ (condition-case nil
+ (eq (indirect-function sym)
+ (indirect-function 'quote))
+ (error nil)))
+
+ (defsubst semantic-grammar-backquote-p (sym)
+ "Return non-nil if SYM is bound to the `backquote' function."
+ (condition-case nil
+ (eq (indirect-function sym)
+ (indirect-function 'backquote))
+ (error nil)))
+ \f
+ ;;;;
+ ;;;; API to access grammar tags
+ ;;;;
+
+ (define-mode-local-override semantic-tag-components
+ semantic-grammar-mode (tag)
+ "Return the children of tag TAG."
+ (semantic-tag-get-attribute tag :children))
+
+ (defun semantic-grammar-first-tag-name (class)
+ "Return the name of the first tag of class CLASS found.
+ Warn if other tags of class CLASS exist."
+ (let* ((tags (semantic-find-tags-by-class
+ class (current-buffer))))
+ (if tags
+ (prog1
+ (semantic-tag-name (car tags))
+ (if (cdr tags)
+ (message "*** Ignore all but first declared %s"
+ class))))))
+
+ (defun semantic-grammar-tag-symbols (class)
+ "Return the list of symbols defined in tags of class CLASS.
+ That is tag names plus names defined in tag attribute `:rest'."
+ (let* ((tags (semantic-find-tags-by-class
+ class (current-buffer))))
+ (apply 'append
+ (mapcar
+ #'(lambda (tag)
+ (mapcar
+ 'intern
+ (cons (semantic-tag-name tag)
+ (semantic-tag-get-attribute tag :rest))))
+ tags))))
+
+ (defsubst semantic-grammar-item-text (item)
+ "Return the readable string form of ITEM."
+ (if (string-match semantic-grammar-lex-c-char-re item)
+ (concat "?" (substring item 1 -1))
+ item))
+
+ (defsubst semantic-grammar-item-value (item)
+ "Return symbol or character value of ITEM string."
+ (if (string-match semantic-grammar-lex-c-char-re item)
+ (let ((c (read (concat "?" (substring item 1 -1)))))
+ (if (featurep 'xemacs)
+ ;; Handle characters as integers in XEmacs like in GNU Emacs.
+ (char-int c)
+ c))
+ (intern item)))
+
+ (defun semantic-grammar-prologue ()
+ "Return grammar prologue code as a string value."
+ (let ((tag (semantic-find-first-tag-by-name
+ "prologue"
+ (semantic-find-tags-by-class 'code (current-buffer)))))
+ (if tag
+ (save-excursion
+ (concat
+ (buffer-substring
+ (progn
+ (goto-char (semantic-tag-start tag))
+ (skip-chars-forward "%{\r\n\t ")
+ (point))
+ (progn
+ (goto-char (semantic-tag-end tag))
+ (skip-chars-backward "\r\n\t %}")
+ (point)))
+ "\n"))
+ "")))
+
+ (defun semantic-grammar-epilogue ()
+ "Return grammar epilogue code as a string value."
+ (let ((tag (semantic-find-first-tag-by-name
+ "epilogue"
+ (semantic-find-tags-by-class 'code (current-buffer)))))
+ (if tag
+ (save-excursion
+ (concat
+ (buffer-substring
+ (progn
+ (goto-char (semantic-tag-start tag))
+ (skip-chars-forward "%\r\n\t ")
+ (point))
+ (progn
+ (goto-char (semantic-tag-end tag))
+ (skip-chars-backward "\r\n\t")
+ ;; If a grammar footer is found, skip it.
+ (re-search-backward "^;;;\\s-+\\S-+\\s-+ends here"
+ (save-excursion
+ (beginning-of-line)
+ (point))
+ t)
+ (skip-chars-backward "\r\n\t")
+ (point)))
+ "\n"))
+ "")))
+
+ (defsubst semantic-grammar-buffer-file (&optional buffer)
+ "Return name of file sans directory BUFFER is visiting.
+ No argument or nil as argument means use the current buffer."
+ (file-name-nondirectory (buffer-file-name buffer)))
+
+ (defun semantic-grammar-package ()
+ "Return the %package value as a string.
+ If there is no %package statement in the grammar, return a default
+ package name derived from the grammar file name. For example, the
+ default package name for the grammar file foo.wy is foo-wy, and for
+ foo.by it is foo-by."
+ (or (semantic-grammar-first-tag-name 'package)
+ (let* ((file (semantic-grammar-buffer-file))
+ (ext (file-name-extension file))
+ (i (string-match (format "\\([.]\\)%s\\'" ext) file)))
+ (concat (substring file 0 i) "-" ext))))
+
+ (defsubst semantic-grammar-languagemode ()
+ "Return the %languagemode value as a list of symbols or nil."
+ (semantic-grammar-tag-symbols 'languagemode))
+
+ (defsubst semantic-grammar-start ()
+ "Return the %start value as a list of symbols or nil."
+ (semantic-grammar-tag-symbols 'start))
+
+ (defsubst semantic-grammar-scopestart ()
+ "Return the %scopestart value as a symbol or nil."
+ (intern (or (semantic-grammar-first-tag-name 'scopestart) "nil")))
+
+ (defsubst semantic-grammar-quotemode ()
+ "Return the %quotemode value as a symbol or nil."
+ (intern (or (semantic-grammar-first-tag-name 'quotemode) "nil")))
+
+ (defsubst semantic-grammar-keywords ()
+ "Return the language keywords.
+ That is an alist of (VALUE . TOKEN) where VALUE is the string value of
+ the keyword and TOKEN is the terminal symbol identifying the keyword."
+ (mapcar
+ #'(lambda (key)
+ (cons (semantic-tag-get-attribute key :value)
+ (intern (semantic-tag-name key))))
+ (semantic-find-tags-by-class 'keyword (current-buffer))))
+
+ (defun semantic-grammar-keyword-properties (keywords)
+ "Return the list of KEYWORDS properties."
+ (let ((puts (semantic-find-tags-by-class
+ 'put (current-buffer)))
+ put keys key plist assoc pkey pval props)
+ (while puts
+ (setq put (car puts)
+ puts (cdr puts)
+ keys (mapcar
+ 'intern
+ (cons (semantic-tag-name put)
+ (semantic-tag-get-attribute put :rest))))
+ (while keys
+ (setq key (car keys)
+ keys (cdr keys)
+ assoc (rassq key keywords))
+ (if (null assoc)
+ nil ;;(message "*** %%put to undefined keyword %s ignored" key)
+ (setq key (car assoc)
+ plist (semantic-tag-get-attribute put :value))
+ (while plist
+ (setq pkey (intern (caar plist))
+ pval (read (cdar plist))
+ props (cons (list key pkey pval) props)
+ plist (cdr plist))))))
+ props))
+
+ (defun semantic-grammar-tokens ()
+ "Return defined lexical tokens.
+ That is an alist (TYPE . DEFS) where type is a %token <type> symbol
+ and DEFS is an alist of (TOKEN . VALUE). TOKEN is the terminal symbol
+ identifying the token and VALUE is the string value of the token or
+ nil."
+ (let (tags alist assoc tag type term names value)
+
+ ;; Check for <type> in %left, %right & %nonassoc declarations
+ (setq tags (semantic-find-tags-by-class
+ 'assoc (current-buffer)))
+ (while tags
+ (setq tag (car tags)
+ tags (cdr tags))
+ (when (setq type (semantic-tag-type tag))
+ (setq names (semantic-tag-get-attribute tag :value)
+ assoc (assoc type alist))
+ (or assoc (setq assoc (list type)
+ alist (cons assoc alist)))
+ (while names
+ (setq term (car names)
+ names (cdr names))
+ (or (string-match semantic-grammar-lex-c-char-re term)
+ (setcdr assoc (cons (list (intern term))
+ (cdr assoc)))))))
+
+ ;; Then process %token declarations so they can override any
+ ;; previous specifications
+ (setq tags (semantic-find-tags-by-class
+ 'token (current-buffer)))
+ (while tags
+ (setq tag (car tags)
+ tags (cdr tags))
+ (setq names (cons (semantic-tag-name tag)
+ (semantic-tag-get-attribute tag :rest))
+ type (or (semantic-tag-type tag) "<no-type>")
+ value (semantic-tag-get-attribute tag :value)
+ assoc (assoc type alist))
+ (or assoc (setq assoc (list type)
+ alist (cons assoc alist)))
+ (while names
+ (setq term (intern (car names))
+ names (cdr names))
+ (setcdr assoc (cons (cons term value) (cdr assoc)))))
+ alist))
+
+ (defun semantic-grammar-token-%type-properties (&optional props)
+ "Return properties set by %type statements.
+ This declare a new type if necessary.
+ If optional argument PROPS is non-nil, it is an existing list of
+ properties where to add new properties."
+ (let (type)
+ (dolist (tag (semantic-find-tags-by-class 'type (current-buffer)))
+ (setq type (semantic-tag-name tag))
+ ;; Indicate to auto-generate the analyzer for this type
+ (push (list type :declared t) props)
+ (dolist (e (semantic-tag-get-attribute tag :value))
+ (push (list type (intern (car e)) (read (or (cdr e) "nil")))
+ props)))
+ props))
+
+ (defun semantic-grammar-token-%put-properties (tokens)
+ "For types found in TOKENS, return properties set by %put statements."
+ (let (found props)
+ (dolist (put (semantic-find-tags-by-class 'put (current-buffer)))
+ (dolist (type (cons (semantic-tag-name put)
+ (semantic-tag-get-attribute put :rest)))
+ (setq found (assoc type tokens))
+ (if (null found)
+ nil ;; %put <type> ignored, no token defined
+ (setq type (car found))
+ (dolist (e (semantic-tag-get-attribute put :value))
+ (push (list type (intern (car e)) (read (or (cdr e) "nil")))
+ props)))))
+ props))
+
+ (defsubst semantic-grammar-token-properties (tokens)
+ "Return properties of declared types.
+ Types are explicitly declared by %type statements. Types found in
+ TOKENS are those declared implicitly by %token statements.
+ Properties can be set by %put and %type statements.
+ Properties set by %type statements take precedence over those set by
+ %put statements."
+ (let ((props (semantic-grammar-token-%put-properties tokens)))
+ (semantic-grammar-token-%type-properties props)))
+
+ (defun semantic-grammar-use-macros ()
+ "Return macro definitions from %use-macros statements.
+ Also load the specified macro libraries."
+ (let (lib defs)
+ (dolist (tag (semantic-find-tags-by-class 'macro (current-buffer)))
+ (setq lib (intern (semantic-tag-type tag)))
+ (condition-case nil
+ ;;(load lib) ;; Be sure to use the latest macro library.
+ (require lib)
+ (error nil))
+ (dolist (mac (semantic-tag-get-attribute tag :value))
+ (push (cons (intern mac)
+ (intern (format "%s-%s" lib mac)))
+ defs)))
+ (nreverse defs)))
+
+ (defvar semantic-grammar-macros nil
+ "List of associations (MACRO-NAME . EXPANDER).")
+ (make-variable-buffer-local 'semantic-grammar-macros)
+
+ (defun semantic-grammar-macros ()
+ "Build and return the alist of defined macros."
+ (append
+ ;; Definitions found in tags.
+ (semantic-grammar-use-macros)
+ ;; Other pre-installed definitions.
+ semantic-grammar-macros))
+ \f
+ ;;;;
+ ;;;; Overloaded functions that build parser data.
+ ;;;;
+
+ ;;; Keyword table builder
+ ;;
+ (defun semantic-grammar-keywordtable-builder-default ()
+ "Return the default value of the keyword table."
+ (let ((keywords (semantic-grammar-keywords)))
+ `(semantic-lex-make-keyword-table
+ ',keywords
+ ',(semantic-grammar-keyword-properties keywords))))
+
+ (define-overloadable-function semantic-grammar-keywordtable-builder ()
+ "Return the keyword table table value.")
+
+ ;;; Token table builder
+ ;;
+ (defun semantic-grammar-tokentable-builder-default ()
+ "Return the default value of the table of lexical tokens."
+ (let ((tokens (semantic-grammar-tokens)))
+ `(semantic-lex-make-type-table
+ ',tokens
+ ',(semantic-grammar-token-properties tokens))))
+
+ (define-overloadable-function semantic-grammar-tokentable-builder ()
+ "Return the value of the table of lexical tokens.")
+
+ ;;; Parser table builder
+ ;;
+ (defun semantic-grammar-parsetable-builder-default ()
+ "Return the default value of the parse table."
+ (error "`semantic-grammar-parsetable-builder' not defined"))
+
+ (define-overloadable-function semantic-grammar-parsetable-builder ()
+ "Return the parser table value.")
+
+ ;;; Parser setup code builder
+ ;;
+ (defun semantic-grammar-setupcode-builder-default ()
+ "Return the default value of the setup code form."
+ (error "`semantic-grammar-setupcode-builder' not defined"))
+
+ (define-overloadable-function semantic-grammar-setupcode-builder ()
+ "Return the parser setup code form.")
+ \f
+ ;;;;
+ ;;;; Lisp code generation
+ ;;;;
+ (defvar semantic--grammar-input-buffer nil)
+ (defvar semantic--grammar-output-buffer nil)
+
+ (defsubst semantic-grammar-keywordtable ()
+ "Return the variable name of the keyword table."
+ (concat (file-name-sans-extension
+ (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ "--keyword-table"))
+
+ (defsubst semantic-grammar-tokentable ()
+ "Return the variable name of the token table."
+ (concat (file-name-sans-extension
+ (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ "--token-table"))
+
+ (defsubst semantic-grammar-parsetable ()
+ "Return the variable name of the parse table."
+ (concat (file-name-sans-extension
+ (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ "--parse-table"))
+
+ (defsubst semantic-grammar-setupfunction ()
+ "Return the name of the parser setup function."
+ (concat (file-name-sans-extension
+ (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ "--install-parser"))
+
+ (defmacro semantic-grammar-as-string (object)
+ "Return OBJECT as a string value."
+ `(if (stringp ,object)
+ ,object
+ ;;(require 'pp)
+ (pp-to-string ,object)))
+
+ (defun semantic-grammar-insert-defconst (name value docstring)
+ "Insert declaration of constant NAME with VALUE and DOCSTRING."
+ (let ((start (point)))
+ (insert (format "(defconst %s\n%s%S)\n\n" name value docstring))
+ (save-excursion
+ (goto-char start)
+ (indent-sexp))))
+
+ (defun semantic-grammar-insert-defun (name body docstring)
+ "Insert declaration of function NAME with BODY and DOCSTRING."
+ (let ((start (point)))
+ (insert (format "(defun %s ()\n%S\n%s)\n\n" name docstring body))
+ (save-excursion
+ (goto-char start)
+ (indent-sexp))))
+
+ (defun semantic-grammar-insert-define (define)
+ "Insert the declaration specified by DEFINE expression.
+ Typically a DEFINE expression should look like this:
+
+ \(define-thing name docstring expression1 ...)"
+ ;;(require 'pp)
+ (let ((start (point)))
+ (insert (format "(%S %S" (car define) (nth 1 define)))
+ (dolist (item (nthcdr 2 define))
+ (insert "\n")
+ (delete-blank-lines)
+ (pp item (current-buffer)))
+ (insert ")\n\n")
+ (save-excursion
+ (goto-char start)
+ (indent-sexp))))
+
+ (defconst semantic-grammar-header-template
+ '("\
+ ;;; " file " --- Generated parser support file
+
+ " copy "
+
+ ;; Author: " user-full-name " <" user-mail-address ">
+ ;; Created: " date "
+ ;; Keywords: syntax
+ ;; X-RCS: " vcid "
+
+ ;; This file is not part of GNU Emacs.
+ ;;
+ ;; This program 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 2, or (at
+ ;; your option) any later version.
+ ;;
+ ;; This software 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; see the file COPYING. If not, write to the
+ ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+ ;; Boston, MA 02110-1301, USA.
+
+ ;;; Commentary:
+ ;;
+ ;; PLEASE DO NOT MANUALLY EDIT THIS FILE! It is automatically
+ ;; generated from the grammar file " gram ".
+
+ ;;; History:
+ ;;
+
+ ;;; Code:
+ ")
+ "Generated header template.
+ The symbols in the template are local variables in
+ `semantic-grammar-header'")
+
+ (defconst semantic-grammar-footer-template
+ '("\
+
+ \(provide '" libr ")
+
+ ;;; " file " ends here
+ ")
+ "Generated footer template.
+ The symbols in the list are local variables in
+ `semantic-grammar-footer'.")
+
+ (defun semantic-grammar-copyright-line ()
+ "Return the grammar copyright line, or nil if not found."
+ (save-excursion
+ (goto-char (point-min))
+ (when (re-search-forward "^;;+[ \t]+Copyright (C) .*$"
+ ;; Search only in the four top lines
+ (save-excursion (forward-line 4) (point))
+ t)
+ (match-string 0))))
+
+ (defun semantic-grammar-header ()
+ "Return text of a generated standard header."
+ (let ((file (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ (gram (semantic-grammar-buffer-file))
+ (date (format-time-string "%Y-%m-%d %T%z"))
+ (vcid (concat "$" "Id" "$")) ;; Avoid expansion
+ ;; Try to get the copyright from the input grammar, or
+ ;; generate a new one if not found.
+ (copy (or (semantic-grammar-copyright-line)
+ (concat (format-time-string ";; Copyright (C) %Y ")
+ user-full-name)))
+ (out ""))
+ (dolist (S semantic-grammar-header-template)
+ (cond ((stringp S)
+ (setq out (concat out S)))
+ ((symbolp S)
+ (setq out (concat out (symbol-value S))))))
+ out))
+
+ (defun semantic-grammar-footer ()
+ "Return text of a generated standard footer."
+ (let* ((file (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ (libr (file-name-sans-extension file))
+ (out ""))
+ (dolist (S semantic-grammar-footer-template)
+ (cond ((stringp S)
+ (setq out (concat out S)))
+ ((symbolp S)
+ (setq out (concat out (symbol-value S))))))
+ out))
+
+ (defun semantic-grammar-token-data ()
+ "Return the string value of the table of lexical tokens."
+ (semantic-grammar-as-string
+ (semantic-grammar-tokentable-builder)))
+
+ (defun semantic-grammar-keyword-data ()
+ "Return the string value of the table of keywords."
+ (semantic-grammar-as-string
+ (semantic-grammar-keywordtable-builder)))
+
+ (defun semantic-grammar-parser-data ()
+ "Return the parser table as a string value."
+ (semantic-grammar-as-string
+ (semantic-grammar-parsetable-builder)))
+
+ (defun semantic-grammar-setup-data ()
+ "Return the parser setup code form as a string value."
+ (semantic-grammar-as-string
+ (semantic-grammar-setupcode-builder)))
+ \f
+ ;;; Generation of lexical analyzers.
+ ;;
+ (defvar semantic-grammar--lex-block-specs)
+
+ (defsubst semantic-grammar--lex-delim-spec (block-spec)
+ "Return delimiters specification from BLOCK-SPEC."
+ (condition-case nil
+ (let* ((standard-input (cdr block-spec))
+ (delim-spec (read)))
+ (if (and (consp delim-spec)
+ (car delim-spec) (symbolp (car delim-spec))
+ (cadr delim-spec) (symbolp (cadr delim-spec)))
+ delim-spec
+ (error)))
+ (error
+ (error "Invalid delimiters specification %s in block token %s"
+ (cdr block-spec) (car block-spec)))))
+
+ (defun semantic-grammar--lex-block-specs ()
+ "Compute lexical block specifications for the current buffer.
+ Block definitions are read from the current table of lexical types."
+ (cond
+ ;; Block specifications have been parsed and are invalid.
+ ((eq semantic-grammar--lex-block-specs 'error)
+ nil
+ )
+ ;; Parse block specifications.
+ ((null semantic-grammar--lex-block-specs)
+ (condition-case err
+ (let* ((blocks (cdr (semantic-lex-type-value "block" t)))
+ (open-delims (cdr (semantic-lex-type-value "open-paren" t)))
+ (close-delims (cdr (semantic-lex-type-value "close-paren" t)))
+ olist clist block-spec delim-spec open-spec close-spec)
+ (dolist (block-spec blocks)
+ (setq delim-spec (semantic-grammar--lex-delim-spec block-spec)
+ open-spec (assq (car delim-spec) open-delims)
+ close-spec (assq (cadr delim-spec) close-delims))
+ (or open-spec
+ (error "Missing open-paren token %s required by block %s"
+ (car delim-spec) (car block-spec)))
+ (or close-spec
+ (error "Missing close-paren token %s required by block %s"
+ (cdr delim-spec) (car block-spec)))
+ ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...)
+ (push (list (cdr open-spec) (car open-spec) (car block-spec))
+ olist)
+ ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...)
+ (push (list (cdr close-spec) (car close-spec))
+ clist))
+ (setq semantic-grammar--lex-block-specs (cons olist clist)))
+ (error
+ (setq semantic-grammar--lex-block-specs 'error)
+ (message "%s" (error-message-string err))
+ nil))
+ )
+ ;; Block specifications already parsed.
+ (t
+ semantic-grammar--lex-block-specs)))
+
+ (defsubst semantic-grammar-quoted-form (exp)
+ "Return a quoted form of EXP if it isn't a self evaluating form."
+ (if (and (not (null exp))
+ (or (listp exp) (symbolp exp)))
+ (list 'quote exp)
+ exp))
+
+ (defun semantic-grammar-insert-defanalyzer (type)
+ "Insert declaration of the lexical analyzer defined with TYPE."
+ (let* ((type-name (symbol-name type))
+ (type-value (symbol-value type))
+ (syntax (get type 'syntax))
+ (declared (get type :declared))
+ spec mtype prefix name doc)
+ ;; Generate an analyzer if the corresponding type has been
+ ;; explicitly declared in a %type statement, and if at least the
+ ;; syntax property has been provided.
+ (when (and declared syntax)
+ (setq prefix (file-name-sans-extension
+ (semantic-grammar-buffer-file
+ semantic--grammar-output-buffer))
+ mtype (or (get type 'matchdatatype) 'regexp)
+ name (intern (format "%s--<%s>-%s-analyzer" prefix type mtype))
+ doc (format "%s analyzer for <%s> tokens." mtype type))
+ (cond
+ ;; Regexp match analyzer
+ ((eq mtype 'regexp)
+ (semantic-grammar-insert-define
+ `(define-lex-regex-type-analyzer ,name
+ ,doc ,syntax
+ ,(semantic-grammar-quoted-form (cdr type-value))
+ ',(or (car type-value) (intern type-name))))
+ )
+ ;; String compare analyzer
+ ((eq mtype 'string)
+ (semantic-grammar-insert-define
+ `(define-lex-string-type-analyzer ,name
+ ,doc ,syntax
+ ,(semantic-grammar-quoted-form (cdr type-value))
+ ',(or (car type-value) (intern type-name))))
+ )
+ ;; Block analyzer
+ ((and (eq mtype 'block)
+ (setq spec (semantic-grammar--lex-block-specs)))
+ (semantic-grammar-insert-define
+ `(define-lex-block-type-analyzer ,name
+ ,doc ,syntax
+ ,(semantic-grammar-quoted-form spec)))
+ )
+ ;; Sexp analyzer
+ ((eq mtype 'sexp)
+ (semantic-grammar-insert-define
+ `(define-lex-sexp-type-analyzer ,name
+ ,doc ,syntax
+ ',(or (car type-value) (intern type-name))))
+ )
+ ;; keyword analyzer
+ ((eq mtype 'keyword)
+ (semantic-grammar-insert-define
+ `(define-lex-keyword-type-analyzer ,name
+ ,doc ,syntax))
+ )
+ ))
+ ))
+
+ (defun semantic-grammar-insert-defanalyzers ()
+ "Insert declarations of lexical analyzers."
+ (let (tokens props)
+ (with-current-buffer semantic--grammar-input-buffer
+ (setq tokens (semantic-grammar-tokens)
+ props (semantic-grammar-token-properties tokens)))
+ (insert "(require 'semantic-lex)\n\n")
+ (let ((semantic-lex-types-obarray
+ (semantic-lex-make-type-table tokens props))
+ semantic-grammar--lex-block-specs)
+ (mapatoms 'semantic-grammar-insert-defanalyzer
+ semantic-lex-types-obarray))))
+ \f
+ ;;; Generation of the grammar support file.
+ ;;
+ (defcustom semantic-grammar-file-regexp "\\.[wb]y$"
+ "Regexp which matches grammar source files."
+ :group 'semantic
+ :type 'regexp)
+
+ (defsubst semantic-grammar-noninteractive ()
+ "Return non-nil if running without interactive terminal."
+ (if (featurep 'xemacs)
+ (noninteractive)
+ noninteractive))
+
+ (defun semantic-grammar-create-package (&optional force)
+ "Create package Lisp code from grammar in current buffer.
+ Does nothing if the Lisp code seems up to date.
+ If optional argument FORCE is non-nil, unconditionally re-generate the
+ Lisp code."
+ (interactive "P")
+ (setq force (or force current-prefix-arg))
+ (semantic-fetch-tags)
+ (let* (
+ ;; Values of the following local variables are obtained from
+ ;; the grammar parsed tree in current buffer, that is before
+ ;; switching to the output file.
+ (package (semantic-grammar-package))
+ (output (concat package ".el"))
+ (semantic--grammar-input-buffer (current-buffer))
+ (semantic--grammar-output-buffer (find-file-noselect output))
+ (header (semantic-grammar-header))
+ (prologue (semantic-grammar-prologue))
+ (epilogue (semantic-grammar-epilogue))
+ (footer (semantic-grammar-footer))
+ )
+ (if (and (not force)
+ (not (buffer-modified-p))
+ (file-newer-than-file-p
+ (buffer-file-name semantic--grammar-output-buffer)
+ (buffer-file-name semantic--grammar-input-buffer)))
+ (message "Package `%s' is up to date." package)
+ ;; Create the package
+ (set-buffer semantic--grammar-output-buffer)
+ ;; Use Unix EOLs, so that the file is portable to all platforms.
+ (setq buffer-file-coding-system 'raw-text-unix)
+ (erase-buffer)
+ (unless (eq major-mode 'emacs-lisp-mode)
+ (emacs-lisp-mode))
+
+ ;;;; Header + Prologue
+
+ (insert header
+ "\f\n;;; Prologue\n;;\n"
+ prologue
+ )
+ ;; Evaluate the prologue now, because it might provide definition
+ ;; of grammar macro expanders.
+ (eval-region (point-min) (point))
+
+ (save-excursion
+
+ ;;;; Declarations
+
+ (insert "\f\n;;; Declarations\n;;\n")
+
+ ;; `eval-defun' is not necessary to reset `defconst' values.
+ (semantic-grammar-insert-defconst
+ (semantic-grammar-keywordtable)
+ (with-current-buffer semantic--grammar-input-buffer
+ (semantic-grammar-keyword-data))
+ "Table of language keywords.")
+
+ (semantic-grammar-insert-defconst
+ (semantic-grammar-tokentable)
+ (with-current-buffer semantic--grammar-input-buffer
+ (semantic-grammar-token-data))
+ "Table of lexical tokens.")
+
+ (semantic-grammar-insert-defconst
+ (semantic-grammar-parsetable)
+ (with-current-buffer semantic--grammar-input-buffer
+ (semantic-grammar-parser-data))
+ "Parser table.")
+
+ (semantic-grammar-insert-defun
+ (semantic-grammar-setupfunction)
+ (with-current-buffer semantic--grammar-input-buffer
+ (semantic-grammar-setup-data))
+ "Setup the Semantic Parser.")
+
+ ;;;; Analyzers
+ (insert "\f\n;;; Analyzers\n;;\n")
+
+ (semantic-grammar-insert-defanalyzers)
+
+ ;;;; Epilogue & Footer
+
+ (insert "\f\n;;; Epilogue\n;;\n"
+ epilogue
+ footer
+ )
+
+ )
+
+ (save-buffer 16)
+
+ ;; If running in batch mode, there is nothing more to do.
+ ;; Save the generated file and quit.
+ (if (semantic-grammar-noninteractive)
+ (let ((version-control t)
+ (delete-old-versions t)
+ (make-backup-files t)
+ (vc-make-backup-files t))
+ (kill-buffer (current-buffer)))
+ ;; If running interactively, eval declarations and epilogue
+ ;; code, then pop to the buffer visiting the generated file.
+ (eval-region (point) (point-max))
+ (goto-char (point-min))
+ (pop-to-buffer (current-buffer))
+ ;; The generated code has been evaluated and updated into
+ ;; memory. Now find all buffers that match the major modes we
+ ;; have created this language for, and force them to call our
+ ;; setup function again, refreshing all semantic data, and
+ ;; enabling them to work with the new code just created.
+ ;;;; FIXME?
+ ;; At this point, I don't know any user's defined setup code :-(
+ ;; At least, what I can do for now, is to run the generated
+ ;; parser-install function.
+ (semantic-map-mode-buffers
+ (semantic-grammar-setupfunction)
+ (semantic-grammar-languagemode)))
+ )
+ ;; Return the name of the generated package file.
+ output))
+
+ (defun semantic-grammar-recreate-package ()
+ "Unconditionnaly create Lisp code from grammar in current buffer.
+ Like \\[universal-argument] \\[semantic-grammar-create-package]."
+ (interactive)
+ (semantic-grammar-create-package t))
+
+ (defun semantic-grammar-batch-build-one-package (file)
+ "Build a Lisp package from the grammar in FILE.
+ That is, generate Lisp code from FILE, and `byte-compile' it.
+ Return non-nil if there were no errors, nil if errors."
+ ;; We need this require so that we can find `byte-compile-dest-file'.
+ (require 'bytecomp)
+ (unless (auto-save-file-name-p file)
+ ;; Create the package
+ (let ((packagename
+ (condition-case err
+ (with-current-buffer (find-file-noselect file)
+ (semantic-grammar-create-package))
+ (error
+ (message "%s" (error-message-string err))
+ nil))))
+ (when packagename
+ ;; Only byte compile if out of date
+ (if (file-newer-than-file-p
+ packagename (byte-compile-dest-file packagename))
+ (let (;; Some complex grammar table expressions need a few
+ ;; more resources than the default.
+ (max-specpdl-size (max 3000 max-specpdl-size))
+ (max-lisp-eval-depth (max 1000 max-lisp-eval-depth))
+ )
+ ;; byte compile the resultant file
+ (byte-compile-file packagename))
+ t)))))
+
+ (defun semantic-grammar-batch-build-packages ()
+ "Build Lisp packages from grammar files on the command line.
+ That is, run `semantic-grammar-batch-build-one-package' for each file.
+ Each file is processed even if an error occurred previously.
+ Must be used from the command line, with `-batch'.
+ For example, to process grammar files in current directory, invoke:
+
+ \"emacs -batch -f semantic-grammar-batch-build-packages .\".
+
+ See also the variable `semantic-grammar-file-regexp'."
+ (or (semantic-grammar-noninteractive)
+ (error "\
+ `semantic-grammar-batch-build-packages' must be used with -batch"
+ ))
+ (let ((status 0)
+ ;; Remove vc from find-file-hook. It causes bad stuff to
+ ;; happen in Emacs 20.
+ (find-file-hook (delete 'vc-find-file-hook find-file-hook)))
+ (message "Compiling Grammars from: %s" (locate-library "semantic-grammar"))
+ (dolist (arg command-line-args-left)
+ (unless (and arg (file-exists-p arg))
+ (error "Argument %s is not a valid file name" arg))
+ (setq arg (expand-file-name arg))
+ (if (file-directory-p arg)
+ ;; Directory as argument
+ (dolist (src (condition-case nil
+ (directory-files
+ arg nil semantic-grammar-file-regexp)
+ (error
+ (error "Unable to read directory files"))))
+ (or (semantic-grammar-batch-build-one-package
+ (expand-file-name src arg))
+ (setq status 1)))
+ ;; Specific file argument
+ (or (semantic-grammar-batch-build-one-package arg)
+ (setq status 1))))
+ (kill-emacs status)
+ ))
+ \f
+ ;;;;
+ ;;;; Macros highlighting
+ ;;;;
+
+ (defvar semantic--grammar-macros-regexp-1 nil)
+ (make-variable-buffer-local 'semantic--grammar-macros-regexp-1)
+
+ (defun semantic--grammar-macros-regexp-1 ()
+ "Return font-lock keyword regexp for pre-installed macro names."
+ (and semantic-grammar-macros
+ (not semantic--grammar-macros-regexp-1)
+ (condition-case nil
+ (setq semantic--grammar-macros-regexp-1
+ (concat "(\\s-*"
+ (regexp-opt
+ (mapcar #'(lambda (e) (symbol-name (car e)))
+ semantic-grammar-macros)
+ t)
+ "\\>"))
+ (error nil)))
+ semantic--grammar-macros-regexp-1)
+
+ (defconst semantic--grammar-macdecl-re
+ "\\<%use-macros\\>[ \t\r\n]+\\(\\sw\\|\\s_\\)+[ \t\r\n]+{"
+ "Regexp that matches a macro declaration statement.")
+
+ (defvar semantic--grammar-macros-regexp-2 nil)
+ (make-variable-buffer-local 'semantic--grammar-macros-regexp-2)
+
+ (defun semantic--grammar-clear-macros-regexp-2 (&rest ignore)
+ "Clear the cached regexp that match macros local in this grammar.
+ IGNORE arguments.
+ Added to `before-change-functions' hooks to be run before each text
+ change."
+ (setq semantic--grammar-macros-regexp-2 nil))
+
+ (defun semantic--grammar-macros-regexp-2 ()
+ "Return the regexp that match macros local in this grammar."
+ (unless semantic--grammar-macros-regexp-2
+ (let (macs)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward semantic--grammar-macdecl-re nil t)
+ (condition-case nil
+ (setq macs (nconc macs
+ (split-string
+ (buffer-substring-no-properties
+ (point)
+ (progn
+ (backward-char)
+ (forward-list 1)
+ (down-list -1)
+ (point))))))
+ (error nil)))
+ (when macs
+ (setq semantic--grammar-macros-regexp-2
+ (concat "(\\s-*" (regexp-opt macs t) "\\>"))))))
+ semantic--grammar-macros-regexp-2)
+
+ (defun semantic--grammar-macros-matcher (end)
+ "Search for a grammar macro name to highlight.
+ END is the limit of the search."
+ (let ((regexp (semantic--grammar-macros-regexp-1)))
+ (or (and regexp (re-search-forward regexp end t))
+ (and (setq regexp (semantic--grammar-macros-regexp-2))
+ (re-search-forward regexp end t)))))
+ \f
+ ;;;;
+ ;;;; Define major mode
+ ;;;;
+
+ (defvar semantic-grammar-syntax-table
+ (let ((table (make-syntax-table (standard-syntax-table))))
+ (modify-syntax-entry ?\: "." table) ;; COLON
+ (modify-syntax-entry ?\> "." table) ;; GT
+ (modify-syntax-entry ?\< "." table) ;; LT
+ (modify-syntax-entry ?\| "." table) ;; OR
+ (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
+ (modify-syntax-entry ?\n ">" table) ;; Comment end
+ (modify-syntax-entry ?\" "\"" table) ;; String
+ (modify-syntax-entry ?\% "w" table) ;; Word
+ (modify-syntax-entry ?\- "_" table) ;; Symbol
+ (modify-syntax-entry ?\. "_" table) ;; Symbol
+ (modify-syntax-entry ?\\ "\\" table) ;; Quote
+ (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
+ (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
+ (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
+ (modify-syntax-entry ?\# "'" table) ;; Prefix # (sharp)
+ table)
+ "Syntax table used in a Semantic grammar buffers.")
+
+ (defvar semantic-grammar-mode-hook nil
+ "Hook run when starting Semantic grammar mode.")
+
+ (defvar semantic-grammar-mode-keywords-1
+ `(("\\(\\<%%\\>\\|\\<%[{}]\\)"
+ 0 font-lock-reference-face)
+ ("\\(%\\)\\(\\(\\sw\\|\\s_\\)+\\)"
+ (1 font-lock-reference-face)
+ (2 font-lock-keyword-face))
+ ("\\<error\\>"
+ 0 (unless (semantic-grammar-in-lisp-p) 'bold))
+ ("^\\(\\(\\sw\\|\\s_\\)+\\)[ \n\r\t]*:"
+ 1 font-lock-function-name-face)
+ (semantic--grammar-macros-matcher
+ 1 ,(if (boundp 'font-lock-builtin-face)
+ 'font-lock-builtin-face
+ 'font-lock-preprocessor-face))
+ ("\\$\\(\\sw\\|\\s_\\)*"
+ 0 font-lock-variable-name-face)
+ ("<\\(\\(\\sw\\|\\s_\\)+\\)>"
+ 1 font-lock-type-face)
+ (,semantic-grammar-lex-c-char-re
+ 0 ,(if (boundp 'font-lock-constant-face)
+ 'font-lock-constant-face
+ 'font-lock-string-face) t)
+ ;; Must highlight :keyword here, because ':' is a punctuation in
+ ;; grammar mode!
+ ("[\r\n\t ]+:\\sw+\\>"
+ 0 font-lock-builtin-face)
++ ;; ;; Append the Semantic keywords
++ ;; ,@semantic-fw-font-lock-keywords
+ )
+ "Font Lock keywords used to highlight Semantic grammar buffers.")
+
+ (defvar semantic-grammar-mode-keywords-2
+ (append semantic-grammar-mode-keywords-1
+ lisp-font-lock-keywords-1)
+ "Font Lock keywords used to highlight Semantic grammar buffers.")
+
+ (defvar semantic-grammar-mode-keywords-3
+ (append semantic-grammar-mode-keywords-1
+ lisp-font-lock-keywords-2)
+ "Font Lock keywords used to highlight Semantic grammar buffers.")
+
+ (defvar semantic-grammar-mode-keywords
+ semantic-grammar-mode-keywords-1
+ "Font Lock keywords used to highlight Semantic grammar buffers.")
+
+ (defvar semantic-grammar-map
+ (let ((km (make-sparse-keymap)))
+
+ (define-key km "|" 'semantic-grammar-electric-punctuation)
+ (define-key km ";" 'semantic-grammar-electric-punctuation)
+ (define-key km "%" 'semantic-grammar-electric-punctuation)
+ (define-key km "(" 'semantic-grammar-electric-punctuation)
+ (define-key km ")" 'semantic-grammar-electric-punctuation)
+ (define-key km ":" 'semantic-grammar-electric-punctuation)
+
+ (define-key km "\t" 'semantic-grammar-indent)
+ (define-key km "\M-\t" 'semantic-grammar-complete)
+ (define-key km "\C-c\C-c" 'semantic-grammar-create-package)
+ (define-key km "\C-cm" 'semantic-grammar-find-macro-expander)
+ (define-key km "\C-cik" 'semantic-grammar-insert-keyword)
+ ;; (define-key km "\C-cc" 'semantic-grammar-generate-and-load)
+ ;; (define-key km "\C-cr" 'semantic-grammar-generate-one-rule)
+
+ km)
+ "Keymap used in `semantic-grammar-mode'.")
+
+ (defvar semantic-grammar-menu
+ '("Grammar"
+ ["Indent Line" semantic-grammar-indent]
+ ["Complete Symbol" semantic-grammar-complete]
+ ["Find Macro" semantic-grammar-find-macro-expander]
+ "--"
+ ["Insert %keyword" semantic-grammar-insert-keyword]
+ "--"
+ ["Update Lisp Package" semantic-grammar-create-package]
+ ["Recreate Lisp Package" semantic-grammar-recreate-package]
+ )
+ "Common semantic grammar menu.")
+
+ (defun semantic-grammar-setup-menu-emacs (symbol mode-menu)
+ "Setup a GNU Emacs grammar menu in variable SYMBOL.
+ MODE-MENU is an optional specific menu whose items are appended to the
+ common grammar menu."
+ (let ((items (make-symbol "items")))
+ `(unless (boundp ',symbol)
+ (easy-menu-define ,symbol (current-local-map)
+ "Grammar Menu" semantic-grammar-menu)
+ (let ((,items (cdr ,mode-menu)))
+ (when ,items
+ (easy-menu-add-item ,symbol nil "--")
+ (while ,items
+ (easy-menu-add-item ,symbol nil (car ,items))
+ (setq ,items (cdr ,items))))))
+ ))
+
+ (defun semantic-grammar-setup-menu-xemacs (symbol mode-menu)
+ "Setup an XEmacs grammar menu in variable SYMBOL.
+ MODE-MENU is an optional specific menu whose items are appended to the
+ common grammar menu."
+ (let ((items (make-symbol "items"))
+ (path (make-symbol "path")))
+ `(progn
+ (unless (boundp ',symbol)
+ (easy-menu-define ,symbol nil
+ "Grammar Menu" (copy-sequence semantic-grammar-menu)))
+ (easy-menu-add ,symbol)
+ (let ((,items (cdr ,mode-menu))
+ (,path (list (car ,symbol))))
+ (when ,items
+ (easy-menu-add-item nil ,path "--")
+ (while ,items
+ (easy-menu-add-item nil ,path (car ,items))
+ (setq ,items (cdr ,items))))))
+ ))
+
+ (defmacro semantic-grammar-setup-menu (&optional mode-menu)
+ "Setup a mode local grammar menu.
+ MODE-MENU is an optional specific menu whose items are appended to the
+ common grammar menu."
+ (let ((menu (intern (format "%s-menu" major-mode))))
+ (if (featurep 'xemacs)
+ (semantic-grammar-setup-menu-xemacs menu mode-menu)
+ (semantic-grammar-setup-menu-emacs menu mode-menu))))
+
+ (defsubst semantic-grammar-in-lisp-p ()
+ "Return non-nil if point is in Lisp code."
+ (or (>= (point) (semantic-grammar-epilogue-start))
+ (condition-case nil
+ (save-excursion
+ (up-list -1)
+ t)
+ (error nil))))
+
+ (defun semantic-grammar-edits-new-change-hook-fcn (overlay)
+ "Function set into `semantic-edits-new-change-hook'.
+ Argument OVERLAY is the overlay created to mark the change.
+ When OVERLAY marks a change in the scope of a nonterminal tag extend
+ the change bounds to encompass the whole nonterminal tag."
+ (let ((outer (car (semantic-find-tag-by-overlay-in-region
+ (semantic-edits-os overlay)
+ (semantic-edits-oe overlay)))))
+ (if (semantic-tag-of-class-p outer 'nonterminal)
+ (semantic-overlay-move overlay
+ (semantic-tag-start outer)
+ (semantic-tag-end outer)))))
+
+ (defun semantic-grammar-mode ()
+ "Initialize a buffer for editing Semantic grammars.
+
+ \\{semantic-grammar-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'semantic-grammar-mode
+ mode-name "Semantic Grammar Framework")
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'comment-start) ";;")
+ ;; Look within the line for a ; following an even number of backslashes
+ ;; after either a non-backslash or the line beginning.
+ (set (make-local-variable 'comment-start-skip)
+ "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
+ (set-syntax-table semantic-grammar-syntax-table)
+ (use-local-map semantic-grammar-map)
+ (set (make-local-variable 'indent-line-function)
+ 'semantic-grammar-indent)
+ (set (make-local-variable 'fill-paragraph-function)
+ 'lisp-fill-paragraph)
+ (set (make-local-variable 'font-lock-multiline)
+ 'undecided)
+ (set (make-local-variable 'font-lock-defaults)
+ '((semantic-grammar-mode-keywords
+ semantic-grammar-mode-keywords-1
+ semantic-grammar-mode-keywords-2
+ semantic-grammar-mode-keywords-3)
+ nil ;; perform string/comment fontification
+ nil ;; keywords are case sensitive.
+ ;; This puts _ & - as a word constituant,
+ ;; simplifying our keywords significantly
+ ((?_ . "w") (?- . "w"))))
+ ;; Setup Semantic to parse grammar
+ (semantic-grammar-wy--install-parser)
+ (setq semantic-lex-comment-regex ";;"
+ semantic-lex-analyzer 'semantic-grammar-lexer
+ semantic-type-relation-separator-character '(":")
+ semantic-symbol->name-assoc-list
+ '(
+ (code . "Setup Code")
+ (keyword . "Keyword")
+ (token . "Token")
+ (nonterminal . "Nonterminal")
+ (rule . "Rule")
+ ))
+ (set (make-local-variable 'semantic-format-face-alist)
+ '(
+ (code . default)
+ (keyword . font-lock-keyword-face)
+ (token . font-lock-type-face)
+ (nonterminal . font-lock-function-name-face)
+ (rule . default)
+ ))
+ (set (make-local-variable 'semantic-stickyfunc-sticky-classes)
+ '(nonterminal))
+ ;; Before each change, clear the cached regexp used to highlight
+ ;; macros local in this grammar.
+ (semantic-make-local-hook 'before-change-functions)
+ (add-hook 'before-change-functions
+ 'semantic--grammar-clear-macros-regexp-2 nil t)
+ ;; Handle safe re-parse of grammar rules.
+ (semantic-make-local-hook 'semantic-edits-new-change-hooks)
+ (add-hook 'semantic-edits-new-change-hooks
+ 'semantic-grammar-edits-new-change-hook-fcn
+ nil t)
+ (semantic-run-mode-hooks 'semantic-grammar-mode-hook))
+ \f
+ ;;;;
+ ;;;; Useful commands
+ ;;;;
+
+ (defvar semantic-grammar-skip-quoted-syntax-table
+ (let ((st (copy-syntax-table semantic-grammar-syntax-table)))
+ (modify-syntax-entry ?\' "$" st)
+ st)
+ "Syntax table to skip a whole quoted expression in grammar code.
+ Consider quote as a \"paired delimiter\", so `forward-sexp' will skip
+ whole quoted expression.")
+
+ (defsubst semantic-grammar-backward-item ()
+ "Move point to beginning of the previous grammar item."
+ (forward-comment (- (point-max)))
+ (if (zerop (skip-syntax-backward "."))
+ (if (eq (char-before) ?\')
+ (with-syntax-table
+ ;; Can't be Lisp code here! Temporarily consider quote
+ ;; as a "paired delimiter", so `forward-sexp' can skip
+ ;; the whole quoted expression.
+ semantic-grammar-skip-quoted-syntax-table
+ (forward-sexp -1))
+ (forward-sexp -1))))
+
+ (defun semantic-grammar-anchored-indentation ()
+ "Return indentation based on previous anchor character found."
+ (let (indent)
+ (save-excursion
+ (while (not indent)
+ (semantic-grammar-backward-item)
+ (cond
+ ((bobp)
+ (setq indent 0))
+ ((looking-at ":\\(\\s-\\|$\\)")
+ (setq indent (current-column))
+ (forward-char)
+ (skip-syntax-forward "-")
+ (if (eolp) (setq indent 2))
+ )
+ ((and (looking-at "[;%]")
+ (not (looking-at "\\<%prec\\>")))
+ (setq indent 0)
+ ))))
+ indent))
+
+ (defun semantic-grammar-do-grammar-indent ()
+ "Indent a line of grammar.
+ When called the point is not in Lisp code."
+ (let (indent n)
+ (save-excursion
+ (beginning-of-line)
+ (skip-syntax-forward "-")
+ (setq indent (current-column))
+ (cond
+ ((or (bobp)
+ (looking-at "\\(\\w\\|\\s_\\)+\\s-*:")
+ (and (looking-at "%")
+ (not (looking-at "%prec\\>"))))
+ (setq n 0))
+ ((looking-at ":")
+ (setq n 2))
+ ((and (looking-at ";;")
+ (save-excursion (forward-comment (point-max))
+ (looking-at ":")))
+ (setq n 1))
+ (t
+ (setq n (semantic-grammar-anchored-indentation))
+ (unless (zerop n)
+ (cond
+ ((looking-at ";;")
+ (setq n (1- n)))
+ ((looking-at "[|;]")
+ )
+ (t
+ (setq n (+ n 2)))))))
+ (when (/= n indent)
+ (beginning-of-line)
+ (delete-horizontal-space)
+ (indent-to n)))))
+
+ (defvar semantic-grammar-brackets-as-parens-syntax-table
+ (let ((st (copy-syntax-table emacs-lisp-mode-syntax-table)))
+ (modify-syntax-entry ?\{ "(} " st)
+ (modify-syntax-entry ?\} "){ " st)
+ st)
+ "Syntax table that consider brackets as parenthesis.
+ So `lisp-indent-line' will work inside bracket blocks.")
+
+ (defun semantic-grammar-do-lisp-indent ()
+ "Maybe run the Emacs Lisp indenter on a line of code.
+ Return nil if not in a Lisp expression."
+ (condition-case nil
+ (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward "\t ")
+ (let ((first (point)))
+ (or (>= first (semantic-grammar-epilogue-start))
+ (up-list -1))
+ (condition-case nil
+ (while t
+ (up-list -1))
+ (error nil))
+ (beginning-of-line)
+ (save-restriction
+ (narrow-to-region (point) first)
+ (goto-char (point-max))
+ (with-syntax-table
+ ;; Temporarily consider brackets as parenthesis so
+ ;; `lisp-indent-line' can indent Lisp code inside
+ ;; brackets.
+ semantic-grammar-brackets-as-parens-syntax-table
+ (lisp-indent-line))))
+ t)
+ (error nil)))
+
+ (defun semantic-grammar-indent ()
+ "Indent the current line.
+ Use the Lisp or grammar indenter depending on point location."
+ (interactive)
+ (let ((orig (point))
+ first)
+ (or (semantic-grammar-do-lisp-indent)
+ (semantic-grammar-do-grammar-indent))
+ (setq first (save-excursion
+ (beginning-of-line)
+ (skip-chars-forward "\t ")
+ (point)))
+ (if (or (< orig first) (/= orig (point)))
+ (goto-char first))))
+
+ (defun semantic-grammar-electric-punctuation ()
+ "Insert and reindent for the symbol just typed in."
+ (interactive)
+ (self-insert-command 1)
+ (save-excursion
+ (semantic-grammar-indent)))
+
+ (defun semantic-grammar-complete ()
+ "Attempt to complete the symbol under point.
+ Completion is position sensitive. If the cursor is in a match section of
+ a rule, then nonterminals symbols are scanned. If the cursor is in a Lisp
+ expression then Lisp symbols are completed."
+ (interactive)
+ (if (semantic-grammar-in-lisp-p)
+ ;; We are in lisp code. Do lisp completion.
+ (lisp-complete-symbol)
+ ;; We are not in lisp code. Do rule completion.
+ (let* ((nonterms (semantic-find-tags-by-class 'nonterminal (current-buffer)))
+ (sym (car (semantic-ctxt-current-symbol)))
+ (ans (try-completion sym nonterms)))
+ (cond ((eq ans t)
+ ;; All done
+ (message "Symbols is already complete"))
+ ((and (stringp ans) (string= ans sym))
+ ;; Max matchable. Show completions.
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list (all-completions sym nonterms)))
+ )
+ ((stringp ans)
+ ;; Expand the completions
+ (forward-sexp -1)
+ (delete-region (point) (progn (forward-sexp 1) (point)))
+ (insert ans))
+ (t (message "No Completions."))
+ ))
+ ))
+
+ (defun semantic-grammar-insert-keyword (name)
+ "Insert a new %keyword declaration with NAME.
+ Assumes it is typed in with the correct casing."
+ (interactive "sKeyword: ")
+ (if (not (bolp)) (insert "\n"))
+ (insert "%keyword " (upcase name) " \"" name "\"
+ %put " (upcase name) " summary
+ \"\"\n")
+ (forward-char -2))
+
+ ;;; Macro facilities
+ ;;
+
+ (defsubst semantic--grammar-macro-function-tag (name)
+ "Search for a function tag for the grammar macro with name NAME.
+ Return the tag found or nil if not found."
+ (car (semantic-find-tags-by-class
+ 'function
+ (or (semantic-find-tags-by-name name (current-buffer))
+ (and (featurep 'semanticdb)
+ semanticdb-current-database
+ (cdar (semanticdb-find-tags-by-name name nil t)))))))
+
+ (defsubst semantic--grammar-macro-lib-part (def)
+ "Return the library part of the grammar macro defined by DEF."
+ (let ((suf (format "-%s\\'" (regexp-quote (symbol-name (car def)))))
+ (fun (symbol-name (cdr def))))
+ (substring fun 0 (string-match suf fun))))
+
+ (defun semantic--grammar-macro-compl-elt (def &optional full)
+ "Return a completion entry for the grammar macro defined by DEF.
+ If optional argument FULL is non-nil qualify the macro name with the
+ library found in DEF."
+ (let ((mac (car def))
+ (lib (semantic--grammar-macro-lib-part def)))
+ (cons (if full
+ (format "%s/%s" mac lib)
+ (symbol-name mac))
+ (list mac lib))))
+
+ (defun semantic--grammar-macro-compl-dict ()
+ "Return a completion dictionnary of macro definitions."
+ (let ((defs (semantic-grammar-macros))
+ def dups dict)
+ (while defs
+ (setq def (car defs)
+ defs (cdr defs))
+ (if (or (assoc (car def) defs) (assoc (car def) dups))
+ (push def dups)
+ (push (semantic--grammar-macro-compl-elt def) dict)))
+ (while dups
+ (setq def (car dups)
+ dups (cdr dups))
+ (push (semantic--grammar-macro-compl-elt def t) dict))
+ dict))
+
+ (defun semantic-grammar-find-macro-expander (macro-name library)
+ "Visit the Emacs Lisp library where a grammar macro is implemented.
+ MACRO-NAME is a symbol that identifies a grammar macro.
+ LIBRARY is the name (sans extension) of the Emacs Lisp library where
+ to start searching the macro implementation. Lookup in included
+ libraries, if necessary.
+ Find a function tag (in current tags table) whose name contains MACRO-NAME.
+ Select the buffer containing the tag's definition, and move point there."
+ (interactive
+ (let* ((dic (semantic--grammar-macro-compl-dict))
+ (def (assoc (completing-read "Macro: " dic nil 1) dic)))
+ (or (cdr def) '(nil nil))))
+ (when (and macro-name library)
+ (let* ((lib (format "%s.el" library))
+ (buf (find-file-noselect (or (locate-library lib t) lib)))
+ (tag (with-current-buffer buf
+ (semantic--grammar-macro-function-tag
+ (format "%s-%s" library macro-name)))))
+ (if tag
+ (progn
+ (require 'semantic/decorate)
+ (pop-to-buffer (semantic-tag-buffer tag))
+ (goto-char (semantic-tag-start tag))
+ (semantic-momentary-highlight-tag tag))
+ (pop-to-buffer buf)
+ (message "No expander found in library %s for macro %s"
+ library macro-name)))))
+
+ ;;; Additional help
+ ;;
+
+ (defvar semantic-grammar-syntax-help
+ `(
+ ;; Lexical Symbols
+ ("symbol" . "Syntax: A symbol of alpha numeric and symbol characters")
+ ("number" . "Syntax: Numeric characters.")
+ ("punctuation" . "Syntax: Punctuation character.")
+ ("semantic-list" . "Syntax: A list delimited by any valid list characters")
+ ("open-paren" . "Syntax: Open Parenthesis character")
+ ("close-paren" . "Syntax: Close Parenthesis character")
+ ("string" . "Syntax: String character delimited text")
+ ("comment" . "Syntax: Comment character delimited text")
+ ;; Special Macros
+ ("EMPTY" . "Syntax: Match empty text")
+ ("ASSOC" . "Lambda Key: (ASSOC key1 value1 key2 value2 ...)")
+ ("EXPAND" . "Lambda Key: (EXPAND <list id> <rule>)")
+ ("EXPANDFULL" . "Lambda Key: (EXPANDFULL <list id> <rule>)")
+ ;; Tag Generator Macros
+ ("TAG" . "Generic Tag Generation: (TAG <name> <tag-class> [ :key value ]*)")
+ ("VARIABLE-TAG" . "(VARIABLE-TAG <name> <lang-type> <default-value> [ :key value ]*)")
+ ("FUNCTION-TAG" . "(FUNCTION-TAG <name> <lang-type> <arg-list> [ :key value ]*)")
+ ("TYPE-TAG" . "(TYPE-TAG <name> <lang-type> <part-list> <parents> [ :key value ]*)")
+ ("INCLUDE-TAG" . "(INCLUDE-TAG <name> <system-flag> [ :key value ]*)")
+ ("PACKAGE-TAG" . "(PACKAGE-TAG <name> <detail> [ :key value ]*)")
+ ("CODE-TAG" . "(CODE-TAG <name> <detail> [ :key value ]*)")
+ ("ALIAS-TAG" . "(ALIAS-TAG <name> <aliasclass> <definition> [:key value]*)")
+ ;; Special value macros
+ ("$1" . "Match Value: Value from match list in slot 1")
+ ("$2" . "Match Value: Value from match list in slot 2")
+ ("$3" . "Match Value: Value from match list in slot 3")
+ ("$4" . "Match Value: Value from match list in slot 4")
+ ("$5" . "Match Value: Value from match list in slot 5")
+ ("$6" . "Match Value: Value from match list in slot 6")
+ ("$7" . "Match Value: Value from match list in slot 7")
+ ("$8" . "Match Value: Value from match list in slot 8")
+ ("$9" . "Match Value: Value from match list in slot 9")
+ ;; Same, but with annoying , in front.
+ (",$1" . "Match Value: Value from match list in slot 1")
+ (",$2" . "Match Value: Value from match list in slot 2")
+ (",$3" . "Match Value: Value from match list in slot 3")
+ (",$4" . "Match Value: Value from match list in slot 4")
+ (",$5" . "Match Value: Value from match list in slot 5")
+ (",$6" . "Match Value: Value from match list in slot 6")
+ (",$7" . "Match Value: Value from match list in slot 7")
+ (",$8" . "Match Value: Value from match list in slot 8")
+ (",$9" . "Match Value: Value from match list in slot 9")
+ )
+ "Association of syntax elements, and the corresponding help.")
+
+ (defun semantic-grammar-eldoc-get-macro-docstring (macro expander)
+ "Return a one-line docstring for the given grammar MACRO.
+ EXPANDER is the name of the function that expands MACRO."
+ (require 'eldoc)
+ (if (and (eq expander (aref eldoc-last-data 0))
+ (eq 'function (aref eldoc-last-data 2)))
+ (aref eldoc-last-data 1)
+ (let ((doc (help-split-fundoc (documentation expander t) expander)))
+ (cond
+ (doc
+ (setq doc (car doc))
+ (string-match "\\`[^ )]* ?" doc)
+ (setq doc (concat "(" (substring doc (match-end 0)))))
+ (t
+ (setq doc (eldoc-function-argstring expander))))
+ (when doc
+ (setq doc
+ (eldoc-docstring-format-sym-doc
+ macro (format "==> %s %s" expander doc) 'default))
+ (eldoc-last-data-store expander doc 'function))
+ doc)))
+
+ (define-mode-local-override semantic-idle-summary-current-symbol-info
+ semantic-grammar-mode ()
+ "Display additional eldoc information about grammar syntax elements.
+ Syntax element is the current symbol at point.
+ If it is associated a help string in `semantic-grammar-syntax-help',
+ return that string.
+ If it is a macro name, return a description of the associated expander
+ function parameter list.
+ If it is a function name, return a description of this function
+ parameter list.
+ It it is a variable name, return a brief (one-line) documentation
+ string for the variable.
+ If a default description of the current context can be obtained,
+ return it.
+ Otherwise return nil."
+ (require 'eldoc)
+ (let* ((elt (car (semantic-ctxt-current-symbol)))
+ (val (and elt (cdr (assoc elt semantic-grammar-syntax-help)))))
+ (when (and (not val) elt (semantic-grammar-in-lisp-p))
+ ;; Ensure to load macro definitions before doing `intern-soft'.
+ (setq val (semantic-grammar-macros)
+ elt (intern-soft elt)
+ val (and elt (cdr (assq elt val))))
+ (cond
+ ;; Grammar macro
+ ((and val (fboundp val))
+ (setq val (semantic-grammar-eldoc-get-macro-docstring elt val)))
+ ;; Function
+ ((and elt (fboundp elt))
+ (setq val (eldoc-get-fnsym-args-string elt)))
+ ;; Variable
+ ((and elt (boundp elt))
+ (setq val (eldoc-get-var-docstring elt)))
+ (t nil)))
+ (or val (semantic-idle-summary-current-symbol-info-default))))
+
+ (define-mode-local-override semantic-tag-boundary-p
+ semantic-grammar-mode (tag)
+ "Return non-nil for tags that should have a boundary drawn.
+ Only tags of type 'nonterminal will be so marked."
+ (let ((c (semantic-tag-class tag)))
+ (eq c 'nonterminal)))
+
+ (define-mode-local-override semantic-ctxt-current-function
+ semantic-grammar-mode (&optional point)
+ "Determine the name of the current function at POINT."
+ (save-excursion
+ (and point (goto-char point))
+ (when (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-ctxt-current-function)))))
+
+ (define-mode-local-override semantic-ctxt-current-argument
+ semantic-grammar-mode (&optional point)
+ "Determine the argument index of the called function at POINT."
+ (save-excursion
+ (and point (goto-char point))
+ (when (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-ctxt-current-argument)))))
+
+ (define-mode-local-override semantic-ctxt-current-assignment
+ semantic-grammar-mode (&optional point)
+ "Determine the tag being assigned into at POINT."
+ (save-excursion
+ (and point (goto-char point))
+ (when (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-ctxt-current-assignment)))))
+
+ (define-mode-local-override semantic-ctxt-current-class-list
+ semantic-grammar-mode (&optional point)
+ "Determine the class of tags that can be used at POINT."
+ (save-excursion
+ (and point (goto-char point))
+ (if (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-ctxt-current-class-list))
+ '(nonterminal keyword))))
+
+ (define-mode-local-override semantic-ctxt-current-mode
+ semantic-grammar-mode (&optional point)
+ "Return the major mode active at POINT.
+ POINT defaults to the value of point in current buffer.
+ Return `emacs-lisp-mode' is POINT is within Lisp code, otherwise
+ return the current major mode."
+ (save-excursion
+ (and point (goto-char point))
+ (if (semantic-grammar-in-lisp-p)
+ 'emacs-lisp-mode
+ (semantic-ctxt-current-mode-default))))
+
+ (define-mode-local-override semantic-format-tag-abbreviate
+ semantic-grammar-mode (tag &optional parent color)
+ "Return a string abbreviation of TAG.
+ Optional PARENT is not used.
+ Optional COLOR is used to flag if color is added to the text."
+ (let ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color)))
+ (cond
+ ((eq class 'nonterminal)
+ (concat name ":"))
+ ((eq class 'setting)
+ "%settings%")
+ ((memq class '(rule keyword))
+ name)
+ (t
+ (concat "%" (symbol-name class) " " name)))))
+
+ (define-mode-local-override semantic-format-tag-summarize
+ semantic-grammar-mode (tag &optional parent color)
+ "Return a string summarizing TAG.
+ Optional PARENT is not used.
+ Optional argument COLOR determines if color is added to the text."
+ (let ((class (semantic-tag-class tag))
+ (name (semantic-format-tag-name tag parent color))
+ (label nil)
+ (desc nil))
+ (cond
+ ((eq class 'nonterminal)
+ (setq label "Nonterminal: "
+ desc (format
+ " with %d match lists."
+ (length (semantic-tag-components tag)))))
+ ((eq class 'keyword)
+ (setq label "Keyword: ")
+ (let (summary)
+ (semantic--find-tags-by-function
+ #'(lambda (put)
+ (unless summary
+ (setq summary (cdr (assoc "summary"
+ (semantic-tag-get-attribute
+ put :value))))))
+ ;; Get `put' tag with TAG name.
+ (semantic-find-tags-by-name-regexp
+ (regexp-quote (semantic-tag-name tag))
+ (semantic-find-tags-by-class 'put (current-buffer))))
+ (setq desc (concat " = "
+ (semantic-tag-get-attribute tag :value)
+ (if summary
+ (concat " - " (read summary))
+ "")))))
+ ((eq class 'token)
+ (setq label "Token: ")
+ (let ((val (semantic-tag-get-attribute tag :value))
+ (names (semantic-tag-get-attribute tag :rest))
+ (type (semantic-tag-type tag)))
+ (if names
+ (setq name (mapconcat 'identity (cons name names) " ")))
+ (setq desc (concat
+ (if type
+ (format " <%s>" type)
+ "")
+ (if val
+ (format "%s%S" val (if type " " ""))
+ "")))))
+ ((eq class 'assoc)
+ (setq label "Assoc: ")
+ (let ((val (semantic-tag-get-attribute tag :value))
+ (type (semantic-tag-type tag)))
+ (setq desc (concat
+ (if type
+ (format " <%s>" type)
+ "")
+ (if val
+ (concat " " (mapconcat 'identity val " "))
+ "")))))
+ (t
+ (setq desc (semantic-format-tag-abbreviate tag parent color))))
+ (if (and color label)
+ (setq label (semantic--format-colorize-text label 'label)))
+ (if (and color label desc)
+ (setq desc (semantic--format-colorize-text desc 'comment)))
+ (if label
+ (concat label name desc)
+ ;; Just a description is the abbreviated version
+ desc)))
+
+ ;;; Semantic Analysis
+
+ (define-mode-local-override semantic-analyze-current-context
+ semantic-grammar-mode (point)
+ "Provide a semantic analysis object describing a context in a grammar."
+ (require 'semantic/analyze)
+ (if (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-analyze-current-context point))
+
+ (let* ((context-return nil)
+ (prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
+ (prefix (car prefixandbounds))
+ (bounds (nth 2 prefixandbounds))
+ (prefixsym nil)
+ (prefixclass (semantic-ctxt-current-class-list))
+ )
+
+ ;; Do context for rules when in a match list.
+ (setq prefixsym
+ (semantic-find-first-tag-by-name
+ (car prefix)
+ (current-buffer)))
+
+ (setq context-return
+ (semantic-analyze-context
+ "context-for-semantic-grammar"
+ :buffer (current-buffer)
+ :scope nil
+ :bounds bounds
+ :prefix (if prefixsym
+ (list prefixsym)
+ prefix)
+ :prefixtypes nil
+ :prefixclass prefixclass
+ ))
+
+ context-return)))
+
+ (define-mode-local-override semantic-analyze-possible-completions
+ semantic-grammar-mode (context)
+ "Return a list of possible completions based on CONTEXT."
+ (require 'semantic/analyze/complete)
+ (if (semantic-grammar-in-lisp-p)
+ (with-mode-local emacs-lisp-mode
+ (semantic-analyze-possible-completions context))
+ (save-excursion
+ (set-buffer (oref context buffer))
+ (let* ((prefix (car (oref context :prefix)))
+ (completetext (cond ((semantic-tag-p prefix)
+ (semantic-tag-name prefix))
+ ((stringp prefix)
+ prefix)
+ ((stringp (car prefix))
+ (car prefix))))
+ (tags (semantic-find-tags-for-completion completetext
+ (current-buffer))))
+ (semantic-analyze-tags-of-class-list
+ tags (oref context prefixclass)))
+ )))
+
+ (provide 'semantic/grammar)
+
+ ;;; semantic/grammar.el ends here
--- /dev/null
-(condition-case nil
- ;; This is not installed in all versions of Emacs.
- (require 'sgml-mode) ;; html-mode is in here.
- (error
- (require 'psgml-mode) ;; XEmacs uses psgml, and html-mode is in here.
- ))
+ ;;; semantic/html.el --- Semantic details for html files
+
+ ;;; Copyright (C) 2004, 2005, 2007, 2008 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Parse HTML files and organize them in a nice way.
+ ;; Pay attention to anchors, including them in the tag list.
+ ;;
+ ;; Copied from the original semantic-texi.el.
+ ;;
+ ;; ToDo: Find <script> tags, and parse the contents in other
+ ;; parsers, such as javascript, php, shtml, or others.
+
++;;; Code:
++
+ (require 'semantic)
+ (require 'semantic/format)
-;;; Code:
-(eval-when-compile
- (require 'semantic/ctxt))
++(require 'sgml-mode)
+
++(defvar semantic-command-separation-character)
+
+ (defvar semantic-html-super-regex
+ "<\\(h[1-9]\\|title\\|script\\|body\\|a +href\\)\\>"
+ "Regular expression used to find special sections in an HTML file.")
+
+ (defvar semantic-html-section-list
+ '(("title" 1)
+ ("script" 1)
+ ("body" 1)
+ ("a" 11)
+ ("h1" 2)
+ ("h2" 3)
+ ("h3" 4)
+ ("h4" 5)
+ ("h5" 6)
+ ("h6" 7)
+ ("h7" 8)
+ ("h8" 9)
+ ("h9" 10)
+ )
+ "Alist of sectioning commands and their relative level.")
+
+ (define-mode-local-override semantic-parse-region
+ html-mode (&rest ignore)
+ "Parse the current html buffer for semantic tags.
+ INGNORE any arguments. Always parse the whole buffer.
+ Each tag returned is of the form:
+ (\"NAME\" section (:members CHILDREN))
+ or
+ (\"NAME\" anchor)"
+ (mapcar 'semantic-html-expand-tag
+ (semantic-html-parse-headings)))
+
+ (define-mode-local-override semantic-parse-changes
+ html-mode ()
+ "We can't parse changes for HTML mode right now."
+ (semantic-parse-tree-set-needs-rebuild))
+
+ (defun semantic-html-expand-tag (tag)
+ "Expand the HTML tag TAG."
+ (let ((chil (semantic-html-components tag)))
+ (if chil
+ (semantic-tag-put-attribute
+ tag :members (mapcar 'semantic-html-expand-tag chil)))
+ (car (semantic--tag-expand tag))))
+
+ (defun semantic-html-components (tag)
+ "Return components belonging to TAG."
+ (semantic-tag-get-attribute tag :members))
+
+ (defun semantic-html-parse-headings ()
+ "Parse the current html buffer for all semantic tags."
+ (let ((pass1 nil))
+ ;; First search and snarf.
+ (save-excursion
+ (goto-char (point-min))
+
+ (let ((semantic--progress-reporter
+ (make-progress-reporter
+ (format "Parsing %s..."
+ (file-name-nondirectory buffer-file-name))
+ (point-min) (point-max))))
+ (while (re-search-forward semantic-html-super-regex nil t)
+ (setq pass1 (cons (match-beginning 0) pass1))
+ (progress-reporter-update semantic--progress-reporter (point)))
+ (progress-reporter-done semantic--progress-reporter)))
+
+ (setq pass1 (nreverse pass1))
+ ;; Now, make some tags while creating a set of children.
+ (car (semantic-html-recursive-combobulate-list pass1 0))
+ ))
+
+ (defun semantic-html-set-endpoint (metataglist pnt)
+ "Set the end point of the first section tag in METATAGLIST to PNT.
+ METATAGLIST is a list of tags in the intermediate tag format used by the
+ html parser. PNT is the new point to set."
+ (let ((metatag nil))
+ (while (and metataglist
+ (not (eq (semantic-tag-class (car metataglist)) 'section)))
+ (setq metataglist (cdr metataglist)))
+ (setq metatag (car metataglist))
+ (when metatag
+ (setcar (nthcdr (1- (length metatag)) metatag) pnt)
+ metatag)))
+
+ (defsubst semantic-html-new-section-tag (name members level start end)
+ "Create a semantic tag of class section.
+ NAME is the name of this section.
+ MEMBERS is a list of semantic tags representing the elements that make
+ up this section.
+ LEVEL is the levelling level.
+ START and END define the location of data described by the tag."
+ (let ((anchorp (eq level 11)))
+ (append (semantic-tag name
+ (cond (anchorp 'anchor)
+ (t 'section))
+ :members members)
+ (list start (if anchorp (point) end)) )))
+
+ (defun semantic-html-extract-section-name ()
+ "Extract a section name from the current buffer and point.
+ Assume the cursor is in the tag representing the section we
+ need the name from."
+ (save-excursion
+ ; Skip over the HTML tag.
+ (forward-sexp -1)
+ (forward-char -1)
+ (forward-sexp 1)
+ (skip-chars-forward "\n\t ")
+ (while (looking-at "<")
+ (forward-sexp 1)
+ (skip-chars-forward "\n\t ")
+ )
+ (let ((start (point))
+ (end nil))
+ (if (re-search-forward "</" nil t)
+ (progn
+ (goto-char (match-beginning 0))
+ (skip-chars-backward " \n\t")
+ (setq end (point))
+ (buffer-substring-no-properties start end))
+ ""))
+ ))
+
+ (defun semantic-html-recursive-combobulate-list (sectionlist level)
+ "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL.
+ Return the rearranged new list, with all remaining tags from
+ SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a
+ tag with greater section value than LEVEL is found."
+ (let ((newl nil)
+ (oldl sectionlist)
+ (case-fold-search t)
+ tag
+ )
+ (save-excursion
+ (catch 'level-jump
+ (while oldl
+ (goto-char (car oldl))
+ (if (looking-at "<\\(\\w+\\)")
+ (let* ((word (match-string 1))
+ (levelmatch (assoc-string
+ word semantic-html-section-list t))
+ text begin tmp
+ )
+ (when (not levelmatch)
+ (error "Tag %s matched in regexp but is not in list"
+ word))
+ ;; Set begin to the right location
+ (setq begin (point))
+ ;; Get out of here if there if we made it that far.
+ (if (and levelmatch (<= (car (cdr levelmatch)) level))
+ (progn
+ (when newl
+ (semantic-html-set-endpoint newl begin))
+ (throw 'level-jump t)))
+ ;; When there is a match, the descriptive text
+ ;; consists of the rest of the line.
+ (goto-char (match-end 1))
+ (skip-chars-forward " \t")
+ (setq text (semantic-html-extract-section-name))
+ ;; Next, recurse into the body to find the end.
+ (setq tmp (semantic-html-recursive-combobulate-list
+ (cdr oldl) (car (cdr levelmatch))))
+ ;; Build a tag
+ (setq tag (semantic-html-new-section-tag
+ text (car tmp) (car (cdr levelmatch)) begin (point-max)))
+ ;; Before appending the newtag, update the previous tag
+ ;; if it is a section tag.
+ (when newl
+ (semantic-html-set-endpoint newl begin))
+ ;; Append new tag to our master list.
+ (setq newl (cons tag newl))
+ ;; continue
+ (setq oldl (cdr tmp))
+ )
+ (error "Problem finding section in semantic/html parser"))
+ ;; (setq oldl (cdr oldl))
+ )))
+ ;; Return the list
+ (cons (nreverse newl) oldl)))
+
+ (define-mode-local-override semantic-sb-tag-children-to-expand
+ html-mode (tag)
+ "The children TAG expands to."
+ (semantic-html-components tag))
+
+ ;;;###autoload
+ (defun semantic-default-html-setup ()
+ "Set up a buffer for parsing of HTML files."
+ ;; This will use our parser.
+ (setq semantic-parser-name "HTML"
+ semantic--parse-table t
+ imenu-create-index-function 'semantic-create-imenu-index
+ semantic-command-separation-character ">"
+ semantic-type-relation-separator-character '(":")
+ semantic-symbol->name-assoc-list '((section . "Section")
+
+ )
+ semantic-imenu-expandable-tag-classes '(section)
+ semantic-imenu-bucketize-file nil
+ semantic-imenu-bucketize-type-members nil
+ senator-step-at-start-end-tag-classes '(section)
+ semantic-stickyfunc-sticky-classes '(section)
+ )
+ (semantic-install-function-overrides
+ '((tag-components . semantic-html-components)
+ )
+ t)
+ )
+
+ (define-child-mode html-helper-mode html-mode
+ "`html-helper-mode' needs the same semantic support as `html-mode'.")
+
+ (provide 'semantic/html)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/html"
+ ;; End:
+
+ ;;; semantic/html.el ends here
--- /dev/null
-
-(semantic-alias-obsolete 'semantic-auto-parse-mode
- 'semantic-idle-scheduler-mode)
-(semantic-alias-obsolete 'global-semantic-auto-parse-mode
- 'global-semantic-idle-scheduler-mode)
-
+ ;;; idle.el --- Schedule parsing tasks in idle time
+
+ ;;; Copyright (C) 2003, 2004, 2005, 2006, 2008, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Originally, `semantic-auto-parse-mode' handled refreshing the
+ ;; tags in a buffer in idle time. Other activities can be scheduled
+ ;; in idle time, all of which require up-to-date tag tables.
+ ;; Having a specialized idle time scheduler that first refreshes
+ ;; the tags buffer, and then enables other idle time tasks reduces
+ ;; the amount of work needed. Any specialized idle tasks need not
+ ;; ask for a fresh tags list.
+ ;;
+ ;; NOTE ON SEMANTIC_ANALYZE
+ ;;
+ ;; Some of the idle modes use the semantic analyzer. The analyzer
+ ;; automatically caches the created context, so it is shared amongst
+ ;; all idle modes that will need it.
+
+ (require 'semantic)
+ (require 'semantic/ctxt)
+ (require 'semantic/format)
+ (require 'semantic/tag)
+ (require 'timer)
+
+ ;; For the semantic-find-tags-by-name macro.
+ (eval-when-compile (require 'semantic/find))
+
+ (declare-function eldoc-message "eldoc")
+ (declare-function semantic-analyze-interesting-tag "semantic/analyze")
+ (declare-function semantic-complete-analyze-inline-idle "semantic/complete")
+ (declare-function semanticdb-deep-find-tags-by-name "semantic/db-find")
+ (declare-function semanticdb-save-all-db-idle "semantic/db")
+ (declare-function semanticdb-typecache-refresh-for-buffer "semantic/db-typecache")
+ (declare-function semantic-decorate-flush-pending-decorations
+ "semantic/decorate/mode")
+ (declare-function pulse-momentary-highlight-region "pulse")
+ (declare-function pulse-momentary-highlight-overlay "pulse")
+ (declare-function semantic-symref-hits-in-region "semantic/symref/filter")
+
+ ;;; Code:
+
+ ;;; TIMER RELATED FUNCTIONS
+ ;;
+ (defvar semantic-idle-scheduler-timer nil
+ "Timer used to schedule tasks in idle time.")
+
+ (defvar semantic-idle-scheduler-work-timer nil
+ "Timer used to schedule tasks in idle time that may take a while.")
+
+ (defcustom semantic-idle-scheduler-verbose-flag nil
+ "Non-nil means that the idle scheduler should provide debug messages.
+ Use this setting to debug idle activities."
+ :group 'semantic
+ :type 'boolean)
+
+ (defcustom semantic-idle-scheduler-idle-time 1
+ "Time in seconds of idle before scheduling events.
+ This time should be short enough to ensure that idle-scheduler will be
+ run as soon as Emacs is idle."
+ :group 'semantic
+ :type 'number
+ :set (lambda (sym val)
+ (set-default sym val)
+ (when (timerp semantic-idle-scheduler-timer)
+ (cancel-timer semantic-idle-scheduler-timer)
+ (setq semantic-idle-scheduler-timer nil)
+ (semantic-idle-scheduler-setup-timers))))
+
+ (defcustom semantic-idle-scheduler-work-idle-time 60
+ "Time in seconds of idle before scheduling big work.
+ This time should be long enough that once any big work is started, it is
+ unlikely the user would be ready to type again right away."
+ :group 'semantic
+ :type 'number
+ :set (lambda (sym val)
+ (set-default sym val)
+ (when (timerp semantic-idle-scheduler-timer)
+ (cancel-timer semantic-idle-scheduler-timer)
+ (setq semantic-idle-scheduler-timer nil)
+ (semantic-idle-scheduler-setup-timers))))
+
+ (defun semantic-idle-scheduler-setup-timers ()
+ "Lazy initialization of the auto parse idle timer."
+ ;; REFRESH THIS FUNCTION for XEMACS FOIBLES
+ (or (timerp semantic-idle-scheduler-timer)
+ (setq semantic-idle-scheduler-timer
+ (run-with-idle-timer
+ semantic-idle-scheduler-idle-time t
+ #'semantic-idle-scheduler-function)))
+ (or (timerp semantic-idle-scheduler-work-timer)
+ (setq semantic-idle-scheduler-work-timer
+ (run-with-idle-timer
+ semantic-idle-scheduler-work-idle-time t
+ #'semantic-idle-scheduler-work-function)))
+ )
+
+ (defun semantic-idle-scheduler-kill-timer ()
+ "Kill the auto parse idle timer."
+ (if (timerp semantic-idle-scheduler-timer)
+ (cancel-timer semantic-idle-scheduler-timer))
+ (setq semantic-idle-scheduler-timer nil))
+
+ \f
+ ;;; MINOR MODE
+ ;;
+ ;; The minor mode portion of this code just sets up the minor mode
+ ;; which does the initial scheduling of the idle timers.
+ ;;
+ ;;;###autoload
+ (defcustom global-semantic-idle-scheduler-mode nil
+ "*If non-nil, enable global use of idle-scheduler mode."
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/idle
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-semantic-idle-scheduler-mode (if val 1 -1))))
+
+ ;;;###autoload
+ (defun global-semantic-idle-scheduler-mode (&optional arg)
+ "Toggle global use of option `semantic-idle-scheduler-mode'.
+ The idle scheduler with automatically reparse buffers in idle time,
+ and then schedule other jobs setup with `semantic-idle-scheduler-add'.
+ If ARG is positive, enable, if it is negative, disable.
+ If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-semantic-idle-scheduler-mode
+ (semantic-toggle-minor-mode-globally
+ 'semantic-idle-scheduler-mode arg)))
+
+ (defcustom semantic-idle-scheduler-mode-hook nil
+ "*Hook run at the end of function `semantic-idle-scheduler-mode'."
+ :group 'semantic
+ :type 'hook)
+
+ (defvar semantic-idle-scheduler-mode nil
+ "Non-nil if idle-scheduler minor mode is enabled.
+ Use the command `semantic-idle-scheduler-mode' to change this variable.")
+ (make-variable-buffer-local 'semantic-idle-scheduler-mode)
+
+ (defcustom semantic-idle-scheduler-max-buffer-size 0
+ "*Maximum size in bytes of buffers where idle-scheduler is enabled.
+ If this value is less than or equal to 0, idle-scheduler is enabled in
+ all buffers regardless of their size."
+ :group 'semantic
+ :type 'number)
+
+ (defsubst semantic-idle-scheduler-enabled-p ()
+ "Return non-nil if idle-scheduler is enabled for this buffer.
+ idle-scheduler is disabled when debugging or if the buffer size
+ exceeds the `semantic-idle-scheduler-max-buffer-size' threshold."
+ (and semantic-idle-scheduler-mode
+ (not (and (boundp 'semantic-debug-enabled)
+ semantic-debug-enabled))
+ (not semantic-lex-debug)
+ (or (<= semantic-idle-scheduler-max-buffer-size 0)
+ (< (buffer-size) semantic-idle-scheduler-max-buffer-size))))
+
+ (defun semantic-idle-scheduler-mode-setup ()
+ "Setup option `semantic-idle-scheduler-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-idle-scheduler-mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq semantic-idle-scheduler-mode nil)
+ (error "Buffer %s was not set up idle time scheduling"
+ (buffer-name)))
+ (semantic-idle-scheduler-setup-timers)))
+ semantic-idle-scheduler-mode)
+
+ ;;;###autoload
+ (defun semantic-idle-scheduler-mode (&optional arg)
+ "Minor mode to auto parse buffer following a change.
+ When this mode is off, a buffer is only rescanned for tokens when
+ some command requests the list of available tokens. When idle-scheduler
+ is enabled, Emacs periodically checks to see if the buffer is out of
+ date, and reparses while the user is idle (not typing.)
+
+ 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-idle-scheduler-mode 0 1))))
+ (setq semantic-idle-scheduler-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-idle-scheduler-mode)))
+ (semantic-idle-scheduler-mode-setup)
+ (run-hooks 'semantic-idle-scheduler-mode-hook)
+ (if (interactive-p)
+ (message "idle-scheduler minor mode %sabled"
+ (if semantic-idle-scheduler-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-idle-scheduler-mode)
+
+ (semantic-add-minor-mode 'semantic-idle-scheduler-mode
+ "ARP"
+ nil)
-;; (defcustom semantic-idle-scheduler-no-working-message t
-;; "*If non-nil, disable display of working messages during parse."
-;; :group 'semantic
-;; :type 'boolean)
-
-;; (defcustom semantic-idle-scheduler-working-in-modeline-flag nil
-;; "*Non-nil means show working messages in the mode line.
-;; Typically, parsing will show messages in the minibuffer.
-;; This will move the parse message into the modeline."
-;; :group 'semantic
-;; :type 'boolean)
-
+ \f
+ ;;; SERVICES services
+ ;;
+ ;; These are services for managing idle services.
+ ;;
+ (defvar semantic-idle-scheduler-queue nil
+ "List of functions to execute during idle time.
+ These functions will be called in the current buffer after that
+ buffer has had its tags made up to date. These functions
+ will not be called if there are errors parsing the
+ current buffer.")
+
+ (defun semantic-idle-scheduler-add (function)
+ "Schedule FUNCTION to occur during idle time."
+ (add-to-list 'semantic-idle-scheduler-queue function))
+
+ (defun semantic-idle-scheduler-remove (function)
+ "Unschedule FUNCTION to occur during idle time."
+ (setq semantic-idle-scheduler-queue
+ (delete function semantic-idle-scheduler-queue)))
+
+ ;;; IDLE Function
+ ;;
+ (defun semantic-idle-core-handler ()
+ "Core idle function that handles reparsing.
+ And also manages services that depend on tag values."
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: Core handler..."))
+ (semantic-exit-on-input 'idle-timer
+ (let* ((inhibit-quit nil)
+ (buffers (delq (current-buffer)
+ (delq nil
+ (mapcar #'(lambda (b)
+ (and (buffer-file-name b)
+ b))
+ (buffer-list)))))
+ safe ;; This safe is not used, but could be.
+ others
+ mode)
+ (when (semantic-idle-scheduler-enabled-p)
+ (save-excursion
+ ;; First, reparse the current buffer.
+ (setq mode major-mode
+ safe (semantic-safe "Idle Parse Error: %S"
+ ;(error "Goofy error 1")
+ (semantic-idle-scheduler-refresh-tags)
+ )
+ )
+ ;; Now loop over other buffers with same major mode, trying to
+ ;; update them as well. Stop on keypress.
+ (dolist (b buffers)
+ (semantic-throw-on-input 'parsing-mode-buffers)
+ (with-current-buffer b
+ (if (eq major-mode mode)
+ (and (semantic-idle-scheduler-enabled-p)
+ (semantic-safe "Idle Parse Error: %S"
+ ;(error "Goofy error")
+ (semantic-idle-scheduler-refresh-tags)))
+ (push (current-buffer) others))))
+ (setq buffers others))
+ ;; If re-parse of current buffer completed, evaluate all other
+ ;; services. Stop on keypress.
+
+ ;; NOTE ON COMMENTED SAFE HERE
+ ;; We used to not execute the services if the buffer wsa
+ ;; unparseable. We now assume that they are lexically
+ ;; safe to do, because we have marked the buffer unparseable
+ ;; if there was a problem.
+ ;;(when safe
+ (dolist (service semantic-idle-scheduler-queue)
+ (save-excursion
+ (semantic-throw-on-input 'idle-queue)
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: execture service %s..." service))
+ (semantic-safe (format "Idle Service Error %s: %%S" service)
+ (funcall service))
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: execture service %s...done" service))
+ )))
+ ;;)
+ ;; Finally loop over remaining buffers, trying to update them as
+ ;; well. Stop on keypress.
+ (save-excursion
+ (dolist (b buffers)
+ (semantic-throw-on-input 'parsing-other-buffers)
+ (with-current-buffer b
+ (and (semantic-idle-scheduler-enabled-p)
+ (semantic-idle-scheduler-refresh-tags)))))
+ ))
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: Core handler...done")))
+
+ (defun semantic-debug-idle-function ()
+ "Run the Semantic idle function with debugging turned on."
+ (interactive)
+ (let ((debug-on-error t))
+ (semantic-idle-core-handler)
+ ))
+
+ (defun semantic-idle-scheduler-function ()
+ "Function run when after `semantic-idle-scheduler-idle-time'.
+ This function will reparse the current buffer, and if successful,
+ call additional functions registered with the timer calls."
+ (when (zerop (recursion-depth))
+ (let ((debug-on-error nil))
+ (save-match-data (semantic-idle-core-handler))
+ )))
+
+ \f
+ ;;; WORK FUNCTION
+ ;;
+ ;; Unlike the shorter timer, the WORK timer will kick of tasks that
+ ;; may take a long time to complete.
+ (defcustom semantic-idle-work-parse-neighboring-files-flag t
+ "*Non-nil means to parse files in the same dir as the current buffer.
+ Disable to prevent lots of excessive parsing in idle time."
+ :group 'semantic
+ :type 'boolean)
+
+
+ (defun semantic-idle-work-for-one-buffer (buffer)
+ "Do long-processing work for for BUFFER.
+ Uses `semantic-safe' and returns the output.
+ Returns t of all processing succeeded."
+ (save-excursion
+ (set-buffer buffer)
+ (not (and
+ ;; Just in case
+ (semantic-safe "Idle Work Parse Error: %S"
+ (semantic-idle-scheduler-refresh-tags)
+ t)
+
+ ;; Force all our include files to get read in so we
+ ;; are ready to provide good smart completion and idle
+ ;; summary information
+ (semantic-safe "Idle Work Including Error: %S"
+ ;; Get the include related path.
+ (when (and (featurep 'semantic/db) (semanticdb-minor-mode-p))
+ (require 'semantic/db-find)
+ (semanticdb-find-translate-path buffer nil)
+ )
+ t)
+
+ ;; Pre-build the typecaches as needed.
+ (semantic-safe "Idle Work Typecaching Error: %S"
+ (when (featurep 'semantic/db-typecache)
+ (semanticdb-typecache-refresh-for-buffer buffer))
+ t)
+ ))
+ ))
+
+ (defun semantic-idle-work-core-handler ()
+ "Core handler for idle work processing of long running tasks.
+ Visits semantic controlled buffers, and makes sure all needed
+ include files have been parsed, and that the typecache is up to date.
+ Uses `semantic-idle-work-for-on-buffer' to do the work."
+ (let ((errbuf nil)
+ (interrupted
+ (semantic-exit-on-input 'idle-work-timer
+ (let* ((inhibit-quit nil)
+ (cb (current-buffer))
+ (buffers (delq (current-buffer)
+ (delq nil
+ (mapcar #'(lambda (b)
+ (and (buffer-file-name b)
+ b))
+ (buffer-list)))))
+ safe errbuf)
+ ;; First, handle long tasks in the current buffer.
+ (when (semantic-idle-scheduler-enabled-p)
+ (save-excursion
+ (setq safe (semantic-idle-work-for-one-buffer (current-buffer))
+ )))
+ (when (not safe) (push (current-buffer) errbuf))
+
+ ;; Now loop over other buffers with same major mode, trying to
+ ;; update them as well. Stop on keypress.
+ (dolist (b buffers)
+ (semantic-throw-on-input 'parsing-mode-buffers)
+ (with-current-buffer b
+ (when (semantic-idle-scheduler-enabled-p)
+ (and (semantic-idle-scheduler-enabled-p)
+ (unless (semantic-idle-work-for-one-buffer (current-buffer))
+ (push (current-buffer) errbuf)))
+ ))
+ )
+
+ (when (and (featurep 'semantic/db) (semanticdb-minor-mode-p))
+ ;; Save everything.
+ (semanticdb-save-all-db-idle)
+
+ ;; Parse up files near our active buffer
+ (when semantic-idle-work-parse-neighboring-files-flag
+ (semantic-safe "Idle Work Parse Neighboring Files: %S"
+ (set-buffer cb)
+ (semantic-idle-scheduler-work-parse-neighboring-files))
+ t)
+
+ ;; Save everything... again
+ (semanticdb-save-all-db-idle)
+ )
+
+ ;; Done w/ processing
+ nil))))
+
+ ;; Done
+ (if interrupted
+ "Interrupted"
+ (cond ((not errbuf)
+ "done")
+ ((not (cdr errbuf))
+ (format "done with 1 error in %s" (car errbuf)))
+ (t
+ (format "done with errors in %d buffers."
+ (length errbuf)))))))
+
+ (defun semantic-debug-idle-work-function ()
+ "Run the Semantic idle work function with debugging turned on."
+ (interactive)
+ (let ((debug-on-error t))
+ (semantic-idle-work-core-handler)
+ ))
+
+ (defun semantic-idle-scheduler-work-function ()
+ "Function run when after `semantic-idle-scheduler-work-idle-time'.
+ This routine handles difficult tasks that require a lot of parsing, such as
+ parsing all the header files used by our active sources, or building up complex
+ datasets."
+ (when semantic-idle-scheduler-verbose-flag
+ (message "Long Work Idle Timer..."))
+ (let ((exit-type (save-match-data
+ (semantic-idle-work-core-handler))))
+ (when semantic-idle-scheduler-verbose-flag
+ (message "Long Work Idle Timer...%s" exit-type)))
+ )
+
+ (defun semantic-idle-scheduler-work-parse-neighboring-files ()
+ "Parse all the files in similar directories to buffers being edited."
+ ;; Lets check to see if EDE matters.
+ (let ((ede-auto-add-method 'never))
+ (dolist (a auto-mode-alist)
+ (when (eq (cdr a) major-mode)
+ (dolist (file (directory-files default-directory t (car a) t))
+ (semantic-throw-on-input 'parsing-mode-buffers)
+ (save-excursion
+ (semanticdb-file-table-object file)
+ ))))
+ ))
+
+ \f
+ ;;; REPARSING
+ ;;
+ ;; Reparsing is installed as semantic idle service.
+ ;; This part ALWAYS happens, and other services occur
+ ;; afterwards.
+
-
-(semantic-alias-obsolete 'semantic-summary-mode
- 'semantic-idle-summary-mode)
-(semantic-alias-obsolete 'global-semantic-summary-mode
- 'global-semantic-idle-summary-mode)
+ (defvar semantic-before-idle-scheduler-reparse-hook nil
+ "Hook run before option `semantic-idle-scheduler' begins parsing.
+ If any hook function throws an error, this variable is reset to nil.
+ This hook is not protected from lexical errors.")
+
+ (defvar semantic-after-idle-scheduler-reparse-hook nil
+ "Hook run after option `semantic-idle-scheduler' has parsed.
+ If any hook function throws an error, this variable is reset to nil.
+ This hook is not protected from lexical errors.")
+
+ (semantic-varalias-obsolete 'semantic-before-idle-scheduler-reparse-hooks
+ 'semantic-before-idle-scheduler-reparse-hook)
+ (semantic-varalias-obsolete 'semantic-after-idle-scheduler-reparse-hooks
+ 'semantic-after-idle-scheduler-reparse-hook)
+
+ (defun semantic-idle-scheduler-refresh-tags ()
+ "Refreshes the current buffer's tags.
+ This is called by `semantic-idle-scheduler-function' to update the
+ tags in the current buffer.
+
+ Return non-nil if the refresh was successful.
+ Return nil if there is some sort of syntax error preventing a full
+ reparse.
+
+ Does nothing if the current buffer doesn't need reparsing."
+
+ (prog1
+ ;; These checks actually occur in `semantic-fetch-tags', but if we
+ ;; do them here, then all the bovination hooks are not run, and
+ ;; we save lots of time.
+ (cond
+ ;; If the buffer was previously marked unparseable,
+ ;; then don't waste our time.
+ ((semantic-parse-tree-unparseable-p)
+ nil)
+ ;; The parse tree is already ok.
+ ((semantic-parse-tree-up-to-date-p)
+ t)
+ (t
+ ;; If the buffer might need a reparse and it is safe to do so,
+ ;; give it a try.
+ (let* (;(semantic-working-type nil)
+ (inhibit-quit nil)
+ ;; (working-use-echo-area-p
+ ;; (not semantic-idle-scheduler-working-in-modeline-flag))
+ ;; (working-status-dynamic-type
+ ;; (if semantic-idle-scheduler-no-working-message
+ ;; nil
+ ;; working-status-dynamic-type))
+ ;; (working-status-percentage-type
+ ;; (if semantic-idle-scheduler-no-working-message
+ ;; nil
+ ;; working-status-percentage-type))
+ (lexically-safe t)
+ )
+ ;; Let people hook into this, but don't let them hose
+ ;; us over!
+ (condition-case nil
+ (run-hooks 'semantic-before-idle-scheduler-reparse-hook)
+ (error (setq semantic-before-idle-scheduler-reparse-hook nil)))
+
+ (unwind-protect
+ ;; Perform the parsing.
+ (progn
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: reparse %s..." (buffer-name)))
+ (when (semantic-lex-catch-errors idle-scheduler
+ (save-excursion (semantic-fetch-tags))
+ nil)
+ ;; If we are here, it is because the lexical step failed,
+ ;; proably due to unterminated lists or something like that.
+
+ ;; We do nothing, and just wait for the next idle timer
+ ;; to go off. In the meantime, remember this, and make sure
+ ;; no other idle services can get executed.
+ (setq lexically-safe nil))
+ (when semantic-idle-scheduler-verbose-flag
+ (message "IDLE: reparse %s...done" (buffer-name))))
+ ;; Let people hook into this, but don't let them hose
+ ;; us over!
+ (condition-case nil
+ (run-hooks 'semantic-after-idle-scheduler-reparse-hook)
+ (error (setq semantic-after-idle-scheduler-reparse-hook nil))))
+ ;; Return if we are lexically safe (from prog1)
+ lexically-safe)))
+
+ ;; After updating the tags, handle any pending decorations for this
+ ;; buffer.
+ (require 'semantic/decorate/mode)
+ (semantic-decorate-flush-pending-decorations (current-buffer))
+ ))
+
+ \f
+ ;;; IDLE SERVICES
+ ;;
+ ;; Idle Services are minor modes which enable or disable a services in
+ ;; the idle scheduler. Creating a new services only requires calling
+ ;; `semantic-create-idle-services' which does all the setup
+ ;; needed to create the minor mode that will enable or disable
+ ;; a services. The services must provide a single function.
+
+ (defmacro define-semantic-idle-service (name doc &rest forms)
+ "Create a new idle services with NAME.
+ DOC will be a documentation string describing FORMS.
+ FORMS will be called during idle time after the current buffer's
+ semantic tag information has been updated.
+ This routines creates the following functions and variables:"
+ (let ((global (intern (concat "global-" (symbol-name name) "-mode")))
+ (mode (intern (concat (symbol-name name) "-mode")))
+ (hook (intern (concat (symbol-name name) "-mode-hook")))
+ (map (intern (concat (symbol-name name) "-mode-map")))
+ (setup (intern (concat (symbol-name name) "-mode-setup")))
+ (func (intern (concat (symbol-name name) "-idle-function")))
+ )
+
+ `(eval-and-compile
+ (defun ,global (&optional arg)
+ ,(concat "Toggle global use of `" (symbol-name mode) "'.
+ If ARG is positive, enable, if it is negative, disable.
+ If ARG is nil, then toggle.")
+ (interactive "P")
+ (setq ,global
+ (semantic-toggle-minor-mode-globally
+ ',mode arg)))
+
+ (defcustom ,global nil
+ (concat "*If non-nil, enable global use of `" (symbol-name ',mode) "'.
+ " ,doc)
+ :group 'semantic
+ :group 'semantic-modes
+ :type 'boolean
+ :require 'semantic/idle
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (,global (if val 1 -1))))
+
+ (defcustom ,hook nil
+ (concat "*Hook run at the end of function `" (symbol-name ',mode) "'.")
+ :group 'semantic
+ :type 'hook)
+
+ (defvar ,map
+ (let ((km (make-sparse-keymap)))
+ km)
+ (concat "Keymap for `" (symbol-name ',mode) "'."))
+
+ (defvar ,mode nil
+ (concat "Non-nil if summary minor mode is enabled.
+ Use the command `" (symbol-name ',mode) "' to change this variable."))
+ (make-variable-buffer-local ',mode)
+
+ (defun ,setup ()
+ ,(concat "Setup option `" (symbol-name mode) "'.
+ The minor mode can be turned on only if semantic feature is available
+ and the idle scheduler is active.
+ Return non-nil if the minor mode is enabled.")
+ (if ,mode
+ (if (not (and (featurep 'semantic) (semantic-active-p)))
+ (progn
+ ;; Disable minor mode if semantic stuff not available
+ (setq ,mode nil)
+ (error "Buffer %s was not set up for parsing"
+ (buffer-name)))
+ ;; Enable the mode mode
+ (semantic-idle-scheduler-add #',func)
+ )
+ ;; Disable the mode mode
+ (semantic-idle-scheduler-remove #',func)
+ )
+ ,mode)
+
+ (defun ,mode (&optional arg)
+ ,(concat doc "
+ This is a minor mode which performs actions during idle time.
+ 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 ,mode 0 1))))
+ (setq ,mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not ,mode)))
+ (,setup)
+ (run-hooks ,hook)
+ (if (interactive-p)
+ (message "%s %sabled"
+ (symbol-name ',mode)
+ (if ,mode "en" "dis")))
+ (semantic-mode-line-update)
+ ,mode)
+
+ (semantic-add-minor-mode ',mode
+ "" ; idle schedulers are quiet?
+ ,map)
+
+ (defun ,func ()
+ ,doc
+ ,@forms)
+
+ )))
+ (put 'define-semantic-idle-service 'lisp-indent-function 1)
+
+ \f
+ ;;; SUMMARY MODE
+ ;;
+ ;; A mode similar to eldoc using semantic
+
+ (defcustom semantic-idle-summary-function
+ 'semantic-format-tag-summarize-with-file
+ "*Function to use when displaying tag information during idle time.
+ Some useful functions are found in `semantic-format-tag-functions'."
+ :group 'semantic
+ :type semantic-format-tag-custom-list)
+
+ (defsubst semantic-idle-summary-find-current-symbol-tag (sym)
+ "Search for a semantic tag with name SYM in database tables.
+ Return the tag found or nil if not found.
+ If semanticdb is not in use, use the current buffer only."
+ (car (if (and (featurep 'semantic/db)
+ semanticdb-current-database
+ (require 'semantic/db-find))
+ (cdar (semanticdb-deep-find-tags-by-name sym))
+ (semantic-deep-find-tags-by-name sym (current-buffer)))))
+
+ (defun semantic-idle-summary-current-symbol-info-brutish ()
+ "Return a string message describing the current context.
+ Gets a symbol with `semantic-ctxt-current-thing' and then
+ trys to find it with a deep targetted search."
+ ;; Try the current "thing".
+ (let ((sym (car (semantic-ctxt-current-thing))))
+ (when sym
+ (semantic-idle-summary-find-current-symbol-tag sym))))
+
+ (defun semantic-idle-summary-current-symbol-keyword ()
+ "Return a string message describing the current symbol.
+ Returns a value only if it is a keyword."
+ ;; Try the current "thing".
+ (let ((sym (car (semantic-ctxt-current-thing))))
+ (if (and sym (semantic-lex-keyword-p sym))
+ (semantic-lex-keyword-get sym 'summary))))
+
+ (defun semantic-idle-summary-current-symbol-info-context ()
+ "Return a string message describing the current context.
+ Use the semantic analyzer to find the symbol information."
+ (let ((analysis (condition-case nil
+ (semantic-analyze-current-context (point))
+ (error nil))))
+ (when analysis
+ (require 'semantic/analyze)
+ (semantic-analyze-interesting-tag analysis))))
+
+ (defun semantic-idle-summary-current-symbol-info-default ()
+ "Return a string message describing the current context.
+ This functin will disable loading of previously unloaded files
+ by semanticdb as a time-saving measure."
+ (let (
+ (semanticdb-find-default-throttle
+ (if (featurep 'semantic/db-find)
+ (remq 'unloaded semanticdb-find-default-throttle)
+ nil))
+ )
+ (save-excursion
+ ;; use whicever has success first.
+ (or
+ (semantic-idle-summary-current-symbol-keyword)
+
+ (semantic-idle-summary-current-symbol-info-context)
+
+ (semantic-idle-summary-current-symbol-info-brutish)
+ ))))
+
+ (defvar semantic-idle-summary-out-of-context-faces
+ '(
+ font-lock-comment-face
+ font-lock-string-face
+ font-lock-doc-string-face ; XEmacs.
+ font-lock-doc-face ; Emacs 21 and later.
+ )
+ "List of font-lock faces that indicate a useless summary context.
+ Those are generally faces used to highlight comments.
+
+ It might be useful to override this variable to add comment faces
+ specific to a major mode. For example, in jde mode:
+
+ \(defvar-mode-local jde-mode semantic-idle-summary-out-of-context-faces
+ (append (default-value 'semantic-idle-summary-out-of-context-faces)
+ '(jde-java-font-lock-doc-tag-face
+ jde-java-font-lock-link-face
+ jde-java-font-lock-bold-face
+ jde-java-font-lock-underline-face
+ jde-java-font-lock-pre-face
+ jde-java-font-lock-code-face)))")
+
+ (defun semantic-idle-summary-useful-context-p ()
+ "Non-nil of we should show a summary based on context."
+ (if (and (boundp 'font-lock-mode)
+ font-lock-mode
+ (memq (get-text-property (point) 'face)
+ semantic-idle-summary-out-of-context-faces))
+ ;; The best I can think of at the moment is to disable
+ ;; in comments by detecting with font-lock.
+ nil
+ t))
+
+ (define-overloadable-function semantic-idle-summary-current-symbol-info ()
+ "Return a string message describing the current context.")
+
+ (make-obsolete-overload 'semantic-eldoc-current-symbol-info
+ 'semantic-idle-summary-current-symbol-info)
+
+ (define-semantic-idle-service semantic-idle-summary
+ "Display a tag summary of the lexical token under the cursor.
+ Call `semantic-idle-summary-current-symbol-info' for getting the
+ current tag to display information."
+ (or (eq major-mode 'emacs-lisp-mode)
+ (not (semantic-idle-summary-useful-context-p))
+ (let* ((found (semantic-idle-summary-current-symbol-info))
+ (str (cond ((stringp found) found)
+ ((semantic-tag-p found)
+ (funcall semantic-idle-summary-function
+ found nil t))))
+ )
+ ;; Show the message with eldoc functions
+ (require 'eldoc)
+ (unless (and str (boundp 'eldoc-echo-area-use-multiline-p)
+ eldoc-echo-area-use-multiline-p)
+ (let ((w (1- (window-width (minibuffer-window)))))
+ (if (> (length str) w)
+ (setq str (substring str 0 w)))))
+ (eldoc-message str))))
+ \f
+ ;;; Current symbol highlight
+ ;;
+ ;; This mode will use context analysis to perform highlighting
+ ;; of all uses of the symbol that is under the cursor.
+ ;;
+ ;; This is to mimic the Eclipse tool of a similar nature.
+ (defvar semantic-idle-summary-highlight-face 'region
+ "Face used for the summary highlight.")
+
+ (defun semantic-idle-summary-maybe-highlight (tag)
+ "Perhaps add highlighting onto TAG.
+ TAG was found as the thing under point. If it happens to be
+ visible, then highlight it."
+ (require 'pulse)
+ (let* ((region (when (and (semantic-tag-p tag)
+ (semantic-tag-with-position-p tag))
+ (semantic-tag-overlay tag)))
+ (file (when (and (semantic-tag-p tag)
+ (semantic-tag-with-position-p tag))
+ (semantic-tag-file-name tag)))
+ (buffer (when file (get-file-buffer file)))
+ ;; We use pulse, but we don't want the flashy version,
+ ;; just the stable version.
+ (pulse-flag nil)
+ )
+ (cond ((semantic-overlay-p region)
+ (save-excursion
+ (set-buffer (semantic-overlay-buffer region))
+ (goto-char (semantic-overlay-start region))
+ (when (pos-visible-in-window-p
+ (point) (get-buffer-window (current-buffer) 'visible))
+ (if (< (semantic-overlay-end region) (point-at-eol))
+ (pulse-momentary-highlight-overlay
+ region semantic-idle-summary-highlight-face)
+ ;; Not the same
+ (pulse-momentary-highlight-region
+ (semantic-overlay-start region)
+ (point-at-eol)
+ semantic-idle-summary-highlight-face)))
+ ))
+ ((vectorp region)
+ (let ((start (aref region 0))
+ (end (aref region 1)))
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ ;; As a vector, we have no filename. Perhaps it is a
+ ;; local variable?
+ (when (and (<= end (point-max))
+ (pos-visible-in-window-p
+ start (get-buffer-window (current-buffer) 'visible)))
+ (goto-char start)
+ (when (re-search-forward
+ (regexp-quote (semantic-tag-name tag))
+ end t)
+ ;; This is likely it, give it a try.
+ (pulse-momentary-highlight-region
+ start (if (<= end (point-at-eol)) end
+ (point-at-eol))
+ semantic-idle-summary-highlight-face)))
+ ))))
+ nil))
+
+ (define-semantic-idle-service semantic-idle-tag-highlight
+ "Highlight the tag, and references of the symbol under point.
+ Call `semantic-analyze-current-context' to find the reference tag.
+ Call `semantic-symref-hits-in-region' to identify local references."
+ (require 'pulse)
+ (when (semantic-idle-summary-useful-context-p)
+ (let* ((ctxt (semantic-analyze-current-context))
+ (Hbounds (when ctxt (oref ctxt bounds)))
+ (target (when ctxt (car (reverse (oref ctxt prefix)))))
+ (tag (semantic-current-tag))
+ ;; We use pulse, but we don't want the flashy version,
+ ;; just the stable version.
+ (pulse-flag nil))
+ (when ctxt
+ ;; Highlight the original tag? Protect against problems.
+ (condition-case nil
+ (semantic-idle-summary-maybe-highlight target)
+ (error nil))
+ ;; Identify all hits in this current tag.
+ (when (semantic-tag-p target)
+ (require 'semantic/symref/filter)
+ (semantic-symref-hits-in-region
+ target (lambda (start end prefix)
+ (when (/= start (car Hbounds))
+ (pulse-momentary-highlight-region
+ start end))
+ (semantic-throw-on-input 'symref-highlight)
+ )
+ (semantic-tag-start tag)
+ (semantic-tag-end tag)))
+ ))))
+
+ \f
+ ;;; Completion Popup Mode
+ ;;
+ ;; This mode uses tooltips to display a (hopefully) short list of possible
+ ;; completions available for the text under point. It provides
+ ;; NO provision for actually filling in the values from those completions.
+
+ (defun semantic-idle-completion-list-default ()
+ "Calculate and display a list of completions."
+ (when (semantic-idle-summary-useful-context-p)
+ ;; This mode can be fragile. Ignore problems.
+ ;; If something doesn't do what you expect, run
+ ;; the below command by hand instead.
+ (condition-case nil
+ (let (
+ ;; Don't go loading in oodles of header libraries in
+ ;; IDLE time.
+ (semanticdb-find-default-throttle
+ (if (featurep 'semantic/db-find)
+ (remq 'unloaded semanticdb-find-default-throttle)
+ nil))
+ )
+ ;; Use idle version.
+ (require 'semantic/complete)
+ (semantic-complete-analyze-inline-idle)
+ )
+ (error nil))
+ ))
+
+ (define-semantic-idle-service semantic-idle-completions
+ "Display a list of possible completions in a tooltip."
+ ;; Add the ability to override sometime.
+ (semantic-idle-completion-list-default))
+
+ (provide 'semantic/idle)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/idle"
+ ;; End:
+
+ ;;; semantic-idle.el ends here
--- /dev/null
- (&define name stringp stringp form def-body)
- )
- ))
-
+ ;;; lex-spp.el --- Semantic Lexical Pre-processor
+
+ ;;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; The Semantic Preprocessor works with semantic-lex to provide a phase
+ ;; during lexical analysis to do the work of a pre-processor.
+ ;;
+ ;; A pre-processor identifies lexical syntax mixed in with another language
+ ;; and replaces some keyword tokens with streams of alternate tokens.
+ ;;
+ ;; If you use SPP in your language, be sure to specify this in your
+ ;; semantic language setup function:
+ ;;
+ ;; (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t)
+ ;;
+ ;;
+ ;; Special Lexical Tokens:
+ ;;
+ ;; There are several special lexical tokens that are used by the
+ ;; Semantic PreProcessor lexer. They are:
+ ;;
+ ;; Declarations:
+ ;; spp-macro-def - A definition of a lexical macro.
+ ;; spp-macro-undef - A removal of a definition of a lexical macro.
+ ;; spp-system-include - A system level include file
+ ;; spp-include - An include file
+ ;; spp-concat - A lexical token representing textual concatenation
+ ;; of symbol parts.
+ ;;
+ ;; Operational tokens:
+ ;; spp-arg-list - Represents an argument list to a macro.
+ ;; spp-symbol-merge - A request for multiple symbols to be textually merged.
+ ;;
+ ;;; TODO:
+ ;;
+ ;; Use `semantic-push-parser-warning' for situations where there are likely
+ ;; macros that are undefined unexpectedly, or other problem.
+ ;;
+ ;; TODO:
+ ;;
+ ;; Try to handle the case of:
+ ;;
+ ;; #define NN namespace nn {
+ ;; #define NN_END }
+ ;;
+ ;; NN
+ ;; int mydecl() {}
+ ;; NN_END
+ ;;
+
+ (require 'semantic)
+ (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 &optional blocktok)
+ "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;
+
+ If optional string BLOCKTOK matches the expanded value, then do not
+ continue processing recursively."
+ (let ((txt (semantic-lex-token-text tok))
+ (sym nil)
+ )
+ (cond
+ ;; Recursion prevention
+ ((and (stringp blocktok) (string= txt blocktok))
+ blocktok)
+ ;; A complex symbol
+ ((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
+ ;; This is another lexical token.
+ ((and (consp val)
+ (symbolp (car val)))
+ (semantic-lex-spp-one-token-to-txt val txt))
+ ;; This is a list of tokens.
+ ((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 count)
+ (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 (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)))))
+
+ (defvar semantic-lex-spp-hack-depth 0
+ "Current depth of recursive calls to `semantic-lex-spp-lex-text-string'.")
+
+ (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* ((semantic-lex-spp-hack-depth (1+ semantic-lex-spp-hack-depth))
+ (buf (get-buffer-create (format " *SPP parse hack %d*"
+ semantic-lex-spp-hack-depth)))
+ (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
+ ))
+ )
+ (save-excursion
+ (set-buffer buf)
+ (erase-buffer)
+ ;; Below is a painful hack to make sure everything is setup correctly.
+ (when (not (eq major-mode mode))
+ (save-match-data
+
+ ;; Protect against user-hooks that throw errors.
+ (condition-case nil
+ (funcall mode)
+ (error nil))
+
+ ;; 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 regarding macro state from the
+ ;; the originating buffer we are parsing. We need to do this every time
+ ;; since the state changes.
+ (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.")
+
++;;;###autoload
+ (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"))
+ )
+
+ ;;; 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)
+
++;; Local variables:
++;; generated-autoload-file: "loaddefs.el"
++;; generated-autoload-feature: semantic/loaddefs
++;; generated-autoload-load-name: "semantic/lex-spp"
++;; End:
++
+ ;;; semantic-lex-spp.el ends here
--- /dev/null
-;;; lex.el --- Lexical Analyzer builder
++;;; semantic/lex.el --- Lexical Analyzer builder
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+ ;;; 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; This file handles the creation of lexical analyzers for different
+ ;; languages in Emacs Lisp. The purpose of a lexical analyzer is to
+ ;; convert a buffer into a list of lexical tokens. Each token
+ ;; contains the token class (such as 'number, 'symbol, 'IF, etc) and
+ ;; the location in the buffer it was found. Optionally, a token also
+ ;; contains a string representing what is at the designated buffer
+ ;; location.
+ ;;
+ ;; Tokens are pushed onto a token stream, which is basically a list of
+ ;; all the lexical tokens from the analyzed region. The token stream
+ ;; is then handed to the grammar which parsers the file.
+ ;;
+ ;;; How it works
+ ;;
+ ;; Each analyzer specifies a condition and forms. These conditions
+ ;; and forms are assembled into a function by `define-lex' that does
+ ;; the lexical analysis.
+ ;;
+ ;; In the lexical analyzer created with `define-lex', each condition
+ ;; is tested for a given point. When the conditin is true, the forms
+ ;; run.
+ ;;
+ ;; The forms can push a lexical token onto the token stream. The
+ ;; analyzer forms also must move the current analyzer point. If the
+ ;; analyzer point is moved without pushing a token, then tne matched
+ ;; syntax is effectively ignored, or skipped.
+ ;;
+ ;; Thus, starting at the beginning of a region to be analyzed, each
+ ;; condition is tested. One will match, and a lexical token might be
+ ;; pushed, and the point is moved to the end of the lexical token
+ ;; identified. At the new position, the process occurs again until
+ ;; the end of the specified region is reached.
+ ;;
+ ;;; How to use semantic-lex
+ ;;
+ ;; To create a lexer for a language, use the `define-lex' macro.
+ ;;
+ ;; The `define-lex' macro accepts a list of lexical analyzers. Each
+ ;; analyzer is created with `define-lex-analyzer', or one of the
+ ;; derivitive macros. A single analyzer defines a regular expression
+ ;; to match text in a buffer, and a short segment of code to create
+ ;; one lexical token.
+ ;;
+ ;; Each analyzer has a NAME, DOC, a CONDITION, and possibly some
+ ;; FORMS. The NAME is the name used in `define-lex'. The DOC
+ ;; describes what the analyzer should do.
+ ;;
+ ;; The CONDITION evaluates the text at the current point in the
+ ;; current buffer. If CONDITION is true, then the FORMS will be
+ ;; executed.
+ ;;
+ ;; The purpose of the FORMS is to push new lexical tokens onto the
+ ;; list of tokens for the current buffer, and to move point after the
+ ;; matched text.
+ ;;
+ ;; Some macros for creating one analyzer are:
+ ;;
+ ;; define-lex-analyzer - A generic analyzer associating any style of
+ ;; condition to forms.
+ ;; define-lex-regex-analyzer - Matches a regular expression.
+ ;; define-lex-simple-regex-analyzer - Matches a regular expressions,
+ ;; and pushes the match.
+ ;; define-lex-block-analyzer - Matches list syntax, and defines
+ ;; handles open/close delimiters.
+ ;;
+ ;; These macros are used by the grammar compiler when lexical
+ ;; information is specified in a grammar:
+ ;; define-lex- * -type-analyzer - Matches syntax specified in
+ ;; a grammar, and pushes one token for it. The * would
+ ;; be `sexp' for things like lists or strings, and
+ ;; `string' for things that need to match some special
+ ;; string, such as "\\." where a literal match is needed.
+ ;;
+ ;;; Lexical Tables
+ ;;
+ ;; There are tables of different symbols managed in semantic-lex.el.
+ ;; They are:
+ ;;
+ ;; Lexical keyword table - A Table of symbols declared in a grammar
+ ;; file with the %keyword declaration.
+ ;; Keywords are used by `semantic-lex-symbol-or-keyword'
+ ;; to create lexical tokens based on the keyword.
+ ;;
+ ;; Lexical type table - A table of symbols declared in a grammer
+ ;; file with the %type declaration.
+ ;; The grammar compiler uses the type table to create new
+ ;; lexical analyzers. These analyzers are then used to when
+ ;; a new lexical analyzer is made for a language.
+ ;;
+ ;;; Lexical Types
+ ;;
+ ;; A lexical type defines a kind of lexical analyzer that will be
+ ;; automatically generated from a grammar file based on some
+ ;; predetermined attributes. For now these two attributes are
+ ;; recognized :
+ ;;
+ ;; * matchdatatype : define the kind of lexical analyzer. That is :
+ ;;
+ ;; - regexp : define a regexp analyzer (see
+ ;; `define-lex-regex-type-analyzer')
+ ;;
+ ;; - string : define a string analyzer (see
+ ;; `define-lex-string-type-analyzer')
+ ;;
+ ;; - block : define a block type analyzer (see
+ ;; `define-lex-block-type-analyzer')
+ ;;
+ ;; - sexp : define a sexp analyzer (see
+ ;; `define-lex-sexp-type-analyzer')
+ ;;
+ ;; - keyword : define a keyword analyzer (see
+ ;; `define-lex-keyword-type-analyzer')
+ ;;
+ ;; * syntax : define the syntax that matches a syntactic
+ ;; expression. When syntax is matched the corresponding type
+ ;; analyzer is entered and the resulting match data will be
+ ;; interpreted based on the kind of analyzer (see matchdatatype
+ ;; above).
+ ;;
+ ;; The following lexical types are predefined :
+ ;;
+ ;; +-------------+---------------+--------------------------------+
+ ;; | type | matchdatatype | syntax |
+ ;; +-------------+---------------+--------------------------------+
+ ;; | punctuation | string | "\\(\\s.\\|\\s$\\|\\s'\\)+" |
+ ;; | keyword | keyword | "\\(\\sw\\|\\s_\\)+" |
+ ;; | symbol | regexp | "\\(\\sw\\|\\s_\\)+" |
+ ;; | string | sexp | "\\s\"" |
+ ;; | number | regexp | semantic-lex-number-expression |
+ ;; | block | block | "\\s(\\|\\s)" |
+ ;; +-------------+---------------+--------------------------------+
+ ;;
+ ;; In a grammar you must use a %type expression to automatically generate
+ ;; the corresponding analyzers of that type.
+ ;;
+ ;; Here is an example to auto-generate punctuation analyzers
+ ;; with 'matchdatatype and 'syntax predefined (see table above)
+ ;;
+ ;; %type <punctuation> ;; will auto-generate this kind of analyzers
+ ;;
+ ;; It is equivalent to write :
+ ;;
+ ;; %type <punctuation> syntax "\\(\\s.\\|\\s$\\|\\s'\\)+" matchdatatype string
+ ;;
+ ;; ;; Some punctuations based on the type defines above
+ ;;
+ ;; %token <punctuation> NOT "!"
+ ;; %token <punctuation> NOTEQ "!="
+ ;; %token <punctuation> MOD "%"
+ ;; %token <punctuation> MODEQ "%="
+ ;;
+
+ ;;; On the Semantic 1.x lexer
+ ;;
+ ;; In semantic 1.x, the lexical analyzer was an all purpose routine.
+ ;; To boost efficiency, the analyzer is now a series of routines that
+ ;; are constructed at build time into a single routine. This will
+ ;; eliminate unneeded if statements to speed the lexer.
+
+ (require 'semantic/fw)
++
+ ;;; Code:
+
-;;; Compatibility
-;;
-(eval-and-compile
- (if (not (fboundp 'with-syntax-table))
-
-;; Copied from Emacs 21 for compatibility with released Emacses.
-(defmacro with-syntax-table (table &rest body)
- "With syntax table of current buffer set to a copy of TABLE, evaluate BODY.
-The syntax table of the current buffer is saved, BODY is evaluated, and the
-saved table is restored, even in case of an abnormal exit.
-Value is what BODY returns."
- (let ((old-table (make-symbol "table"))
- (old-buffer (make-symbol "buffer")))
- `(let ((,old-table (syntax-table))
- (,old-buffer (current-buffer)))
- (unwind-protect
- (progn
- (set-syntax-table (copy-syntax-table ,table))
- ,@body)
- (save-current-buffer
- (set-buffer ,old-buffer)
- (set-syntax-table ,old-table))))))
-
-))
-\f
+ ;;; Semantic 2.x lexical analysis
+ ;;
+ (defun semantic-lex-map-symbols (fun table &optional property)
+ "Call function FUN on every symbol in TABLE.
+ If optional PROPERTY is non-nil, call FUN only on every symbol which
+ as a PROPERTY value. FUN receives a symbol as argument."
+ (if (arrayp table)
+ (mapatoms
+ #'(lambda (symbol)
+ (if (or (null property) (get symbol property))
+ (funcall fun symbol)))
+ table)))
+
+ ;;; Lexical keyword table handling.
+ ;;
+ ;; These keywords are keywords defined for using in a grammar with the
+ ;; %keyword declaration, and are not keywords used in Emacs Lisp.
+
+ (defvar semantic-flex-keywords-obarray nil
+ "Buffer local keyword obarray for the lexical analyzer.
+ These keywords are matched explicitly, and converted into special symbols.")
+ (make-variable-buffer-local 'semantic-flex-keywords-obarray)
+
+ (defmacro semantic-lex-keyword-invalid (name)
+ "Signal that NAME is an invalid keyword name."
+ `(signal 'wrong-type-argument '(semantic-lex-keyword-p ,name)))
+
+ (defsubst semantic-lex-keyword-symbol (name)
+ "Return keyword symbol with NAME or nil if not found."
+ (and (arrayp semantic-flex-keywords-obarray)
+ (stringp name)
+ (intern-soft name semantic-flex-keywords-obarray)))
+
+ (defsubst semantic-lex-keyword-p (name)
+ "Return non-nil if a keyword with NAME exists in the keyword table.
+ Return nil otherwise."
+ (and (setq name (semantic-lex-keyword-symbol name))
+ (symbol-value name)))
+
+ (defsubst semantic-lex-keyword-set (name value)
+ "Set value of keyword with NAME to VALUE and return VALUE."
+ (set (intern name semantic-flex-keywords-obarray) value))
+
+ (defsubst semantic-lex-keyword-value (name)
+ "Return value of keyword with NAME.
+ Signal an error if a keyword with NAME does not exist."
+ (let ((keyword (semantic-lex-keyword-symbol name)))
+ (if keyword
+ (symbol-value keyword)
+ (semantic-lex-keyword-invalid name))))
+
+ (defsubst semantic-lex-keyword-put (name property value)
+ "For keyword with NAME, set its PROPERTY to VALUE."
+ (let ((keyword (semantic-lex-keyword-symbol name)))
+ (if keyword
+ (put keyword property value)
+ (semantic-lex-keyword-invalid name))))
+
+ (defsubst semantic-lex-keyword-get (name property)
+ "For keyword with NAME, return its PROPERTY value."
+ (let ((keyword (semantic-lex-keyword-symbol name)))
+ (if keyword
+ (get keyword property)
+ (semantic-lex-keyword-invalid name))))
+
+ (defun semantic-lex-make-keyword-table (specs &optional propspecs)
+ "Convert keyword SPECS into an obarray and return it.
+ SPECS must be a list of (NAME . TOKSYM) elements, where:
+
+ NAME is the name of the keyword symbol to define.
+ TOKSYM is the lexical token symbol of that keyword.
+
+ If optional argument PROPSPECS is non nil, then interpret it, and
+ apply those properties.
+ PROPSPECS must be a list of (NAME PROPERTY VALUE) elements."
+ ;; Create the symbol hash table
+ (let ((semantic-flex-keywords-obarray (make-vector 13 0))
+ spec)
+ ;; fill it with stuff
+ (while specs
+ (setq spec (car specs)
+ specs (cdr specs))
+ (semantic-lex-keyword-set (car spec) (cdr spec)))
+ ;; Apply all properties
+ (while propspecs
+ (setq spec (car propspecs)
+ propspecs (cdr propspecs))
+ (semantic-lex-keyword-put (car spec) (nth 1 spec) (nth 2 spec)))
+ semantic-flex-keywords-obarray))
+
+ (defsubst semantic-lex-map-keywords (fun &optional property)
+ "Call function FUN on every lexical keyword.
+ If optional PROPERTY is non-nil, call FUN only on every keyword which
+ as a PROPERTY value. FUN receives a lexical keyword as argument."
+ (semantic-lex-map-symbols
+ fun semantic-flex-keywords-obarray property))
+
+ (defun semantic-lex-keywords (&optional property)
+ "Return a list of lexical keywords.
+ If optional PROPERTY is non-nil, return only keywords which have a
+ PROPERTY set."
+ (let (keywords)
+ (semantic-lex-map-keywords
+ #'(lambda (symbol) (setq keywords (cons symbol keywords)))
+ property)
+ keywords))
+
+ ;;; Inline functions:
+
+ (defvar semantic-lex-unterminated-syntax-end-function)
+ (defvar semantic-lex-analysis-bounds)
+ (defvar semantic-lex-end-point)
+
+ (defsubst semantic-lex-token-bounds (token)
+ "Fetch the start and end locations of the lexical token TOKEN.
+ Return a pair (START . END)."
+ (if (not (numberp (car (cdr token))))
+ (cdr (cdr token))
+ (cdr token)))
+
+ (defsubst semantic-lex-token-start (token)
+ "Fetch the start position of the lexical token TOKEN.
+ See also the function `semantic-lex-token'."
+ (car (semantic-lex-token-bounds token)))
+
+ (defsubst semantic-lex-token-end (token)
+ "Fetch the end position of the lexical token TOKEN.
+ See also the function `semantic-lex-token'."
+ (cdr (semantic-lex-token-bounds token)))
+
+ (defsubst semantic-lex-unterminated-syntax-detected (syntax)
+ "Inside a lexical analyzer, use this when unterminated syntax was found.
+ Argument SYNTAX indicates the type of syntax that is unterminated.
+ The job of this function is to move (point) to a new logical location
+ so that analysis can continue, if possible."
+ (goto-char
+ (funcall semantic-lex-unterminated-syntax-end-function
+ syntax
+ (car semantic-lex-analysis-bounds)
+ (cdr semantic-lex-analysis-bounds)
+ ))
+ (setq semantic-lex-end-point (point)))
+ \f
+ ;;; Type table handling.
+ ;;
+ ;; The lexical type table manages types that occur in a grammar file
+ ;; with the %type declaration. Types represent different syntaxes.
+ ;; See code for `semantic-lex-preset-default-types' for the classic
+ ;; types of syntax.
+ (defvar semantic-lex-types-obarray nil
+ "Buffer local types obarray for the lexical analyzer.")
+ (make-variable-buffer-local 'semantic-lex-types-obarray)
+
+ (defmacro semantic-lex-type-invalid (type)
+ "Signal that TYPE is an invalid lexical type name."
+ `(signal 'wrong-type-argument '(semantic-lex-type-p ,type)))
+
+ (defsubst semantic-lex-type-symbol (type)
+ "Return symbol with TYPE or nil if not found."
+ (and (arrayp semantic-lex-types-obarray)
+ (stringp type)
+ (intern-soft type semantic-lex-types-obarray)))
+
+ (defsubst semantic-lex-type-p (type)
+ "Return non-nil if a symbol with TYPE name exists."
+ (and (setq type (semantic-lex-type-symbol type))
+ (symbol-value type)))
+
+ (defsubst semantic-lex-type-set (type value)
+ "Set value of symbol with TYPE name to VALUE and return VALUE."
+ (set (intern type semantic-lex-types-obarray) value))
+
+ (defsubst semantic-lex-type-value (type &optional noerror)
+ "Return value of symbol with TYPE name.
+ If optional argument NOERROR is non-nil return nil if a symbol with
+ TYPE name does not exist. Otherwise signal an error."
+ (let ((sym (semantic-lex-type-symbol type)))
+ (if sym
+ (symbol-value sym)
+ (unless noerror
+ (semantic-lex-type-invalid type)))))
+
+ (defsubst semantic-lex-type-put (type property value &optional add)
+ "For symbol with TYPE name, set its PROPERTY to VALUE.
+ If optional argument ADD is non-nil, create a new symbol with TYPE
+ name if it does not already exist. Otherwise signal an error."
+ (let ((sym (semantic-lex-type-symbol type)))
+ (unless sym
+ (or add (semantic-lex-type-invalid type))
+ (semantic-lex-type-set type nil)
+ (setq sym (semantic-lex-type-symbol type)))
+ (put sym property value)))
+
+ (defsubst semantic-lex-type-get (type property &optional noerror)
+ "For symbol with TYPE name, return its PROPERTY value.
+ If optional argument NOERROR is non-nil return nil if a symbol with
+ TYPE name does not exist. Otherwise signal an error."
+ (let ((sym (semantic-lex-type-symbol type)))
+ (if sym
+ (get sym property)
+ (unless noerror
+ (semantic-lex-type-invalid type)))))
+
+ (defun semantic-lex-preset-default-types ()
+ "Install useful default properties for well known types."
+ (semantic-lex-type-put "punctuation" 'matchdatatype 'string t)
+ (semantic-lex-type-put "punctuation" 'syntax "\\(\\s.\\|\\s$\\|\\s'\\)+")
+ (semantic-lex-type-put "keyword" 'matchdatatype 'keyword t)
+ (semantic-lex-type-put "keyword" 'syntax "\\(\\sw\\|\\s_\\)+")
+ (semantic-lex-type-put "symbol" 'matchdatatype 'regexp t)
+ (semantic-lex-type-put "symbol" 'syntax "\\(\\sw\\|\\s_\\)+")
+ (semantic-lex-type-put "string" 'matchdatatype 'sexp t)
+ (semantic-lex-type-put "string" 'syntax "\\s\"")
+ (semantic-lex-type-put "number" 'matchdatatype 'regexp t)
+ (semantic-lex-type-put "number" 'syntax 'semantic-lex-number-expression)
+ (semantic-lex-type-put "block" 'matchdatatype 'block t)
+ (semantic-lex-type-put "block" 'syntax "\\s(\\|\\s)")
+ )
+
+ (defun semantic-lex-make-type-table (specs &optional propspecs)
+ "Convert type SPECS into an obarray and return it.
+ SPECS must be a list of (TYPE . TOKENS) elements, where:
+
+ TYPE is the name of the type symbol to define.
+ TOKENS is an list of (TOKSYM . MATCHER) elements, where:
+
+ TOKSYM is any lexical token symbol.
+ MATCHER is a string or regexp a text must match to be a such
+ lexical token.
+
+ If optional argument PROPSPECS is non nil, then interpret it, and
+ apply those properties.
+ PROPSPECS must be a list of (TYPE PROPERTY VALUE)."
+ ;; Create the symbol hash table
+ (let* ((semantic-lex-types-obarray (make-vector 13 0))
+ spec type tokens token alist default)
+ ;; fill it with stuff
+ (while specs
+ (setq spec (car specs)
+ specs (cdr specs)
+ type (car spec)
+ tokens (cdr spec)
+ default nil
+ alist nil)
+ (while tokens
+ (setq token (car tokens)
+ tokens (cdr tokens))
+ (if (cdr token)
+ (setq alist (cons token alist))
+ (setq token (car token))
+ (if default
+ (message
+ "*Warning* default value of <%s> tokens changed to %S, was %S"
+ type default token))
+ (setq default token)))
+ ;; Ensure the default matching spec is the first one.
+ (semantic-lex-type-set type (cons default (nreverse alist))))
+ ;; Install useful default types & properties
+ (semantic-lex-preset-default-types)
+ ;; Apply all properties
+ (while propspecs
+ (setq spec (car propspecs)
+ propspecs (cdr propspecs))
+ ;; Create the type if necessary.
+ (semantic-lex-type-put (car spec) (nth 1 spec) (nth 2 spec) t))
+ semantic-lex-types-obarray))
+
+ (defsubst semantic-lex-map-types (fun &optional property)
+ "Call function FUN on every lexical type.
+ If optional PROPERTY is non-nil, call FUN only on every type symbol
+ which as a PROPERTY value. FUN receives a type symbol as argument."
+ (semantic-lex-map-symbols
+ fun semantic-lex-types-obarray property))
+
+ (defun semantic-lex-types (&optional property)
+ "Return a list of lexical type symbols.
+ If optional PROPERTY is non-nil, return only type symbols which have
+ PROPERTY set."
+ (let (types)
+ (semantic-lex-map-types
+ #'(lambda (symbol) (setq types (cons symbol types)))
+ property)
+ types))
+ \f
+ ;;; Lexical Analyzer framework settings
+ ;;
+
+ (defvar semantic-lex-analyzer 'semantic-flex
+ "The lexical analyzer used for a given buffer.
+ See `semantic-lex' for documentation.
+ For compatibility with Semantic 1.x it defaults to `semantic-flex'.")
+ (make-variable-buffer-local 'semantic-lex-analyzer)
+
+ (defvar semantic-lex-tokens
+ '(
+ (bol)
+ (charquote)
+ (close-paren)
+ (comment)
+ (newline)
+ (open-paren)
+ (punctuation)
+ (semantic-list)
+ (string)
+ (symbol)
+ (whitespace)
+ )
+ "An alist of of semantic token types.
+ As of December 2001 (semantic 1.4beta13), this variable is not used in
+ any code. The only use is to refer to the doc-string from elsewhere.
+
+ The key to this alist is the symbol representing token type that
+ \\[semantic-flex] returns. These are
+
+ - bol: Empty string matching a beginning of line.
+ This token is produced with
+ `semantic-lex-beginning-of-line'.
+
+ - charquote: String sequences that match `\\s\\+' regexp.
+ This token is produced with `semantic-lex-charquote'.
+
+ - close-paren: Characters that match `\\s)' regexp.
+ These are typically `)', `}', `]', etc.
+ This token is produced with
+ `semantic-lex-close-paren'.
+
+ - comment: A comment chunk. These token types are not
+ produced by default.
+ This token is produced with `semantic-lex-comments'.
+ Comments are ignored with `semantic-lex-ignore-comments'.
+ Comments are treated as whitespace with
+ `semantic-lex-comments-as-whitespace'.
+
+ - newline Characters matching `\\s-*\\(\n\\|\\s>\\)' regexp.
+ This token is produced with `semantic-lex-newline'.
+
+ - open-paren: Characters that match `\\s(' regexp.
+ These are typically `(', `{', `[', etc.
+ If `semantic-lex-paren-or-list' is used,
+ then `open-paren' is not usually generated unless
+ the `depth' argument to \\[semantic-lex] is
+ greater than 0.
+ This token is always produced if the analyzer
+ `semantic-lex-open-paren' is used.
+
+ - punctuation: Characters matching `{\\(\\s.\\|\\s$\\|\\s'\\)'
+ regexp.
+ This token is produced with `semantic-lex-punctuation'.
+ Always specify this analyzer after the comment
+ analyzer.
+
+ - semantic-list: String delimited by matching parenthesis, braces,
+ etc. that the lexer skipped over, because the
+ `depth' parameter to \\[semantic-flex] was not high
+ enough.
+ This token is produced with `semantic-lex-paren-or-list'.
+
+ - string: Quoted strings, i.e., string sequences that start
+ and end with characters matching `\\s\"'
+ regexp. The lexer relies on @code{forward-sexp} to
+ find the matching end.
+ This token is produced with `semantic-lex-string'.
+
+ - symbol: String sequences that match `\\(\\sw\\|\\s_\\)+'
+ regexp.
+ This token is produced with
+ `semantic-lex-symbol-or-keyword'. Always add this analyzer
+ after `semantic-lex-number', or other analyzers that
+ match its regular expression.
+
+ - whitespace: Characters that match `\\s-+' regexp.
+ This token is produced with `semantic-lex-whitespace'.")
+
+ (defvar semantic-lex-syntax-modifications nil
+ "Changes to the syntax table for this buffer.
+ These changes are active only while the buffer is being flexed.
+ This is a list where each element has the form:
+ (CHAR CLASS)
+ CHAR is the char passed to `modify-syntax-entry',
+ and CLASS is the string also passed to `modify-syntax-entry' to define
+ what syntax class CHAR has.")
+ (make-variable-buffer-local 'semantic-lex-syntax-modifications)
+
+ (defvar semantic-lex-syntax-table nil
+ "Syntax table used by lexical analysis.
+ See also `semantic-lex-syntax-modifications'.")
+ (make-variable-buffer-local 'semantic-lex-syntax-table)
+
+ (defvar semantic-lex-comment-regex nil
+ "Regular expression for identifying comment start during lexical analysis.
+ This may be automatically set when semantic initializes in a mode, but
+ may need to be overriden for some special languages.")
+ (make-variable-buffer-local 'semantic-lex-comment-regex)
+
+ (defvar semantic-lex-number-expression
+ ;; This expression was written by David Ponce for Java, and copied
+ ;; here for C and any other similar language.
+ (eval-when-compile
+ (concat "\\("
+ "\\<[0-9]+[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>"
+ "\\|"
+ "\\<[0-9]+[.][eE][-+]?[0-9]+[fFdD]?\\>"
+ "\\|"
+ "\\<[0-9]+[.][fFdD]\\>"
+ "\\|"
+ "\\<[0-9]+[.]"
+ "\\|"
+ "[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>"
+ "\\|"
+ "\\<[0-9]+[eE][-+]?[0-9]+[fFdD]?\\>"
+ "\\|"
+ "\\<0[xX][0-9a-fA-F]+[lL]?\\>"
+ "\\|"
+ "\\<[0-9]+[lLfFdD]?\\>"
+ "\\)"
+ ))
+ "Regular expression for matching a number.
+ If this value is nil, no number extraction is done during lex.
+ This expression tries to match C and Java like numbers.
+
+ DECIMAL_LITERAL:
+ [1-9][0-9]*
+ ;
+ HEX_LITERAL:
+ 0[xX][0-9a-fA-F]+
+ ;
+ OCTAL_LITERAL:
+ 0[0-7]*
+ ;
+ INTEGER_LITERAL:
+ <DECIMAL_LITERAL>[lL]?
+ | <HEX_LITERAL>[lL]?
+ | <OCTAL_LITERAL>[lL]?
+ ;
+ EXPONENT:
+ [eE][+-]?[09]+
+ ;
+ FLOATING_POINT_LITERAL:
+ [0-9]+[.][0-9]*<EXPONENT>?[fFdD]?
+ | [.][0-9]+<EXPONENT>?[fFdD]?
+ | [0-9]+<EXPONENT>[fFdD]?
+ | [0-9]+<EXPONENT>?[fFdD]
+ ;")
+ (make-variable-buffer-local 'semantic-lex-number-expression)
+
+ (defvar semantic-lex-depth 0
+ "Default lexing depth.
+ This specifies how many lists to create tokens in.")
+ (make-variable-buffer-local 'semantic-lex-depth)
+
+ (defvar semantic-lex-unterminated-syntax-end-function
+ (lambda (syntax syntax-start lex-end) lex-end)
+ "Function called when unterminated syntax is encountered.
+ This should be set to one function. That function should take three
+ parameters. The SYNTAX, or type of syntax which is unterminated.
+ SYNTAX-START where the broken syntax begins.
+ LEX-END is where the lexical analysis was asked to end.
+ This function can be used for languages that can intelligently fix up
+ broken syntax, or the exit lexical analysis via `throw' or `signal'
+ when finding unterminated syntax.")
+
+ ;;; Interactive testing commands
+
+ (declare-function semantic-elapsed-time "semantic")
+
+ (defun semantic-lex-test (arg)
+ "Test the semantic lexer in the current buffer.
+ If universal argument ARG, then try the whole buffer."
+ (interactive "P")
+ (require 'semantic)
+ (let* ((start (current-time))
+ (result (semantic-lex
+ (if arg (point-min) (point))
+ (point-max)))
+ (end (current-time)))
+ (message "Elapsed Time: %.2f seconds."
+ (semantic-elapsed-time start end))
+ (pop-to-buffer "*Lexer Output*")
+ (require 'pp)
+ (erase-buffer)
+ (insert (pp-to-string result))
+ (goto-char (point-min))
+ ))
+
+ (defvar semantic-lex-debug nil
+ "When non-nil, debug the local lexical analyzer.")
+
+ (defun semantic-lex-debug (arg)
+ "Debug the semantic lexer in the current buffer.
+ Argument ARG specifies of the analyze the whole buffer, or start at point.
+ While engaged, each token identified by the lexer will be highlighted
+ in the target buffer A description of the current token will be
+ displayed in the minibuffer. Press SPC to move to the next lexical token."
+ (interactive "P")
+ (require 'semantic/debug)
+ (let ((semantic-lex-debug t))
+ (semantic-lex-test arg)))
+
+ (defun semantic-lex-highlight-token (token)
+ "Highlight the lexical TOKEN.
+ TOKEN is a lexical token with a START And END position.
+ Return the overlay."
+ (let ((o (semantic-make-overlay (semantic-lex-token-start token)
+ (semantic-lex-token-end token))))
+ (semantic-overlay-put o 'face 'highlight)
+ o))
+
+ (defsubst semantic-lex-debug-break (token)
+ "Break during lexical analysis at TOKEN."
+ (when semantic-lex-debug
+ (let ((o nil))
+ (unwind-protect
+ (progn
+ (when token
+ (setq o (semantic-lex-highlight-token token)))
+ (semantic-read-event
+ (format "%S :: SPC - continue" token))
+ )
+ (when o
+ (semantic-overlay-delete o))))))
+
+ ;;; Lexical analyzer creation
+ ;;
+ ;; Code for creating a lex function from lists of analyzers.
+ ;;
+ ;; A lexical analyzer is created from a list of individual analyzers.
+ ;; Each individual analyzer specifies a single match, and code that
+ ;; goes with it.
+ ;;
+ ;; Creation of an analyzer assembles these analyzers into a new function
+ ;; with the behaviors of all the individual analyzers.
+ ;;
+ (defmacro semantic-lex-one-token (analyzers)
+ "Calculate one token from the current buffer at point.
+ Uses locally bound variables from `define-lex'.
+ Argument ANALYZERS is the list of analyzers being used."
+ (cons 'cond (mapcar #'symbol-value analyzers)))
+
+ (defvar semantic-lex-end-point nil
+ "The end point as tracked through lexical functions.")
+
+ (defvar semantic-lex-current-depth nil
+ "The current depth as tracked through lexical functions.")
+
+ (defvar semantic-lex-maximum-depth nil
+ "The maximum depth of parenthisis as tracked through lexical functions.")
+
+ (defvar semantic-lex-token-stream nil
+ "The current token stream we are collecting.")
+
+ (defvar semantic-lex-analysis-bounds nil
+ "The bounds of the current analysis.")
+
+ (defvar semantic-lex-block-streams nil
+ "Streams of tokens inside collapsed blocks.
+ This is an alist of (ANCHOR . STREAM) elements where ANCHOR is the
+ start position of the block, and STREAM is the list of tokens in that
+ block.")
+
+ (defvar semantic-lex-reset-hooks nil
+ "Abnormal hook used by major-modes to reset lexical analyzers.
+ Hook functions are called with START and END values for the
+ current lexical pass. Should be set with `add-hook', specifying
+ a LOCAL option.")
+
+ ;; Stack of nested blocks.
+ (defvar semantic-lex-block-stack nil)
+ ;;(defvar semantic-lex-timeout 5
+ ;; "*Number of sections of lexing before giving up.")
+
+ (defmacro define-lex (name doc &rest analyzers)
+ "Create a new lexical analyzer with NAME.
+ DOC is a documentation string describing this analyzer.
+ ANALYZERS are small code snippets of analyzers to use when
+ building the new NAMED analyzer. Only use analyzers which
+ are written to be used in `define-lex'.
+ Each analyzer should be an analyzer created with `define-lex-analyzer'.
+ Note: The order in which analyzers are listed is important.
+ If two analyzers can match the same text, it is important to order the
+ analyzers so that the one you want to match first occurs first. For
+ example, it is good to put a numbe analyzer in front of a symbol
+ analyzer which might mistake a number for as a symbol."
+ `(defun ,name (start end &optional depth length)
+ ,(concat doc "\nSee `semantic-lex' for more information.")
+ ;; Make sure the state of block parsing starts over.
+ (setq semantic-lex-block-streams nil)
+ ;; Allow specialty reset items.
+ (run-hook-with-args 'semantic-lex-reset-hooks start end)
+ ;; Lexing state.
+ (let* (;(starttime (current-time))
+ (starting-position (point))
+ (semantic-lex-token-stream nil)
+ (semantic-lex-block-stack nil)
+ (tmp-start start)
+ (semantic-lex-end-point start)
+ (semantic-lex-current-depth 0)
+ ;; Use the default depth when not specified.
+ (semantic-lex-maximum-depth
+ (or depth semantic-lex-depth))
+ ;; Bounds needed for unterminated syntax
+ (semantic-lex-analysis-bounds (cons start end))
+ ;; This entry prevents text properties from
+ ;; confusing our lexical analysis. See Emacs 22 (CVS)
+ ;; version of C++ mode with template hack text properties.
+ (parse-sexp-lookup-properties nil)
+ )
+ ;; Maybe REMOVE THIS LATER.
+ ;; Trying to find incremental parser bug.
+ (when (> end (point-max))
+ (error ,(format "%s: end (%%d) > point-max (%%d)" name)
+ end (point-max)))
+ (with-syntax-table semantic-lex-syntax-table
+ (goto-char start)
+ (while (and (< (point) end)
+ (or (not length)
+ (<= (length semantic-lex-token-stream) length)))
+ (semantic-lex-one-token ,analyzers)
+ (when (eq semantic-lex-end-point tmp-start)
+ (error ,(format "%s: endless loop at %%d, after %%S" name)
+ tmp-start (car semantic-lex-token-stream)))
+ (setq tmp-start semantic-lex-end-point)
+ (goto-char semantic-lex-end-point)
+ ;;(when (> (semantic-elapsed-time starttime (current-time))
+ ;; semantic-lex-timeout)
+ ;; (error "Timeout during lex at char %d" (point)))
+ (semantic-throw-on-input 'lex)
+ (semantic-lex-debug-break (car semantic-lex-token-stream))
+ ))
+ ;; Check that there is no unterminated block.
+ (when semantic-lex-block-stack
+ (let* ((last (pop semantic-lex-block-stack))
+ (blk last))
+ (while blk
+ (message
+ ,(format "%s: `%%s' block from %%S is unterminated" name)
+ (car blk) (cadr blk))
+ (setq blk (pop semantic-lex-block-stack)))
+ (semantic-lex-unterminated-syntax-detected (car last))))
+ ;; Return to where we started.
+ ;; Do not wrap in protective stuff so that if there is an error
+ ;; thrown, the user knows where.
+ (goto-char starting-position)
+ ;; Return the token stream
+ (nreverse semantic-lex-token-stream))))
+ \f
+ ;;; Collapsed block tokens delimited by any tokens.
+ ;;
+ (defun semantic-lex-start-block (syntax)
+ "Mark the last read token as the beginning of a SYNTAX block."
+ (if (or (not semantic-lex-maximum-depth)
+ (< semantic-lex-current-depth semantic-lex-maximum-depth))
+ (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
+ (push (list syntax (car semantic-lex-token-stream))
+ semantic-lex-block-stack)))
+
+ (defun semantic-lex-end-block (syntax)
+ "Process the end of a previously marked SYNTAX block.
+ That is, collapse the tokens inside that block, including the
+ beginning and end of block tokens, into a high level block token of
+ class SYNTAX.
+ The token at beginning of block is the one marked by a previous call
+ to `semantic-lex-start-block'. The current token is the end of block.
+ The collapsed tokens are saved in `semantic-lex-block-streams'."
+ (if (null semantic-lex-block-stack)
+ (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
+ (let* ((stream semantic-lex-token-stream)
+ (blk (pop semantic-lex-block-stack))
+ (bstream (cdr blk))
+ (first (car bstream))
+ (last (pop stream)) ;; The current token mark the EOBLK
+ tok)
+ (if (not (eq (car blk) syntax))
+ ;; SYNTAX doesn't match the syntax of the current block in
+ ;; the stack. So we encountered the end of the SYNTAX block
+ ;; before the end of the current one in the stack which is
+ ;; signaled unterminated.
+ (semantic-lex-unterminated-syntax-detected (car blk))
+ ;; Move tokens found inside the block from the main stream
+ ;; into a separate block stream.
+ (while (and stream (not (eq (setq tok (pop stream)) first)))
+ (push tok bstream))
+ ;; The token marked as beginning of block was not encountered.
+ ;; This should not happen!
+ (or (eq tok first)
+ (error "Token %S not found at beginning of block `%s'"
+ first syntax))
+ ;; Save the block stream for future reuse, to avoid to redo
+ ;; the lexical analysis of the block content!
+ ;; Anchor the block stream with its start position, so we can
+ ;; use: (cdr (assq start semantic-lex-block-streams)) to
+ ;; quickly retrieve the lexical stream associated to a block.
+ (setcar blk (semantic-lex-token-start first))
+ (setcdr blk (nreverse bstream))
+ (push blk semantic-lex-block-streams)
+ ;; In the main stream, replace the tokens inside the block by
+ ;; a high level block token of class SYNTAX.
+ (setq semantic-lex-token-stream stream)
+ (semantic-lex-push-token
+ (semantic-lex-token
+ syntax (car blk) (semantic-lex-token-end last)))
+ ))))
+ \f
+ ;;; Lexical token API
+ ;;
+ ;; Functions for accessing parts of a token. Use these functions
+ ;; instead of accessing the list structure directly because the
+ ;; contents of the lexical may change.
+ ;;
+ (defmacro semantic-lex-token (symbol start end &optional str)
+ "Create a lexical token.
+ SYMBOL is a symbol representing the class of syntax found.
+ START and END define the bounds of the token in the current buffer.
+ Optional STR is the string for the token iff the the bounds
+ in the buffer do not cover the string they represent. (As from
+ macro expansion.)"
+ ;; This if statement checks the existance of a STR argument at
+ ;; compile time, where STR is some symbol or constant. If the
+ ;; variable STr (runtime) is nil, this will make an incorrect decision.
+ ;;
+ ;; It is like this to maintain the original speed of the compiled
+ ;; code.
+ (if str
+ `(cons ,symbol (cons ,str (cons ,start ,end)))
+ `(cons ,symbol (cons ,start ,end))))
+
+ (defun semantic-lex-token-p (thing)
+ "Return non-nil if THING is a semantic lex token.
+ This is an exhaustively robust check."
+ (and (consp thing)
+ (symbolp (car thing))
+ (or (and (numberp (nth 1 thing))
+ (numberp (nthcdr 2 thing)))
+ (and (stringp (nth 1 thing))
+ (numberp (nth 2 thing))
+ (numberp (nthcdr 3 thing)))
+ ))
+ )
+
+ (defun semantic-lex-token-with-text-p (thing)
+ "Return non-nil if THING is a semantic lex token.
+ This is an exhaustively robust check."
+ (and (consp thing)
+ (symbolp (car thing))
+ (= (length thing) 4)
+ (stringp (nth 1 thing))
+ (numberp (nth 2 thing))
+ (numberp (nth 3 thing)))
+ )
+
+ (defun semantic-lex-token-without-text-p (thing)
+ "Return non-nil if THING is a semantic lex token.
+ This is an exhaustively robust check."
+ (and (consp thing)
+ (symbolp (car thing))
+ (= (length thing) 3)
+ (numberp (nth 1 thing))
+ (numberp (nth 2 thing)))
+ )
+
+ (eval-and-compile
+
+ (defun semantic-lex-expand-block-specs (specs)
+ "Expand block specifications SPECS into a Lisp form.
+ SPECS is a list of (BLOCK BEGIN END) elements where BLOCK, BEGIN, and
+ END are token class symbols that indicate to produce one collapsed
+ BLOCK token from tokens found between BEGIN and END ones.
+ BLOCK must be a non-nil symbol, and at least one of the BEGIN or END
+ symbols must be non-nil too.
+ When BEGIN is non-nil, generate a call to `semantic-lex-start-block'
+ when a BEGIN token class is encountered.
+ When END is non-nil, generate a call to `semantic-lex-end-block' when
+ an END token class is encountered."
+ (let ((class (make-symbol "class"))
+ (form nil))
+ (dolist (spec specs)
+ (when (car spec)
+ (when (nth 1 spec)
+ (push `((eq ',(nth 1 spec) ,class)
+ (semantic-lex-start-block ',(car spec)))
+ form))
+ (when (nth 2 spec)
+ (push `((eq ',(nth 2 spec) ,class)
+ (semantic-lex-end-block ',(car spec)))
+ form))))
+ (when form
+ `((let ((,class (semantic-lex-token-class
+ (car semantic-lex-token-stream))))
+ (cond ,@(nreverse form))))
+ )))
+ )
+
+ (defmacro semantic-lex-push-token (token &rest blockspecs)
+ "Push TOKEN in the lexical analyzer token stream.
+ Return the lexical analysis current end point.
+ If optional arguments BLOCKSPECS is non-nil, it specifies to process
+ collapsed block tokens. See `semantic-lex-expand-block-specs' for
+ more details.
+ This macro should only be called within the bounds of
+ `define-lex-analyzer'. It changes the values of the lexical analyzer
+ variables `token-stream' and `semantic-lex-end-point'. If you need to
+ move `semantic-lex-end-point' somewhere else, just modify this
+ variable after calling `semantic-lex-push-token'."
+ `(progn
+ (push ,token semantic-lex-token-stream)
+ ,@(semantic-lex-expand-block-specs blockspecs)
+ (setq semantic-lex-end-point
+ (semantic-lex-token-end (car semantic-lex-token-stream)))
+ ))
+
+ (defsubst semantic-lex-token-class (token)
+ "Fetch the class of the lexical token TOKEN.
+ See also the function `semantic-lex-token'."
+ (car token))
+
+ (defsubst semantic-lex-token-text (token)
+ "Fetch the text associated with the lexical token TOKEN.
+ See also the function `semantic-lex-token'."
+ (if (stringp (car (cdr token)))
+ (car (cdr token))
+ (buffer-substring-no-properties
+ (semantic-lex-token-start token)
+ (semantic-lex-token-end token))))
+
+ (defun semantic-lex-init ()
+ "Initialize any lexical state for this buffer."
+ (unless semantic-lex-comment-regex
+ (setq semantic-lex-comment-regex
+ (if comment-start-skip
+ (concat "\\(\\s<\\|" comment-start-skip "\\)")
+ "\\(\\s<\\)")))
+ ;; Setup the lexer syntax-table
+ (setq semantic-lex-syntax-table (copy-syntax-table (syntax-table)))
+ (dolist (mod semantic-lex-syntax-modifications)
+ (modify-syntax-entry
+ (car mod) (nth 1 mod) semantic-lex-syntax-table)))
+
+ ;;;###autoload
+ (define-overloadable-function semantic-lex (start end &optional depth length)
+ "Lexically analyze text in the current buffer between START and END.
+ Optional argument DEPTH indicates at what level to scan over entire
+ lists. The last argument, LENGTH specifies that `semantic-lex'
+ should only return LENGTH tokens. The return value is a token stream.
+ Each element is a list, such of the form
+ (symbol start-expression . end-expression)
+ where SYMBOL denotes the token type.
+ See `semantic-lex-tokens' variable for details on token types. END
+ does not mark the end of the text scanned, only the end of the
+ beginning of text scanned. Thus, if a string extends past END, the
+ end of the return token will be larger than END. To truly restrict
+ scanning, use `narrow-to-region'."
+ (funcall semantic-lex-analyzer start end depth length))
+
+ (defsubst semantic-lex-buffer (&optional depth)
+ "Lex the current buffer.
+ Optional argument DEPTH is the depth to scan into lists."
+ (semantic-lex (point-min) (point-max) depth))
+
+ (defsubst semantic-lex-list (semlist depth)
+ "Lex the body of SEMLIST to DEPTH."
+ (semantic-lex (semantic-lex-token-start semlist)
+ (semantic-lex-token-end semlist)
+ depth))
+ \f
+ ;;; Analyzer creation macros
+ ;;
+ ;; An individual analyzer is a condition and code that goes with it.
+ ;;
+ ;; Created analyzers become variables with the code associated with them
+ ;; as the symbol value. These analyzers are assembled into a lexer
+ ;; to create new lexical analyzers.
+
+ (defcustom semantic-lex-debug-analyzers nil
+ "Non nil means to debug analyzers with syntax protection.
+ Only in effect if `debug-on-error' is also non-nil."
+ :group 'semantic
+ :type 'boolean)
+
+ (defmacro semantic-lex-unterminated-syntax-protection (syntax &rest forms)
+ "For SYNTAX, execute FORMS with protection for unterminated syntax.
+ If FORMS throws an error, treat this as a syntax problem, and
+ execute the unterminated syntax code. FORMS should return a position.
+ Irreguardless of an error, the cursor should be moved to the end of
+ the desired syntax, and a position returned.
+ If `debug-on-error' is set, errors are not caught, so that you can
+ debug them.
+ Avoid using a large FORMS since it is duplicated."
+ `(if (and debug-on-error semantic-lex-debug-analyzers)
+ (progn ,@forms)
+ (condition-case nil
+ (progn ,@forms)
+ (error
+ (semantic-lex-unterminated-syntax-detected ,syntax)))))
+ (put 'semantic-lex-unterminated-syntax-protection
+ 'lisp-indent-function 1)
+
+ (defmacro define-lex-analyzer (name doc condition &rest forms)
+ "Create a single lexical analyzer NAME with DOC.
+ When an analyzer is called, the current buffer and point are
+ positioned in a buffer at the location to be analyzed.
+ CONDITION is an expression which returns t if FORMS should be run.
+ Within the bounds of CONDITION and FORMS, the use of backquote
+ can be used to evaluate expressions at compile time.
+ While forms are running, the following variables will be locally bound:
+ `semantic-lex-analysis-bounds' - The bounds of the current analysis.
+ of the form (START . END)
+ `semantic-lex-maximum-depth' - The maximum depth of semantic-list
+ for the current analysis.
+ `semantic-lex-current-depth' - The current depth of `semantic-list' that has
+ been decended.
+ `semantic-lex-end-point' - End Point after match.
+ Analyzers should set this to a buffer location if their
+ match string does not represent the end of the matched text.
+ `semantic-lex-token-stream' - The token list being collected.
+ Add new lexical tokens to this list.
+ Proper action in FORMS is to move the value of `semantic-lex-end-point' to
+ after the location of the analyzed entry, and to add any discovered tokens
+ at the beginning of `semantic-lex-token-stream'.
+ This can be done by using `semantic-lex-push-token'."
+ `(eval-and-compile
+ (defvar ,name nil ,doc)
+ (defun ,name nil)
+ ;; Do this part separately so that re-evaluation rebuilds this code.
+ (setq ,name '(,condition ,@forms))
+ ;; Build a single lexical analyzer function, so the doc for
+ ;; function help is automatically provided, and perhaps the
+ ;; function could be useful for testing and debugging one
+ ;; analyzer.
+ (fset ',name (lambda () ,doc
+ (let ((semantic-lex-token-stream nil)
+ (semantic-lex-end-point (point))
+ (semantic-lex-analysis-bounds
+ (cons (point) (point-max)))
+ (semantic-lex-current-depth 0)
+ (semantic-lex-maximum-depth
+ semantic-lex-depth)
+ )
+ (when ,condition ,@forms)
+ semantic-lex-token-stream)))
+ ))
+
+ (defmacro define-lex-regex-analyzer (name doc regexp &rest forms)
+ "Create a lexical analyzer with NAME and DOC that will match REGEXP.
+ FORMS are evaluated upon a successful match.
+ See `define-lex-analyzer' for more about analyzers."
+ `(define-lex-analyzer ,name
+ ,doc
+ (looking-at ,regexp)
+ ,@forms
+ ))
+
+ (defmacro define-lex-simple-regex-analyzer (name doc regexp toksym
+ &optional index
+ &rest forms)
+ "Create a lexical analyzer with NAME and DOC that match REGEXP.
+ TOKSYM is the symbol to use when creating a semantic lexical token.
+ INDEX is the index into the match that defines the bounds of the token.
+ Index should be a plain integer, and not specified in the macro as an
+ expression.
+ FORMS are evaluated upon a successful match BEFORE the new token is
+ created. It is valid to ignore FORMS.
+ See `define-lex-analyzer' for more about analyzers."
+ `(define-lex-analyzer ,name
+ ,doc
+ (looking-at ,regexp)
+ ,@forms
+ (semantic-lex-push-token
+ (semantic-lex-token ,toksym
+ (match-beginning ,(or index 0))
+ (match-end ,(or index 0))))
+ ))
+
+ (defmacro define-lex-block-analyzer (name doc spec1 &rest specs)
+ "Create a lexical analyzer NAME for paired delimiters blocks.
+ It detects a paired delimiters block or the corresponding open or
+ close delimiter depending on the value of the variable
+ `semantic-lex-current-depth'. DOC is the documentation string of the lexical
+ analyzer. SPEC1 and SPECS specify the token symbols and open, close
+ delimiters used. Each SPEC has the form:
+
+ \(BLOCK-SYM (OPEN-DELIM OPEN-SYM) (CLOSE-DELIM CLOSE-SYM))
+
+ where BLOCK-SYM is the symbol returned in a block token. OPEN-DELIM
+ and CLOSE-DELIM are respectively the open and close delimiters
+ identifying a block. OPEN-SYM and CLOSE-SYM are respectively the
+ symbols returned in open and close tokens."
+ (let ((specs (cons spec1 specs))
+ spec open olist clist)
+ (while specs
+ (setq spec (car specs)
+ specs (cdr specs)
+ open (nth 1 spec)
+ ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...)
+ olist (cons (list (car open) (cadr open) (car spec)) olist)
+ ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...)
+ clist (cons (nth 2 spec) clist)))
+ `(define-lex-analyzer ,name
+ ,doc
+ (and
+ (looking-at "\\(\\s(\\|\\s)\\)")
+ (let ((text (match-string 0)) match)
+ (cond
+ ((setq match (assoc text ',olist))
+ (if (or (not semantic-lex-maximum-depth)
+ (< semantic-lex-current-depth semantic-lex-maximum-depth))
+ (progn
+ (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 1 match)
+ (match-beginning 0) (match-end 0))))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 2 match)
+ (match-beginning 0)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection (nth 2 match)
+ (forward-list 1)
+ (point)))
+ ))
+ ))
+ ((setq match (assoc text ',clist))
+ (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 1 match)
+ (match-beginning 0) (match-end 0)))))))
+ )))
+ \f
+ ;;; Analyzers
+ ;;
+ ;; Pre-defined common analyzers.
+ ;;
+ (define-lex-analyzer semantic-lex-default-action
+ "The default action when no other lexical actions match text.
+ This action will just throw an error."
+ t
+ (error "Unmatched Text during Lexical Analysis"))
+
+ (define-lex-analyzer semantic-lex-beginning-of-line
+ "Detect and create a beginning of line token (BOL)."
+ (and (bolp)
+ ;; Just insert a (bol N . N) token in the token stream,
+ ;; without moving the point. N is the point at the
+ ;; beginning of line.
+ (semantic-lex-push-token (semantic-lex-token 'bol (point) (point)))
+ nil) ;; CONTINUE
+ ;; We identify and add the BOL token onto the stream, but since
+ ;; semantic-lex-end-point doesn't move, we always fail CONDITION, and have no
+ ;; FORMS body.
+ nil)
+
+ (define-lex-simple-regex-analyzer semantic-lex-newline
+ "Detect and create newline tokens."
+ "\\s-*\\(\n\\|\\s>\\)" 'newline 1)
+
+ (define-lex-regex-analyzer semantic-lex-newline-as-whitespace
+ "Detect and create newline tokens.
+ Use this ONLY if newlines are not whitespace characters (such as when
+ they are comment end characters) AND when you want whitespace tokens."
+ "\\s-*\\(\n\\|\\s>\\)"
+ ;; Language wants whitespaces. Create a token for it.
+ (if (eq (semantic-lex-token-class (car semantic-lex-token-stream))
+ 'whitespace)
+ ;; Merge whitespace tokens together if they are adjacent. Two
+ ;; whitespace tokens may be sperated by a comment which is not in
+ ;; the token stream.
+ (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
+ (match-end 0))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'whitespace (match-beginning 0) (match-end 0)))))
+
+ (define-lex-regex-analyzer semantic-lex-ignore-newline
+ "Detect and ignore newline tokens.
+ Use this ONLY if newlines are not whitespace characters (such as when
+ they are comment end characters)."
+ "\\s-*\\(\n\\|\\s>\\)"
+ (setq semantic-lex-end-point (match-end 0)))
+
+ (define-lex-regex-analyzer semantic-lex-whitespace
+ "Detect and create whitespace tokens."
+ ;; catch whitespace when needed
+ "\\s-+"
+ ;; Language wants whitespaces. Create a token for it.
+ (if (eq (semantic-lex-token-class (car semantic-lex-token-stream))
+ 'whitespace)
+ ;; Merge whitespace tokens together if they are adjacent. Two
+ ;; whitespace tokens may be sperated by a comment which is not in
+ ;; the token stream.
+ (progn
+ (setq semantic-lex-end-point (match-end 0))
+ (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
+ semantic-lex-end-point))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'whitespace (match-beginning 0) (match-end 0)))))
+
+ (define-lex-regex-analyzer semantic-lex-ignore-whitespace
+ "Detect and skip over whitespace tokens."
+ ;; catch whitespace when needed
+ "\\s-+"
+ ;; Skip over the detected whitespace, do not create a token for it.
+ (setq semantic-lex-end-point (match-end 0)))
+
+ (define-lex-simple-regex-analyzer semantic-lex-number
+ "Detect and create number tokens.
+ See `semantic-lex-number-expression' for details on matching numbers,
+ and number formats."
+ semantic-lex-number-expression 'number)
+
+ (define-lex-regex-analyzer semantic-lex-symbol-or-keyword
+ "Detect and create symbol and keyword tokens."
+ "\\(\\sw\\|\\s_\\)+"
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (or (semantic-lex-keyword-p (match-string 0)) 'symbol)
+ (match-beginning 0) (match-end 0))))
+
+ (define-lex-simple-regex-analyzer semantic-lex-charquote
+ "Detect and create charquote tokens."
+ ;; Character quoting characters (ie, \n as newline)
+ "\\s\\+" 'charquote)
+
+ (define-lex-simple-regex-analyzer semantic-lex-punctuation
+ "Detect and create punctuation tokens."
+ "\\(\\s.\\|\\s$\\|\\s'\\)" 'punctuation)
+
+ (define-lex-analyzer semantic-lex-punctuation-type
+ "Detect and create a punctuation type token.
+ Recognized punctuations are defined in the current table of lexical
+ types, as the value of the `punctuation' token type."
+ (and (looking-at "\\(\\s.\\|\\s$\\|\\s'\\)+")
+ (let* ((key (match-string 0))
+ (pos (match-beginning 0))
+ (end (match-end 0))
+ (len (- end pos))
+ (lst (semantic-lex-type-value "punctuation" t))
+ (def (car lst)) ;; default lexical symbol or nil
+ (lst (cdr lst)) ;; alist of (LEX-SYM . PUNCT-STRING)
+ (elt nil))
+ (if lst
+ ;; Starting with the longest one, search if the
+ ;; punctuation string is defined for this language.
+ (while (and (> len 0) (not (setq elt (rassoc key lst))))
+ (setq len (1- len)
+ key (substring key 0 len))))
+ (if elt ;; Return the punctuation token found
+ (semantic-lex-push-token
+ (semantic-lex-token (car elt) pos (+ pos len)))
+ (if def ;; Return a default generic token
+ (semantic-lex-push-token
+ (semantic-lex-token def pos end))
+ ;; Nothing match
+ )))))
+
+ (define-lex-regex-analyzer semantic-lex-paren-or-list
+ "Detect open parenthesis.
+ Return either a paren token or a semantic list token depending on
+ `semantic-lex-current-depth'."
+ "\\s("
+ (if (or (not semantic-lex-maximum-depth)
+ (< semantic-lex-current-depth semantic-lex-maximum-depth))
+ (progn
+ (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'open-paren (match-beginning 0) (match-end 0))))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'semantic-list (match-beginning 0)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection 'semantic-list
+ (forward-list 1)
+ (point))
+ )))
+ ))
+
+ (define-lex-simple-regex-analyzer semantic-lex-open-paren
+ "Detect and create an open parenthisis token."
+ "\\s(" 'open-paren 0 (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)))
+
+ (define-lex-simple-regex-analyzer semantic-lex-close-paren
+ "Detect and create a close paren token."
+ "\\s)" 'close-paren 0 (setq semantic-lex-current-depth (1- semantic-lex-current-depth)))
+
+ (define-lex-regex-analyzer semantic-lex-string
+ "Detect and create a string token."
+ "\\s\""
+ ;; Zing to the end of this string.
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'string (point)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection 'string
+ (forward-sexp 1)
+ (point))
+ ))))
+
+ (define-lex-regex-analyzer semantic-lex-comments
+ "Detect and create a comment token."
+ semantic-lex-comment-regex
+ (save-excursion
+ (forward-comment 1)
+ ;; Generate newline token if enabled
+ (if (bolp) (backward-char 1))
+ (setq semantic-lex-end-point (point))
+ ;; Language wants comments or want them as whitespaces,
+ ;; link them together.
+ (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) 'comment)
+ (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
+ semantic-lex-end-point)
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'comment (match-beginning 0) semantic-lex-end-point)))))
+
+ (define-lex-regex-analyzer semantic-lex-comments-as-whitespace
+ "Detect comments and create a whitespace token."
+ semantic-lex-comment-regex
+ (save-excursion
+ (forward-comment 1)
+ ;; Generate newline token if enabled
+ (if (bolp) (backward-char 1))
+ (setq semantic-lex-end-point (point))
+ ;; Language wants comments or want them as whitespaces,
+ ;; link them together.
+ (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) 'whitespace)
+ (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream))
+ semantic-lex-end-point)
+ (semantic-lex-push-token
+ (semantic-lex-token
+ 'whitespace (match-beginning 0) semantic-lex-end-point)))))
+
+ (define-lex-regex-analyzer semantic-lex-ignore-comments
+ "Detect and create a comment token."
+ semantic-lex-comment-regex
+ (let ((comment-start-point (point)))
+ (forward-comment 1)
+ (if (eq (point) comment-start-point)
+ ;; In this case our start-skip string failed
+ ;; to work properly. Lets try and move over
+ ;; whatever white space we matched to begin
+ ;; with.
+ (skip-syntax-forward "-.'"
+ (save-excursion
+ (end-of-line)
+ (point)))
+ ;; We may need to back up so newlines or whitespace is generated.
+ (if (bolp)
+ (backward-char 1)))
+ (if (eq (point) comment-start-point)
+ (error "Strange comment syntax prevents lexical analysis"))
+ (setq semantic-lex-end-point (point))))
+ \f
+ ;;; Comment lexer
+ ;;
+ ;; Predefined lexers that could be used instead of creating new
+ ;; analyers.
+
+ (define-lex semantic-comment-lexer
+ "A simple lexical analyzer that handles comments.
+ This lexer will only return comment tokens. It is the default lexer
+ used by `semantic-find-doc-snarf-comment' to snarf up the comment at
+ point."
+ semantic-lex-ignore-whitespace
+ semantic-lex-ignore-newline
+ semantic-lex-comments
+ semantic-lex-default-action)
+
+ ;;; Test Lexer
+ ;;
+ (define-lex semantic-simple-lexer
+ "A simple lexical analyzer that handles simple buffers.
+ This lexer ignores comments and whitespace, and will return
+ syntax as specified by the syntax table."
+ semantic-lex-ignore-whitespace
+ semantic-lex-ignore-newline
+ semantic-lex-number
+ semantic-lex-symbol-or-keyword
+ semantic-lex-charquote
+ semantic-lex-paren-or-list
+ semantic-lex-close-paren
+ semantic-lex-string
+ semantic-lex-ignore-comments
+ semantic-lex-punctuation
+ semantic-lex-default-action)
+ \f
+ ;;; Analyzers generated from grammar.
+ ;;
+ ;; Some analyzers are hand written. Analyzers created with these
+ ;; functions are generated from the grammar files.
+
+ (defmacro define-lex-keyword-type-analyzer (name doc syntax)
+ "Define a keyword type analyzer NAME with DOC string.
+ SYNTAX is the regexp that matches a keyword syntactic expression."
+ (let ((key (make-symbol "key")))
+ `(define-lex-analyzer ,name
+ ,doc
+ (and (looking-at ,syntax)
+ (let ((,key (semantic-lex-keyword-p (match-string 0))))
+ (when ,key
+ (semantic-lex-push-token
+ (semantic-lex-token
+ ,key (match-beginning 0) (match-end 0)))))))
+ ))
+
+ (defmacro define-lex-sexp-type-analyzer (name doc syntax token)
+ "Define a sexp type analyzer NAME with DOC string.
+ SYNTAX is the regexp that matches the beginning of the s-expression.
+ TOKEN is the lexical token returned when SYNTAX matches."
+ `(define-lex-regex-analyzer ,name
+ ,doc
+ ,syntax
+ (semantic-lex-push-token
+ (semantic-lex-token
+ ,token (point)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection ,token
+ (forward-sexp 1)
+ (point))))))
+ )
+
+ (defmacro define-lex-regex-type-analyzer (name doc syntax matches default)
+ "Define a regexp type analyzer NAME with DOC string.
+ SYNTAX is the regexp that matches a syntactic expression.
+ MATCHES is an alist of lexical elements used to refine the syntactic
+ expression.
+ DEFAULT is the default lexical token returned when no MATCHES."
+ (if matches
+ (let* ((val (make-symbol "val"))
+ (lst (make-symbol "lst"))
+ (elt (make-symbol "elt"))
+ (pos (make-symbol "pos"))
+ (end (make-symbol "end")))
+ `(define-lex-analyzer ,name
+ ,doc
+ (and (looking-at ,syntax)
+ (let* ((,val (match-string 0))
+ (,pos (match-beginning 0))
+ (,end (match-end 0))
+ (,lst ,matches)
+ ,elt)
+ (while (and ,lst (not ,elt))
+ (if (string-match (cdar ,lst) ,val)
+ (setq ,elt (caar ,lst))
+ (setq ,lst (cdr ,lst))))
+ (semantic-lex-push-token
+ (semantic-lex-token (or ,elt ,default) ,pos ,end))))
+ ))
+ `(define-lex-simple-regex-analyzer ,name
+ ,doc
+ ,syntax ,default)
+ ))
+
+ (defmacro define-lex-string-type-analyzer (name doc syntax matches default)
+ "Define a string type analyzer NAME with DOC string.
+ SYNTAX is the regexp that matches a syntactic expression.
+ MATCHES is an alist of lexical elements used to refine the syntactic
+ expression.
+ DEFAULT is the default lexical token returned when no MATCHES."
+ (if matches
+ (let* ((val (make-symbol "val"))
+ (lst (make-symbol "lst"))
+ (elt (make-symbol "elt"))
+ (pos (make-symbol "pos"))
+ (end (make-symbol "end"))
+ (len (make-symbol "len")))
+ `(define-lex-analyzer ,name
+ ,doc
+ (and (looking-at ,syntax)
+ (let* ((,val (match-string 0))
+ (,pos (match-beginning 0))
+ (,end (match-end 0))
+ (,len (- ,end ,pos))
+ (,lst ,matches)
+ ,elt)
+ ;; Starting with the longest one, search if a lexical
+ ;; value match a token defined for this language.
+ (while (and (> ,len 0) (not (setq ,elt (rassoc ,val ,lst))))
+ (setq ,len (1- ,len)
+ ,val (substring ,val 0 ,len)))
+ (when ,elt ;; Adjust token end position.
+ (setq ,elt (car ,elt)
+ ,end (+ ,pos ,len)))
+ (semantic-lex-push-token
+ (semantic-lex-token (or ,elt ,default) ,pos ,end))))
+ ))
+ `(define-lex-simple-regex-analyzer ,name
+ ,doc
+ ,syntax ,default)
+ ))
+
+ (defmacro define-lex-block-type-analyzer (name doc syntax matches)
+ "Define a block type analyzer NAME with DOC string.
+
+ SYNTAX is the regexp that matches block delimiters, typically the
+ open (`\\\\s(') and close (`\\\\s)') parenthesis syntax classes.
+
+ MATCHES is a pair (OPEN-SPECS . CLOSE-SPECS) that defines blocks.
+
+ OPEN-SPECS is a list of (OPEN-DELIM OPEN-TOKEN BLOCK-TOKEN) elements
+ where:
+
+ OPEN-DELIM is a string: the block open delimiter character.
+
+ OPEN-TOKEN is the lexical token class associated to the OPEN-DELIM
+ delimiter.
+
+ BLOCK-TOKEN is the lexical token class associated to the block
+ that starts at the OPEN-DELIM delimiter.
+
+ CLOSE-SPECS is a list of (CLOSE-DELIM CLOSE-TOKEN) elements where:
+
+ CLOSE-DELIM is a string: the block end delimiter character.
+
+ CLOSE-TOKEN is the lexical token class associated to the
+ CLOSE-DELIM delimiter.
+
+ Each element in OPEN-SPECS must have a corresponding element in
+ CLOSE-SPECS.
+
+ The lexer will return a BLOCK-TOKEN token when the value of
+ `semantic-lex-current-depth' is greater than or equal to the maximum
+ depth of parenthesis tracking (see also the function `semantic-lex').
+ Otherwise it will return OPEN-TOKEN and CLOSE-TOKEN tokens.
+
+ TO DO: Put the following in the developer's guide and just put a
+ reference here.
+
+ In the grammar:
+
+ The value of a block token must be a string that contains a readable
+ sexp of the form:
+
+ \"(OPEN-TOKEN CLOSE-TOKEN)\"
+
+ OPEN-TOKEN and CLOSE-TOKEN represent the block delimiters, and must be
+ lexical tokens of respectively `open-paren' and `close-paren' types.
+ Their value is the corresponding delimiter character as a string.
+
+ Here is a small example to analyze a parenthesis block:
+
+ %token <block> PAREN_BLOCK \"(LPAREN RPAREN)\"
+ %token <open-paren> LPAREN \"(\"
+ %token <close-paren> RPAREN \")\"
+
+ When the lexer encounters the open-paren delimiter \"(\":
+
+ - If the maximum depth of parenthesis tracking is not reached (that
+ is, current depth < max depth), it returns a (LPAREN start . end)
+ token, then continue analysis inside the block. Later, when the
+ corresponding close-paren delimiter \")\" will be encountered, it
+ will return a (RPAREN start . end) token.
+
+ - If the maximum depth of parenthesis tracking is reached (current
+ depth >= max depth), it returns the whole parenthesis block as
+ a (PAREN_BLOCK start . end) token."
+ (let* ((val (make-symbol "val"))
+ (lst (make-symbol "lst"))
+ (elt (make-symbol "elt")))
+ `(define-lex-analyzer ,name
+ ,doc
+ (and
+ (looking-at ,syntax) ;; "\\(\\s(\\|\\s)\\)"
+ (let ((,val (match-string 0))
+ (,lst ,matches)
+ ,elt)
+ (cond
+ ((setq ,elt (assoc ,val (car ,lst)))
+ (if (or (not semantic-lex-maximum-depth)
+ (< semantic-lex-current-depth semantic-lex-maximum-depth))
+ (progn
+ (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 1 ,elt)
+ (match-beginning 0) (match-end 0))))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 2 ,elt)
+ (match-beginning 0)
+ (save-excursion
+ (semantic-lex-unterminated-syntax-protection (nth 2 ,elt)
+ (forward-list 1)
+ (point)))))))
+ ((setq ,elt (assoc ,val (cdr ,lst)))
+ (setq semantic-lex-current-depth (1- semantic-lex-current-depth))
+ (semantic-lex-push-token
+ (semantic-lex-token
+ (nth 1 ,elt)
+ (match-beginning 0) (match-end 0))))
+ ))))
+ ))
+ \f
+ ;;; Lexical Safety
+ ;;
+ ;; The semantic lexers, unlike other lexers, can throw errors on
+ ;; unbalanced syntax. Since editing is all about changeging test
+ ;; we need to provide a convenient way to protect against syntactic
+ ;; inequalities.
+
+ (defmacro semantic-lex-catch-errors (symbol &rest forms)
+ "Using SYMBOL, execute FORMS catching lexical errors.
+ If FORMS results in a call to the parser that throws a lexical error,
+ the error will be caught here without the buffer's cache being thrown
+ out of date.
+ If there is an error, the syntax that failed is returned.
+ If there is no error, then the last value of FORMS is returned."
+ (let ((ret (make-symbol "ret"))
+ (syntax (make-symbol "syntax"))
+ (start (make-symbol "start"))
+ (end (make-symbol "end")))
+ `(let* ((semantic-lex-unterminated-syntax-end-function
+ (lambda (,syntax ,start ,end)
+ (throw ',symbol ,syntax)))
+ ;; Delete the below when semantic-flex is fully retired.
+ (semantic-flex-unterminated-syntax-end-function
+ semantic-lex-unterminated-syntax-end-function)
+ (,ret (catch ',symbol
+ (save-excursion
+ ,@forms
+ nil))))
+ ;; Great Sadness. Assume that FORMS execute within the
+ ;; confines of the current buffer only! Mark this thing
+ ;; unparseable iff the special symbol was thrown. This
+ ;; will prevent future calls from parsing, but will allow
+ ;; then to still return the cache.
+ (when ,ret
+ ;; Leave this message off. If an APP using this fcn wants
+ ;; a message, they can do it themselves. This cleans up
+ ;; problems with the idle scheduler obscuring useful data.
+ ;;(message "Buffer not currently parsable (%S)." ,ret)
+ (semantic-parse-tree-unparseable))
+ ,ret)))
+ (put 'semantic-lex-catch-errors 'lisp-indent-function 1)
+
+ \f
+ ;;; Interfacing with edebug
+ ;;
+ (add-hook
+ 'edebug-setup-hook
+ #'(lambda ()
+
+ (def-edebug-spec define-lex
+ (&define name stringp (&rest symbolp))
+ )
+ (def-edebug-spec define-lex-analyzer
+ (&define name stringp form def-body)
+ )
+ (def-edebug-spec define-lex-regex-analyzer
+ (&define name stringp form def-body)
+ )
+ (def-edebug-spec define-lex-simple-regex-analyzer
+ (&define name stringp form symbolp [ &optional form ] def-body)
+ )
+ (def-edebug-spec define-lex-block-analyzer
+ (&define name stringp form (&rest form))
+ )
+ (def-edebug-spec semantic-lex-catch-errors
+ (symbolp def-body)
+ )
+
+ ))
+ \f
+ ;;; Compatibility with Semantic 1.x lexical analysis
+ ;;
+ ;; NOTE: DELETE THIS SOMEDAY SOON
+
+ (semantic-alias-obsolete 'semantic-flex-start 'semantic-lex-token-start)
+ (semantic-alias-obsolete 'semantic-flex-end 'semantic-lex-token-end)
+ (semantic-alias-obsolete 'semantic-flex-text 'semantic-lex-token-text)
+ (semantic-alias-obsolete 'semantic-flex-make-keyword-table 'semantic-lex-make-keyword-table)
+ (semantic-alias-obsolete 'semantic-flex-keyword-p 'semantic-lex-keyword-p)
+ (semantic-alias-obsolete 'semantic-flex-keyword-put 'semantic-lex-keyword-put)
+ (semantic-alias-obsolete 'semantic-flex-keyword-get 'semantic-lex-keyword-get)
+ (semantic-alias-obsolete 'semantic-flex-map-keywords 'semantic-lex-map-keywords)
+ (semantic-alias-obsolete 'semantic-flex-keywords 'semantic-lex-keywords)
+ (semantic-alias-obsolete 'semantic-flex-buffer 'semantic-lex-buffer)
+ (semantic-alias-obsolete 'semantic-flex-list 'semantic-lex-list)
+
+ ;; This simple scanner uses the syntax table to generate a stream of
+ ;; simple tokens of the form:
+ ;;
+ ;; (SYMBOL START . END)
+ ;;
+ ;; Where symbol is the type of thing it is. START and END mark that
+ ;; objects boundary.
+
+ (defvar semantic-flex-tokens semantic-lex-tokens
+ "An alist of of semantic token types.
+ See variable `semantic-lex-tokens'.")
+
+ (defvar semantic-flex-unterminated-syntax-end-function
+ (lambda (syntax syntax-start flex-end) flex-end)
+ "Function called when unterminated syntax is encountered.
+ This should be set to one function. That function should take three
+ parameters. The SYNTAX, or type of syntax which is unterminated.
+ SYNTAX-START where the broken syntax begins.
+ FLEX-END is where the lexical analysis was asked to end.
+ This function can be used for languages that can intelligently fix up
+ broken syntax, or the exit lexical analysis via `throw' or `signal'
+ when finding unterminated syntax.")
+
+ (defvar semantic-flex-extensions nil
+ "Buffer local extensions to the lexical analyzer.
+ This should contain an alist with a key of a regex and a data element of
+ a function. The function should both move point, and return a lexical
+ token of the form:
+ ( TYPE START . END)
+ nil is also a valid return value.
+ TYPE can be any type of symbol, as long as it doesn't occur as a
+ nonterminal in the language definition.")
+ (make-variable-buffer-local 'semantic-flex-extensions)
+
+ (defvar semantic-flex-syntax-modifications nil
+ "Changes to the syntax table for this buffer.
+ These changes are active only while the buffer is being flexed.
+ This is a list where each element has the form:
+ (CHAR CLASS)
+ CHAR is the char passed to `modify-syntax-entry',
+ and CLASS is the string also passed to `modify-syntax-entry' to define
+ what syntax class CHAR has.")
+ (make-variable-buffer-local 'semantic-flex-syntax-modifications)
+
+ (defvar semantic-ignore-comments t
+ "Default comment handling.
+ t means to strip comments when flexing. Nil means to keep comments
+ as part of the token stream.")
+ (make-variable-buffer-local 'semantic-ignore-comments)
+
+ (defvar semantic-flex-enable-newlines nil
+ "When flexing, report 'newlines as syntactic elements.
+ Useful for languages where the newline is a special case terminator.
+ Only set this on a per mode basis, not globally.")
+ (make-variable-buffer-local 'semantic-flex-enable-newlines)
+
+ (defvar semantic-flex-enable-whitespace nil
+ "When flexing, report 'whitespace as syntactic elements.
+ Useful for languages where the syntax is whitespace dependent.
+ Only set this on a per mode basis, not globally.")
+ (make-variable-buffer-local 'semantic-flex-enable-whitespace)
+
+ (defvar semantic-flex-enable-bol nil
+ "When flexing, report beginning of lines as syntactic elements.
+ Useful for languages like python which are indentation sensitive.
+ Only set this on a per mode basis, not globally.")
+ (make-variable-buffer-local 'semantic-flex-enable-bol)
+
+ (defvar semantic-number-expression semantic-lex-number-expression
+ "See variable `semantic-lex-number-expression'.")
+ (make-variable-buffer-local 'semantic-number-expression)
+
+ (defvar semantic-flex-depth 0
+ "Default flexing depth.
+ This specifies how many lists to create tokens in.")
+ (make-variable-buffer-local 'semantic-flex-depth)
+
+ (defun semantic-flex (start end &optional depth length)
+ "Using the syntax table, do something roughly equivalent to flex.
+ Semantically check between START and END. Optional argument DEPTH
+ indicates at what level to scan over entire lists.
+ The return value is a token stream. Each element is a list, such of
+ the form (symbol start-expression . end-expression) where SYMBOL
+ denotes the token type.
+ See `semantic-flex-tokens' variable for details on token types.
+ END does not mark the end of the text scanned, only the end of the
+ beginning of text scanned. Thus, if a string extends past END, the
+ end of the return token will be larger than END. To truly restrict
+ scanning, use `narrow-to-region'.
+ The last argument, LENGTH specifies that `semantic-flex' should only
+ return LENGTH tokens."
+ (message "`semantic-flex' is an obsolete function. Use `define-lex' to create lexers.")
+ (if (not semantic-flex-keywords-obarray)
+ (setq semantic-flex-keywords-obarray [ nil ]))
+ (let ((ts nil)
+ (pos (point))
+ (ep nil)
+ (curdepth 0)
+ (cs (if comment-start-skip
+ (concat "\\(\\s<\\|" comment-start-skip "\\)")
+ (concat "\\(\\s<\\)")))
+ (newsyntax (copy-syntax-table (syntax-table)))
+ (mods semantic-flex-syntax-modifications)
+ ;; Use the default depth if it is not specified.
+ (depth (or depth semantic-flex-depth)))
+ ;; Update the syntax table
+ (while mods
+ (modify-syntax-entry (car (car mods)) (car (cdr (car mods))) newsyntax)
+ (setq mods (cdr mods)))
+ (with-syntax-table newsyntax
+ (goto-char start)
+ (while (and (< (point) end) (or (not length) (<= (length ts) length)))
+ (cond
+ ;; catch beginning of lines when needed.
+ ;; Must be done before catching any other tokens!
+ ((and semantic-flex-enable-bol
+ (bolp)
+ ;; Just insert a (bol N . N) token in the token stream,
+ ;; without moving the point. N is the point at the
+ ;; beginning of line.
+ (setq ts (cons (cons 'bol (cons (point) (point))) ts))
+ nil)) ;; CONTINUE
+ ;; special extensions, includes whitespace, nl, etc.
+ ((and semantic-flex-extensions
+ (let ((fe semantic-flex-extensions)
+ (r nil))
+ (while fe
+ (if (looking-at (car (car fe)))
+ (setq ts (cons (funcall (cdr (car fe))) ts)
+ r t
+ fe nil
+ ep (point)))
+ (setq fe (cdr fe)))
+ (if (and r (not (car ts))) (setq ts (cdr ts)))
+ r)))
+ ;; catch newlines when needed
+ ((looking-at "\\s-*\\(\n\\|\\s>\\)")
+ (if semantic-flex-enable-newlines
+ (setq ep (match-end 1)
+ ts (cons (cons 'newline
+ (cons (match-beginning 1) ep))
+ ts))))
+ ;; catch whitespace when needed
+ ((looking-at "\\s-+")
+ (if semantic-flex-enable-whitespace
+ ;; Language wants whitespaces, link them together.
+ (if (eq (car (car ts)) 'whitespace)
+ (setcdr (cdr (car ts)) (match-end 0))
+ (setq ts (cons (cons 'whitespace
+ (cons (match-beginning 0)
+ (match-end 0)))
+ ts)))))
+ ;; numbers
+ ((and semantic-number-expression
+ (looking-at semantic-number-expression))
+ (setq ts (cons (cons 'number
+ (cons (match-beginning 0)
+ (match-end 0)))
+ ts)))
+ ;; symbols
+ ((looking-at "\\(\\sw\\|\\s_\\)+")
+ (setq ts (cons (cons
+ ;; Get info on if this is a keyword or not
+ (or (semantic-lex-keyword-p (match-string 0))
+ 'symbol)
+ (cons (match-beginning 0) (match-end 0)))
+ ts)))
+ ;; Character quoting characters (ie, \n as newline)
+ ((looking-at "\\s\\+")
+ (setq ts (cons (cons 'charquote
+ (cons (match-beginning 0) (match-end 0)))
+ ts)))
+ ;; Open parens, or semantic-lists.
+ ((looking-at "\\s(")
+ (if (or (not depth) (< curdepth depth))
+ (progn
+ (setq curdepth (1+ curdepth))
+ (setq ts (cons (cons 'open-paren
+ (cons (match-beginning 0) (match-end 0)))
+ ts)))
+ (setq ts (cons
+ (cons 'semantic-list
+ (cons (match-beginning 0)
+ (save-excursion
+ (condition-case nil
+ (forward-list 1)
+ ;; This case makes flex robust
+ ;; to broken lists.
+ (error
+ (goto-char
+ (funcall
+ semantic-flex-unterminated-syntax-end-function
+ 'semantic-list
+ start end))))
+ (setq ep (point)))))
+ ts))))
+ ;; Close parens
+ ((looking-at "\\s)")
+ (setq ts (cons (cons 'close-paren
+ (cons (match-beginning 0) (match-end 0)))
+ ts))
+ (setq curdepth (1- curdepth)))
+ ;; String initiators
+ ((looking-at "\\s\"")
+ ;; Zing to the end of this string.
+ (setq ts (cons (cons 'string
+ (cons (match-beginning 0)
+ (save-excursion
+ (condition-case nil
+ (forward-sexp 1)
+ ;; This case makes flex
+ ;; robust to broken strings.
+ (error
+ (goto-char
+ (funcall
+ semantic-flex-unterminated-syntax-end-function
+ 'string
+ start end))))
+ (setq ep (point)))))
+ ts)))
+ ;; comments
+ ((looking-at cs)
+ (if (and semantic-ignore-comments
+ (not semantic-flex-enable-whitespace))
+ ;; If the language doesn't deal with comments nor
+ ;; whitespaces, ignore them here.
+ (let ((comment-start-point (point)))
+ (forward-comment 1)
+ (if (eq (point) comment-start-point)
+ ;; In this case our start-skip string failed
+ ;; to work properly. Lets try and move over
+ ;; whatever white space we matched to begin
+ ;; with.
+ (skip-syntax-forward "-.'"
+ (save-excursion
+ (end-of-line)
+ (point)))
+ ;;(forward-comment 1)
+ ;; Generate newline token if enabled
+ (if (and semantic-flex-enable-newlines
+ (bolp))
+ (backward-char 1)))
+ (if (eq (point) comment-start-point)
+ (error "Strange comment syntax prevents lexical analysis"))
+ (setq ep (point)))
+ (let ((tk (if semantic-ignore-comments 'whitespace 'comment)))
+ (save-excursion
+ (forward-comment 1)
+ ;; Generate newline token if enabled
+ (if (and semantic-flex-enable-newlines
+ (bolp))
+ (backward-char 1))
+ (setq ep (point)))
+ ;; Language wants comments or want them as whitespaces,
+ ;; link them together.
+ (if (eq (car (car ts)) tk)
+ (setcdr (cdr (car ts)) ep)
+ (setq ts (cons (cons tk (cons (match-beginning 0) ep))
+ ts))))))
+ ;; punctuation
+ ((looking-at "\\(\\s.\\|\\s$\\|\\s'\\)")
+ (setq ts (cons (cons 'punctuation
+ (cons (match-beginning 0) (match-end 0)))
+ ts)))
+ ;; unknown token
+ (t
+ (error "What is that?")))
+ (goto-char (or ep (match-end 0)))
+ (setq ep nil)))
+ ;; maybe catch the last beginning of line when needed
+ (and semantic-flex-enable-bol
+ (= (point) end)
+ (bolp)
+ (setq ts (cons (cons 'bol (cons (point) (point))) ts)))
+ (goto-char pos)
+ ;;(message "Flexing muscles...done")
+ (nreverse ts)))
+
+ (provide 'semantic/lex)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/lex"
+ ;; End:
+
-;;; semantic-lex.el ends here
++;;; semantic/lex.el ends here
--- /dev/null
+ ;;; semantic/sb.el --- Semantic tag display for speedbar
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
+ ;;; 2007, 2008 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Convert a tag table into speedbar buttons.
+
+ ;;; TODO:
+
+ ;; Use semanticdb to find which semanticdb-table is being used for each
+ ;; file/tag. Replace `semantic-sb-with-tag-buffer' to instead call
+ ;; children with the new `with-mode-local' instead.
+
+ (require 'semantic)
+ (require 'semantic/format)
+ (require 'semantic/sort)
+ (require 'semantic/util)
+ (require 'speedbar)
++(declare-function semanticdb-file-stream "semantic/db")
+
+ (defcustom semantic-sb-autoexpand-length 1
+ "*Length of a semantic bucket to autoexpand in place.
+ This will replace the named bucket that would have usually occured here."
+ :group 'speedbar
+ :type 'integer)
+
+ (defcustom semantic-sb-button-format-tag-function 'semantic-format-tag-abbreviate
+ "*Function called to create the text for a but from a token."
+ :group 'speedbar
+ :type semantic-format-tag-custom-list)
+
+ (defcustom semantic-sb-info-format-tag-function 'semantic-format-tag-summarize
+ "*Function called to create the text for info display from a token."
+ :group 'speedbar
+ :type semantic-format-tag-custom-list)
+
+ ;;; Code:
+ ;;
+
+ ;;; Buffer setting for correct mode manipulation.
+ (defun semantic-sb-tag-set-buffer (tag)
+ "Set the current buffer to something associated with TAG.
+ use the `speedbar-line-file' to get this info if needed."
+ (if (semantic-tag-buffer tag)
+ (set-buffer (semantic-tag-buffer tag))
+ (let ((f (speedbar-line-file)))
+ (set-buffer (find-file-noselect f)))))
+
+ (defmacro semantic-sb-with-tag-buffer (tag &rest forms)
+ "Set the current buffer to the origin of TAG and execute FORMS.
+ Restore the old current buffer when completed."
+ `(save-excursion
+ (semantic-sb-tag-set-buffer ,tag)
+ ,@forms))
+ (put 'semantic-sb-with-tag-buffer 'lisp-indent-function 1)
+
+ ;;; Button Generation
+ ;;
+ ;; Here are some button groups:
+ ;;
+ ;; +> Function ()
+ ;; @ return_type
+ ;; +( arg1
+ ;; +| arg2
+ ;; +) arg3
+ ;;
+ ;; +> Variable[1] =
+ ;; @ type
+ ;; = default value
+ ;;
+ ;; +> keywrd Type
+ ;; +> type part
+ ;;
+ ;; +> -> click to see additional information
+
+ (define-overloadable-function semantic-sb-tag-children-to-expand (tag)
+ "For TAG, return a list of children that TAG expands to.
+ If this returns a value, then a +> icon is created.
+ If it returns nil, then a => icon is created.")
+
+ (defun semantic-sb-tag-children-to-expand-default (tag)
+ "For TAG, the children for type, variable, and function classes."
+ (semantic-sb-with-tag-buffer tag
+ (semantic-tag-components tag)))
+
+ (defun semantic-sb-one-button (tag depth &optional prefix)
+ "Insert TAG as a speedbar button at DEPTH.
+ Optional PREFIX is used to specify special marker characters."
+ (let* ((class (semantic-tag-class tag))
+ (edata (semantic-sb-tag-children-to-expand tag))
+ (type (semantic-tag-type tag))
+ (abbrev (semantic-sb-with-tag-buffer tag
+ (funcall semantic-sb-button-format-tag-function tag)))
+ (start (point))
+ (end (progn
+ (insert (int-to-string depth) ":")
+ (point))))
+ (insert-char ? (1- depth) nil)
+ (put-text-property end (point) 'invisible nil)
+ ;; take care of edata = (nil) -- a yucky but hard to clean case
+ (if (and edata (listp edata) (and (<= (length edata) 1) (not (car edata))))
+ (setq edata nil))
+ (if (and (not edata)
+ (member class '(variable function))
+ type)
+ (setq edata t))
+ ;; types are a bit unique. Variable types can have special meaning.
+ (if edata
+ (speedbar-insert-button (if prefix (concat " +" prefix) " +>")
+ 'speedbar-button-face
+ 'speedbar-highlight-face
+ 'semantic-sb-show-extra
+ tag t)
+ (speedbar-insert-button (if prefix (concat " " prefix) " =>")
+ nil nil nil nil t))
+ (speedbar-insert-button abbrev
+ 'speedbar-tag-face
+ 'speedbar-highlight-face
+ 'semantic-sb-token-jump
+ tag t)
+ ;; This is very bizarre. When this was just after the insertion
+ ;; of the depth: text, the : would get erased, but only for the
+ ;; auto-expanded short- buckets. Move back for a later version
+ ;; version of Emacs 21 CVS
+ (put-text-property start end 'invisible t)
+ ))
+
+ (defun semantic-sb-speedbar-data-line (depth button text &optional
+ text-fun text-data)
+ "Insert a semantic token data element.
+ DEPTH is the current depth. BUTTON is the text for the button.
+ TEXT is the actual info with TEXT-FUN to occur when it happens.
+ Argument TEXT-DATA is the token data to pass to TEXT-FUN."
+ (let ((start (point))
+ (end (progn
+ (insert (int-to-string depth) ":")
+ (point))))
+ (put-text-property start end 'invisible t)
+ (insert-char ? depth nil)
+ (put-text-property end (point) 'invisible nil)
+ (speedbar-insert-button button nil nil nil nil t)
+ (speedbar-insert-button text
+ 'speedbar-tag-face
+ (if text-fun 'speedbar-highlight-face)
+ text-fun text-data t)
+ ))
+
+ (defun semantic-sb-maybe-token-to-button (obj indent &optional
+ prefix modifiers)
+ "Convert OBJ, which was returned from the semantic parser, into a button.
+ This OBJ might be a plain string (simple type or untyped variable)
+ or a complete tag.
+ Argument INDENT is the indentation used when making the button.
+ Optional PREFIX is the character to use when marking the line.
+ Optional MODIFIERS is additional text needed for variables."
+ (let ((myprefix (or prefix ">")))
+ (if (stringp obj)
+ (semantic-sb-speedbar-data-line indent myprefix obj)
+ (if (listp obj)
+ (progn
+ (if (and (stringp (car obj))
+ (= (length obj) 1))
+ (semantic-sb-speedbar-data-line indent myprefix
+ (concat
+ (car obj)
+ (or modifiers "")))
+ (semantic-sb-one-button obj indent prefix)))))))
+
+ (defun semantic-sb-insert-details (tag indent)
+ "Insert details about TAG at level INDENT."
+ (let ((tt (semantic-tag-class tag))
+ (type (semantic-tag-type tag)))
+ (cond ((eq tt 'type)
+ (let ((parts (semantic-tag-type-members tag))
+ (newparts nil))
+ ;; Lets expect PARTS to be a list of either strings,
+ ;; or variable tokens.
+ (when (semantic-tag-p (car parts))
+ ;; Bucketize into groups
+ (semantic-sb-with-tag-buffer (car parts)
+ (setq newparts (semantic-bucketize parts)))
+ (when (> (length newparts) semantic-sb-autoexpand-length)
+ ;; More than one bucket, insert inline
+ (semantic-sb-insert-tag-table (1- indent) newparts)
+ (setq parts nil))
+ ;; Dump the strings in.
+ (while parts
+ (semantic-sb-maybe-token-to-button (car parts) indent)
+ (setq parts (cdr parts))))))
+ ((eq tt 'variable)
+ (if type
+ (semantic-sb-maybe-token-to-button type indent "@"))
+ (let ((default (semantic-tag-variable-default tag)))
+ (if default
+ (semantic-sb-maybe-token-to-button default indent "=")))
+ )
+ ((eq tt 'function)
+ (if type
+ (semantic-sb-speedbar-data-line
+ indent "@"
+ (if (stringp type) type
+ (semantic-tag-name type))))
+ ;; Arguments to the function
+ (let ((args (semantic-tag-function-arguments tag)))
+ (if (and args (car args))
+ (progn
+ (semantic-sb-maybe-token-to-button (car args) indent "(")
+ (setq args (cdr args))
+ (while (> (length args) 1)
+ (semantic-sb-maybe-token-to-button (car args)
+ indent
+ "|")
+ (setq args (cdr args)))
+ (if args
+ (semantic-sb-maybe-token-to-button
+ (car args) indent ")"))
+ ))))
+ (t
+ (let ((components
+ (save-excursion
+ (when (and (semantic-tag-overlay tag)
+ (semantic-tag-buffer tag))
+ (set-buffer (semantic-tag-buffer tag)))
+ (semantic-sb-tag-children-to-expand tag))))
+ ;; Well, it wasn't one of the many things we expect.
+ ;; Lets just insert them in with no decoration.
+ (while components
+ (semantic-sb-one-button (car components) indent)
+ (setq components (cdr components)))
+ ))
+ )
+ ))
+
+ (defun semantic-sb-detail-parent ()
+ "Return the first parent token of the current line that includes a location."
+ (save-excursion
+ (beginning-of-line)
+ (let ((dep (if (looking-at "[0-9]+:")
+ (1- (string-to-number (match-string 0)))
+ 0)))
+ (re-search-backward (concat "^"
+ (int-to-string dep)
+ ":")
+ nil t))
+ (beginning-of-line)
+ (if (looking-at "[0-9]+: +[-+][>()@|] \\([^\n]+\\)$")
+ (let ((prop nil))
+ (goto-char (match-beginning 1))
+ (setq prop (get-text-property (point) 'speedbar-token))
+ (if (semantic-tag-with-position-p prop)
+ prop
+ (semantic-sb-detail-parent)))
+ nil)))
+
+ (defun semantic-sb-show-extra (text token indent)
+ "Display additional information about the token as an expansion.
+ TEXT TOKEN and INDENT are the details."
+ (cond ((string-match "+" text) ;we have to expand this file
+ (speedbar-change-expand-button-char ?-)
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ ;; Add in stuff specific to this type of token.
+ (semantic-sb-insert-details token (1+ indent))))))
+ ((string-match "-" text) ;we have to contract this node
+ (speedbar-change-expand-button-char ?+)
+ (speedbar-delete-subblock indent))
+ (t (error "Ooops... not sure what to do")))
+ (speedbar-center-buffer-smartly))
+
+ (defun semantic-sb-token-jump (text token indent)
+ "Jump to the location specified in token.
+ TEXT TOKEN and INDENT are the details."
+ (let ((file
+ (or
+ (cond ((fboundp 'speedbar-line-path)
+ (speedbar-line-directory indent))
+ ((fboundp 'speedbar-line-directory)
+ (speedbar-line-directory indent)))
+ ;; If speedbar cannot figure this out, extract the filename from
+ ;; the token. True for Analysis mode.
+ (semantic-tag-file-name token)))
+ (parent (semantic-sb-detail-parent)))
+ (let ((f (selected-frame)))
+ (dframe-select-attached-frame speedbar-frame)
+ (run-hooks 'speedbar-before-visiting-tag-hook)
+ (select-frame f))
+ ;; Sometimes FILE may be nil here. If you are debugging a problem
+ ;; when this happens, go back and figure out why FILE is nil and try
+ ;; and fix the source.
+ (speedbar-find-file-in-frame file)
+ (save-excursion (speedbar-stealthy-updates))
+ (semantic-go-to-tag token parent)
+ (switch-to-buffer (current-buffer))
+ ;; Reset the timer with a new timeout when cliking a file
+ ;; in case the user was navigating directories, we can cancel
+ ;; that other timer.
+ ;; (speedbar-set-timer dframe-update-speed)
+ ;;(recenter)
+ (speedbar-maybee-jump-to-attached-frame)
+ (run-hooks 'speedbar-visiting-tag-hook)))
+
+ (defun semantic-sb-expand-group (text token indent)
+ "Expand a group which has semantic tokens.
+ TEXT TOKEN and INDENT are the details."
+ (cond ((string-match "+" text) ;we have to expand this file
+ (speedbar-change-expand-button-char ?-)
+ (speedbar-with-writable
+ (save-excursion
+ (end-of-line) (forward-char 1)
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (semantic-sb-buttons-plain (1+ indent) token)))))
+ ((string-match "-" text) ;we have to contract this node
+ (speedbar-change-expand-button-char ?+)
+ (speedbar-delete-subblock indent))
+ (t (error "Ooops... not sure what to do")))
+ (speedbar-center-buffer-smartly))
+
+ (defun semantic-sb-buttons-plain (level tokens)
+ "Create buttons at LEVEL using TOKENS."
+ (let ((sordid (speedbar-create-tag-hierarchy tokens)))
+ (while sordid
+ (cond ((null (car-safe sordid)) nil)
+ ((consp (car-safe (cdr-safe (car-safe sordid))))
+ ;; A group!
+ (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group
+ (cdr (car sordid))
+ (car (car sordid))
+ nil nil 'speedbar-tag-face
+ level))
+ (t ;; Assume that this is a token.
+ (semantic-sb-one-button (car sordid) level)))
+ (setq sordid (cdr sordid)))))
+
+ (defun semantic-sb-insert-tag-table (level table)
+ "At LEVEL, insert the tag table TABLE.
+ Use arcane knowledge about the semantic tokens in the tagged elements
+ to create much wiser decisions about how to sort and group these items."
+ (semantic-sb-buttons level table))
+
+ (defun semantic-sb-buttons (level lst)
+ "Create buttons at LEVEL using LST sorting into type buckets."
+ (save-restriction
+ (narrow-to-region (point-min) (point))
+ (let (tmp)
+ (while lst
+ (setq tmp (car lst))
+ (if (cdr tmp)
+ (if (<= (length (cdr tmp)) semantic-sb-autoexpand-length)
+ (semantic-sb-buttons-plain (1+ level) (cdr tmp))
+ (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group
+ (cdr tmp)
+ (car (car lst))
+ nil nil 'speedbar-tag-face
+ (1+ level))))
+ (setq lst (cdr lst))))))
+
+ (defun semantic-sb-fetch-tag-table (file)
+ "Load FILE into a buffer, and generate tags using the Semantic parser.
+ Returns the tag list, or t for an error."
+ (let ((out nil))
+ (if (and (featurep 'semantic/db)
+ (semanticdb-minor-mode-p)
+ (not speedbar-power-click)
+ ;; If the database is loaded and running, try to get
+ ;; tokens from it.
+ (setq out (semanticdb-file-stream file)))
+ ;; Successful DB query.
+ nil
+ ;; No database, do it the old way.
+ (save-excursion
+ (set-buffer (find-file-noselect file))
+ (if (or (not (featurep 'semantic))
+ (not semantic--parse-table))
+ (setq out t)
+ (if speedbar-power-click (semantic-clear-toplevel-cache))
+ (setq out (semantic-fetch-tags)))))
+ (if (listp out)
+ (condition-case nil
+ (progn
+ ;; This brings externally defind methods into
+ ;; their classes, and creates meta classes for
+ ;; orphans.
+ (setq out (semantic-adopt-external-members out))
+ ;; Dump all the tokens into buckets.
+ (semantic-sb-with-tag-buffer (car out)
+ (semantic-bucketize out)))
+ (error t))
+ t)))
+
+ ;; Link ourselves into the tagging process.
+ (add-to-list 'speedbar-dynamic-tags-function-list
+ '(semantic-sb-fetch-tag-table . semantic-sb-insert-tag-table))
+
+ (provide 'semantic/sb)
+
+ ;;; semantic/sb.el ends here
--- /dev/null
-(require 'assoc)
+ ;;; sort.el --- Utilities for sorting and re-arranging tag tables.
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+ ;;; 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Tag tables originate in the order they appear in a buffer, or source file.
+ ;; It is often useful to re-arrange them is some predictable way for browsing
+ ;; purposes. Re-organization may be alphabetical, or even a complete
+ ;; reorganization of parents and children.
+ ;;
+ ;; Originally written in semantic-util.el
+ ;;
+
-(require 'semantic/db)
+ (require 'semantic)
-
-
-(semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing
- 'semantic-sort-tags-by-name-increasing)
-(semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing
- 'semantic-sort-tags-by-name-decreasing)
-(semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing
- 'semantic-sort-tags-by-type-increasing)
-(semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing
- 'semantic-sort-tags-by-type-decreasing)
-(semantic-alias-obsolete 'semantic-sort-tokens-by-name-increasing-ci
- 'semantic-sort-tags-by-name-increasing-ci)
-(semantic-alias-obsolete 'semantic-sort-tokens-by-name-decreasing-ci
- 'semantic-sort-tags-by-name-decreasing-ci)
-(semantic-alias-obsolete 'semantic-sort-tokens-by-type-increasing-ci
- 'semantic-sort-tags-by-type-increasing-ci)
-(semantic-alias-obsolete 'semantic-sort-tokens-by-type-decreasing-ci
- 'semantic-sort-tags-by-type-decreasing-ci)
-
+ (eval-when-compile
+ (require 'semantic/find))
+
+ (declare-function semanticdb-find-tags-external-children-of-type
+ "semantic/db-find")
+
+ ;;; Alphanumeric sorting
+ ;;
+ ;; Takes a list of tags, and sorts them in a case-insensitive way
+ ;; at a single level.
+
+ ;;; Code:
+ (defun semantic-string-lessp-ci (s1 s2)
+ "Case insensitive version of `string-lessp'.
+ Argument S1 and S2 are the strings to compare."
+ ;; Use downcase instead of upcase because an average name
+ ;; has more lower case characters.
+ (if (fboundp 'compare-strings)
+ (eq (compare-strings s1 0 nil s2 0 nil t) -1)
+ (string-lessp (downcase s1) (downcase s2))))
+
+ (defun semantic-sort-tag-type (tag)
+ "Return a type string for TAG guaranteed to be a string."
+ (let ((ty (semantic-tag-type tag)))
+ (cond ((stringp ty)
+ ty)
+ ((listp ty)
+ (or (car ty) ""))
+ (t ""))))
+
+ (defun semantic-tag-lessp-name-then-type (A B)
+ "Return t if tag A is < tag B.
+ First sorts on name, then sorts on the name of the :type of
+ each tag."
+ (let ((na (semantic-tag-name A))
+ (nb (semantic-tag-name B))
+ )
+ (if (string-lessp na nb)
+ t ; a sure thing.
+ (if (string= na nb)
+ ;; If equal, test the :type which might be different.
+ (let* ((ta (semantic-tag-type A))
+ (tb (semantic-tag-type B))
+ (tas (cond ((stringp ta)
+ ta)
+ ((semantic-tag-p ta)
+ (semantic-tag-name ta))
+ (t nil)))
+ (tbs (cond ((stringp tb)
+ tb)
+ ((semantic-tag-p tb)
+ (semantic-tag-name tb))
+ (t nil))))
+ (if (and (stringp tas) (stringp tbs))
+ (string< tas tbs)
+ ;; This is if A == B, and no types in A or B
+ nil))
+ ;; This nil is if A > B, but not =
+ nil))))
+
+ (defun semantic-sort-tags-by-name-increasing (tags)
+ "Sort TAGS by name in increasing order with side effects.
+ Return the sorted list."
+ (sort tags (lambda (a b)
+ (string-lessp (semantic-tag-name a)
+ (semantic-tag-name b)))))
+
+ (defun semantic-sort-tags-by-name-decreasing (tags)
+ "Sort TAGS by name in decreasing order with side effects.
+ Return the sorted list."
+ (sort tags (lambda (a b)
+ (string-lessp (semantic-tag-name b)
+ (semantic-tag-name a)))))
+
+ (defun semantic-sort-tags-by-type-increasing (tags)
+ "Sort TAGS by type in increasing order with side effects.
+ Return the sorted list."
+ (sort tags (lambda (a b)
+ (string-lessp (semantic-sort-tag-type a)
+ (semantic-sort-tag-type b)))))
+
+ (defun semantic-sort-tags-by-type-decreasing (tags)
+ "Sort TAGS by type in decreasing order with side effects.
+ Return the sorted list."
+ (sort tags (lambda (a b)
+ (string-lessp (semantic-sort-tag-type b)
+ (semantic-sort-tag-type a)))))
+
+ (defun semantic-sort-tags-by-name-increasing-ci (tags)
+ "Sort TAGS by name in increasing order with side effects.
+ Return the sorted list."
+ (sort tags (lambda (a b)
+ (semantic-string-lessp-ci (semantic-tag-name a)
+ (semantic-tag-name b)))))
+
+ (defun semantic-sort-tags-by-name-decreasing-ci (tags)
+ "Sort TAGS by name in decreasing order with side effects.
+ Return the sorted list."
+ (sort tags (lambda (a b)
+ (semantic-string-lessp-ci (semantic-tag-name b)
+ (semantic-tag-name a)))))
+
+ (defun semantic-sort-tags-by-type-increasing-ci (tags)
+ "Sort TAGS by type in increasing order with side effects.
+ Return the sorted list."
+ (sort tags (lambda (a b)
+ (semantic-string-lessp-ci (semantic-sort-tag-type a)
+ (semantic-sort-tag-type b)))))
+
+ (defun semantic-sort-tags-by-type-decreasing-ci (tags)
+ "Sort TAGS by type in decreasing order with side effects.
+ Return the sorted list."
+ (sort tags (lambda (a b)
+ (semantic-string-lessp-ci (semantic-sort-tag-type b)
+ (semantic-sort-tag-type a)))))
+
+ (defun semantic-sort-tags-by-name-then-type-increasing (tags)
+ "Sort TAGS by name, then type in increasing order with side effects.
+ Return the sorted list."
+ (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type a b))))
+
+ (defun semantic-sort-tags-by-name-then-type-decreasing (tags)
+ "Sort TAGS by name, then type in increasing order with side effects.
+ Return the sorted list."
+ (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type b a))))
- tp)
- ))
-
-(semantic-alias-obsolete 'semantic-nonterminal-external-member-parent
- 'semantic-tag-external-member-parent)
+ \f
+ ;;; Unique
+ ;;
+ ;; Scan a list of tags, removing duplicates.
+ ;; This must first sort the tags by name alphabetically ascending.
+ ;;
+ ;; Useful for completion lists, or other situations where the
+ ;; other data isn't as useful.
+
+ (defun semantic-unique-tag-table-by-name (tags)
+ "Scan a list of TAGS, removing duplicate names.
+ This must first sort the tags by name alphabetically ascending.
+ For more complex uniqueness testing used by the semanticdb
+ typecaching system, see `semanticdb-typecache-merge-streams'."
+ (let ((sorted (semantic-sort-tags-by-name-increasing
+ (copy-sequence tags)))
+ (uniq nil))
+ (while sorted
+ (if (or (not uniq)
+ (not (string= (semantic-tag-name (car sorted))
+ (semantic-tag-name (car uniq)))))
+ (setq uniq (cons (car sorted) uniq)))
+ (setq sorted (cdr sorted))
+ )
+ (nreverse uniq)))
+
+ (defun semantic-unique-tag-table (tags)
+ "Scan a list of TAGS, removing duplicates.
+ This must first sort the tags by position ascending.
+ TAGS are removed only if they are equivalent, as can happen when
+ multiple tag sources are scanned.
+ For more complex uniqueness testing used by the semanticdb
+ typecaching system, see `semanticdb-typecache-merge-streams'."
+ (let ((sorted (sort (copy-sequence tags)
+ (lambda (a b)
+ (cond ((not (semantic-tag-with-position-p a))
+ t)
+ ((not (semantic-tag-with-position-p b))
+ nil)
+ (t
+ (< (semantic-tag-start a)
+ (semantic-tag-start b)))))))
+ (uniq nil))
+ (while sorted
+ (if (or (not uniq)
+ (not (semantic-equivalent-tag-p (car sorted) (car uniq))))
+ (setq uniq (cons (car sorted) uniq)))
+ (setq sorted (cdr sorted))
+ )
+ (nreverse uniq)))
+
+ \f
+ ;;; Tag Table Flattening
+ ;;
+ ;; In the 1.4 search API, there was a parameter "search-parts" which
+ ;; was used to find tags inside other tags. This was used
+ ;; infrequently, mostly for completion/jump routines. These types
+ ;; of commands would be better off with a flattened list, where all
+ ;; tags appear at the top level.
+
+ ;;;###autoload
+ (defun semantic-flatten-tags-table (&optional table)
+ "Flatten the tags table TABLE.
+ All tags in TABLE, and all components of top level tags
+ in TABLE will appear at the top level of list.
+ Tags promoted to the top of the list will still appear
+ unmodified as components of their parent tags."
+ (let* ((table (semantic-something-to-tag-table table))
+ ;; Initialize the starting list with our table.
+ (lists (list table)))
+ (mapc (lambda (tag)
+ (let ((components (semantic-tag-components tag)))
+ (if (and components
+ ;; unpositined tags can be hazardous to
+ ;; completion. Do we need any type of tag
+ ;; here? - EL
+ (semantic-tag-with-position-p (car components)))
+ (setq lists (cons
+ (semantic-flatten-tags-table components)
+ lists)))))
+ table)
+ (apply 'append (nreverse lists))
+ ))
+
+ \f
+ ;;; Buckets:
+ ;;
+ ;; A list of tags can be grouped into buckets based on the tag class.
+ ;; Bucketize means to take a list of tags at a given level in a tag
+ ;; table, and reorganize them into buckets based on class.
+ ;;
+ (defvar semantic-bucketize-tag-class
+ ;; Must use lambda because `semantic-tag-class' is a macro.
+ (lambda (tok) (semantic-tag-class tok))
+ "Function used to get a symbol describing the class of a tag.
+ This function must take one argument of a semantic tag.
+ It should return a symbol found in `semantic-symbol->name-assoc-list'
+ which `semantic-bucketize' uses to bin up tokens.
+ To create new bins for an application augment
+ `semantic-symbol->name-assoc-list', and
+ `semantic-symbol->name-assoc-list-for-type-parts' in addition
+ to setting this variable (locally in your function).")
+
+ (defun semantic-bucketize (tags &optional parent filter)
+ "Sort TAGS into a group of buckets based on tag class.
+ Unknown classes are placed in a Misc bucket.
+ Type bucket names are defined by either `semantic-symbol->name-assoc-list'.
+ If PARENT is specified, then TAGS belong to this PARENT in some way.
+ This will use `semantic-symbol->name-assoc-list-for-type-parts' to
+ generate bucket names.
+ Optional argument FILTER is a filter function to be applied to each bucket.
+ The filter function will take one argument, which is a list of tokens, and
+ may re-organize the list with side-effects."
+ (let* ((name-list (if parent
+ semantic-symbol->name-assoc-list-for-type-parts
+ semantic-symbol->name-assoc-list))
+ (sn name-list)
+ (bins (make-vector (1+ (length sn)) nil))
+ ask tagtype
+ (nsn nil)
+ (num 1)
+ (out nil))
+ ;; Build up the bucket vector
+ (while sn
+ (setq nsn (cons (cons (car (car sn)) num) nsn)
+ sn (cdr sn)
+ num (1+ num)))
+ ;; Place into buckets
+ (while tags
+ (setq tagtype (funcall semantic-bucketize-tag-class (car tags))
+ ask (assq tagtype nsn)
+ num (or (cdr ask) 0))
+ (aset bins num (cons (car tags) (aref bins num)))
+ (setq tags (cdr tags)))
+ ;; Remove from buckets into a list.
+ (setq num 1)
+ (while (< num (length bins))
+ (when (aref bins num)
+ (setq out
+ (cons (cons
+ (cdr (nth (1- num) name-list))
+ ;; Filtering, First hacked by David Ponce david@dponce.com
+ (funcall (or filter 'nreverse) (aref bins num)))
+ out)))
+ (setq num (1+ num)))
+ (if (aref bins 0)
+ (setq out (cons (cons "Misc"
+ (funcall (or filter 'nreverse) (aref bins 0)))
+ out)))
+ (nreverse out)))
+ \f
+ ;;; Adoption
+ ;;
+ ;; Some languages allow children of a type to be defined outside
+ ;; the syntactic scope of that class. These routines will find those
+ ;; external members, and bring them together in a cloned copy of the
+ ;; class tag.
+ ;;
+ (defvar semantic-orphaned-member-metaparent-type "class"
+ "In `semantic-adopt-external-members', the type of 'type for metaparents.
+ A metaparent is a made-up type semantic token used to hold the child list
+ of orphaned members of a named type.")
+ (make-variable-buffer-local 'semantic-orphaned-member-metaparent-type)
+
+ (defvar semantic-mark-external-member-function nil
+ "Function called when an externally defined orphan is found.
+ By default, the token is always marked with the `adopted' property.
+ This function should be locally bound by a program that needs
+ to add additional behaviors into the token list.
+ This function is called with two arguments. The first is TOKEN which is
+ a shallow copy of the token to be modified. The second is the PARENT
+ which is adopting TOKEN. This function should return TOKEN (or a copy of it)
+ which is then integrated into the revised token list.")
+
+ (defun semantic-adopt-external-members (tags)
+ "Rebuild TAGS so that externally defined members are regrouped.
+ Some languages such as C++ and CLOS permit the declaration of member
+ functions outside the definition of the class. It is easier to study
+ the structure of a program when such methods are grouped together
+ more logically.
+
+ This function uses `semantic-tag-external-member-p' to
+ determine when a potential child is an externally defined member.
+
+ Note: Applications which use this function must account for token
+ types which do not have a position, but have children which *do*
+ have positions.
+
+ Applications should use `semantic-mark-external-member-function'
+ to modify all tags which are found as externally defined to some
+ type. For example, changing the token type for generating extra
+ buckets with the bucket function."
+ (let ((parent-buckets nil)
+ (decent-list nil)
+ (out nil)
+ (tmp nil)
+ )
+ ;; Rebuild the output list, stripping out all parented
+ ;; external entries
+ (while tags
+ (cond
+ ((setq tmp (semantic-tag-external-member-parent (car tags)))
+ (let ((tagcopy (semantic-tag-clone (car tags)))
+ (a (assoc tmp parent-buckets)))
+ (semantic--tag-put-property-no-side-effect tagcopy 'adopted t)
+ (if a
+ ;; If this parent is already in the list, append.
+ (setcdr (nthcdr (1- (length a)) a) (list tagcopy))
+ ;; If not, prepend this new parent bucket into our list
+ (setq parent-buckets
+ (cons (cons tmp (list tagcopy)) parent-buckets)))
+ ))
+ ((eq (semantic-tag-class (car tags)) 'type)
+ ;; Types need to be rebuilt from scratch so we can add in new
+ ;; children to the child list. Only the top-level cons
+ ;; cells need to be duplicated so we can hack out the
+ ;; child list later.
+ (setq out (cons (semantic-tag-clone (car tags)) out))
+ (setq decent-list (cons (car out) decent-list))
+ )
+ (t
+ ;; Otherwise, append this tag to our new output list.
+ (setq out (cons (car tags) out)))
+ )
+ (setq tags (cdr tags)))
+ ;; Rescan out, by descending into all types and finding parents
+ ;; for all entries moved into the parent-buckets.
+ (while decent-list
+ (let* ((bucket (assoc (semantic-tag-name (car decent-list))
+ parent-buckets))
+ (bucketkids (cdr bucket)))
+ (when bucket
+ ;; Run our secondary marking function on the children
+ (if semantic-mark-external-member-function
+ (setq bucketkids
+ (mapcar (lambda (tok)
+ (funcall semantic-mark-external-member-function
+ tok (car decent-list)))
+ bucketkids)))
+ ;; We have some extra kids. Merge.
+ (semantic-tag-put-attribute
+ (car decent-list) :members
+ (append (semantic-tag-type-members (car decent-list))
+ bucketkids))
+ ;; Nuke the bucket label so it is not found again.
+ (setcar bucket nil))
+ (setq decent-list
+ (append (cdr decent-list)
+ ;; get embedded types to scan and make copies
+ ;; of them.
+ (mapcar
+ (lambda (tok) (semantic-tag-clone tok))
+ (semantic-find-tags-by-class 'type
+ (semantic-tag-type-members (car decent-list)))))
+ )))
+ ;; Scan over all remaining lost external methods, and tack them
+ ;; onto the end.
+ (while parent-buckets
+ (if (car (car parent-buckets))
+ (let* ((tmp (car parent-buckets))
+ (fauxtag (semantic-tag-new-type
+ (car tmp)
+ semantic-orphaned-member-metaparent-type
+ nil ;; Part list
+ nil ;; parents (unknown)
+ ))
+ (bucketkids (cdr tmp)))
+ (semantic-tag-set-faux fauxtag) ;; properties
+ (if semantic-mark-external-member-function
+ (setq bucketkids
+ (mapcar (lambda (tok)
+ (funcall semantic-mark-external-member-function
+ tok fauxtag))
+ bucketkids)))
+ (semantic-tag-put-attribute fauxtag :members bucketkids)
+ ;; We have a bunch of methods with no parent in this file.
+ ;; Create a meta-type to hold it.
+ (setq out (cons fauxtag out))
+ ))
+ (setq parent-buckets (cdr parent-buckets)))
+ ;; Return the new list.
+ (nreverse out)))
+
+ \f
+ ;;; External children
+ ;;
+ ;; In order to adopt external children, we need a few overload methods
+ ;; to enable the feature.
+
+ ;;;###autoload
+ (define-overloadable-function semantic-tag-external-member-parent (tag)
+ "Return a parent for TAG when TAG is an external member.
+ TAG is an external member if it is defined at a toplevel and
+ has some sort of label defining a parent. The parent return will
+ be a string.
+
+ The default behavior, if not overridden with
+ `tag-member-parent' gets the 'parent extra
+ specifier of TAG.
+
+ If this function is overridden, use
+ `semantic-tag-external-member-parent-default' to also
+ include the default behavior, and merely extend your own."
+ )
+
+ (defun semantic-tag-external-member-parent-default (tag)
+ "Return the name of TAGs parent only if TAG is not defined in it's parent."
+ ;; Use only the extra spec because a type has a parent which
+ ;; means something completely different.
+ (let ((tp (semantic-tag-get-attribute tag :parent)))
+ (when (stringp tp)
- (string= (semantic-tag-name parent) tp))
- ))
-
-(semantic-alias-obsolete 'semantic-nonterminal-external-member-p
- 'semantic-tag-external-member-p)
++ tp)))
+
+ (define-overloadable-function semantic-tag-external-member-p (parent tag)
+ "Return non-nil if PARENT is the parent of TAG.
+ TAG is an external member of PARENT when it is somehow tagged
+ as having PARENT as it's parent.
+ PARENT and TAG must both be semantic tags.
+
+ The default behavior, if not overridden with
+ `tag-external-member-p' is to match :parent attribute in
+ the name of TAG.
+
+ If this function is overridden, use
+ `semantic-tag-external-member-children-p-default' to also
+ include the default behavior, and merely extend your own."
+ )
+
+ (defun semantic-tag-external-member-p-default (parent tag)
+ "Return non-nil if PARENT is the parent of TAG."
+ ;; Use only the extra spec because a type has a parent which
+ ;; means something completely different.
+ (let ((tp (semantic-tag-external-member-parent tag)))
+ (and (stringp tp)
- nil
- ))
-
-(semantic-alias-obsolete 'semantic-nonterminal-external-member-children
- 'semantic-tag-external-member-children)
++ (string= (semantic-tag-name parent) tp))))
+
+ (define-overloadable-function semantic-tag-external-member-children (tag &optional usedb)
+ "Return the list of children which are not *in* TAG.
+ If optional argument USEDB is non-nil, then also search files in
+ the Semantic Database. If USEDB is a list of databases, search those
+ databases.
+
+ Children in this case are functions or types which are members of
+ TAG, such as the parts of a type, but which are not defined inside
+ the class. C++ and CLOS both permit methods of a class to be defined
+ outside the bounds of the class' definition.
+
+ The default behavior, if not overridden with
+ `tag-external-member-children' is to search using
+ `semantic-tag-external-member-p' in all top level definitions
+ with a parent of TAG.
+
+ If this function is overridden, use
+ `semantic-tag-external-member-children-default' to also
+ include the default behavior, and merely extend your own."
+ )
+
+ (defun semantic-tag-external-member-children-default (tag &optional usedb)
+ "Return list of external children for TAG.
+ Optional argument USEDB specifies if the semantic database is used.
+ See `semantic-tag-external-member-children' for details."
+ (if (and usedb
+ (require 'semantic/db-mode)
+ (semanticdb-minor-mode-p)
+ (require 'semantic/db-find))
+ (let ((m (semanticdb-find-tags-external-children-of-type
+ (semantic-tag-name tag))))
+ (if m (apply #'append (mapcar #'cdr m))))
+ (semantic--find-tags-by-function
+ `(lambda (tok)
+ ;; This bit of annoying backquote forces the contents of
+ ;; tag into the generated lambda.
+ (semantic-tag-external-member-p ',tag tok))
+ (current-buffer))
+ ))
+
+ (define-overloadable-function semantic-tag-external-class (tag)
+ "Return a list of real tags that faux TAG might represent.
+
+ In some languages, a method can be defined on an object which is
+ not in the same file. In this case,
+ `semantic-adopt-external-members' will create a faux-tag. If it
+ is necessary to get the tag from which for faux TAG was most
+ likely derived, then this function is needed."
+ (unless (semantic-tag-faux-p tag)
+ (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p)))
+ (:override)
+ )
+
+ (defun semantic-tag-external-class-default (tag)
+ "Return a list of real tags that faux TAG might represent.
+ See `semantic-tag-external-class' for details."
+ (if (and (require 'semantic/db-mode)
+ (semanticdb-minor-mode-p))
+ (let* ((semanticdb-search-system-databases nil)
+ (m (semanticdb-find-tags-by-class
+ (semantic-tag-class tag)
+ (semanticdb-find-tags-by-name (semantic-tag-name tag)))))
+ (semanticdb-strip-find-results m 'name))
+ ;; Presumably, if the tag is faux, it is not local.
++ nil))
+
+ (provide 'semantic/sort)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/sort"
+ ;; End:
+
+ ;;; semantic-sort.el ends here
--- /dev/null
-(require 'eieio)
-;; (require 'ede)
+ ;;; semantic/symref.el --- Symbol Reference API
+
+ ;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Semantic Symbol Reference API.
+ ;;
+ ;; Semantic's native parsing tools do not handle symbol references.
+ ;; Tracking such information is a task that requires a huge amount of
+ ;; space and processing not apropriate for an Emacs Lisp program.
+ ;;
+ ;; Many desired tools used in refactoring, however, need to have
+ ;; such references available to them. This API aims to provide a
+ ;; range of functions that can be used to identify references. The
+ ;; API is backed by an OO system that is used to allow multiple
+ ;; external tools to provide the information.
+ ;;
+ ;; The default implementation uses a find/grep combination to do a
+ ;; search. This works ok in small projects. For larger projects, it
+ ;; is important to find an alternate tool to use as a back-end to
+ ;; symref.
+ ;;
+ ;; See the command: `semantic-symref' for an example app using this api.
+ ;;
+ ;; TO USE THIS TOOL
+ ;;
+ ;; The following functions can be used to find different kinds of
+ ;; references.
+ ;;
+ ;; `semantic-symref-find-references-by-name'
+ ;; `semantic-symref-find-file-references-by-name'
+ ;; `semantic-symref-find-text'
+ ;;
+ ;; All the search routines return a class of type
+ ;; `semantic-symref-result'. You can reference the various slots, but
+ ;; you will need the following methods to get extended information.
+ ;;
+ ;; `semantic-symref-result-get-files'
+ ;; `semantic-symref-result-get-tags'
+ ;;
+ ;; ADD A NEW EXTERNAL TOOL
+ ;;
+ ;; To support a new external tool, sublcass `semantic-symref-tool-baseclass'
+ ;; and implement the methods. The baseclass provides support for
+ ;; managing external processes that produce parsable output.
+ ;;
+ ;; Your tool should then create an instance of `semantic-symref-result'.
+
+ (require 'semantic)
+
+ (defvar ede-minor-mode)
+ (declare-function data-debug-new-buffer "data-debug")
+ (declare-function data-debug-insert-object-slots "eieio-datadebug")
+ (declare-function ede-toplevel "ede/files")
+ (declare-function ede-project-root-directory "ede/files")
+
+ ;;; Code:
+ (defvar semantic-symref-tool 'detect
+ "*The active symbol reference tool name.
+ The tool symbol can be 'detect, or a symbol that is the name of
+ a tool that can be used for symbol referencing.")
+ (make-variable-buffer-local 'semantic-symref-tool)
+
+ ;;; TOOL SETUP
+ ;;
+ (defvar semantic-symref-tool-alist
+ '( ( (lambda (rootdir) (file-exists-p (expand-file-name "GPATH" rootdir))) .
+ global)
+ ( (lambda (rootdir) (file-exists-p (expand-file-name "ID" rootdir))) .
+ idutils)
+ ( (lambda (rootdir) (file-exists-p (expand-file-name "cscope.out" rootdir))) .
+ cscope )
+ )
+ "Alist of tools usable by `semantic-symref'.
+ Each entry is of the form:
+ ( PREDICATE . KEY )
+ Where PREDICATE is a function that takes a directory name for the
+ root of a project, and returns non-nil if the tool represented by KEY
+ is supported.
+
+ If no tools are supported, then 'grep is assumed.")
+
+ (defun semantic-symref-detect-symref-tool ()
+ "Detect the symref tool to use for the current buffer."
+ (if (not (eq semantic-symref-tool 'detect))
+ semantic-symref-tool
+ ;; We are to perform a detection for the right tool to use.
+ (let* ((rootproj (when (and (featurep 'ede) ede-minor-mode)
+ (ede-toplevel)))
+ (rootdir (if rootproj
+ (ede-project-root-directory rootproj)
+ default-directory))
+ (tools semantic-symref-tool-alist))
+ (while (and tools (eq semantic-symref-tool 'detect))
+ (when (funcall (car (car tools)) rootdir)
+ (setq semantic-symref-tool (cdr (car tools))))
+ (setq tools (cdr tools)))
+
+ (when (eq semantic-symref-tool 'detect)
+ (setq semantic-symref-tool 'grep))
+
+ semantic-symref-tool)))
+
+ (defun semantic-symref-instantiate (&rest args)
+ "Instantiate a new symref search object.
+ ARGS are the initialization arguments to pass to the created class."
+ (let* ((srt (symbol-name (semantic-symref-detect-symref-tool)))
+ (class (intern-soft (concat "semantic-symref-tool-" srt)))
+ (inst nil)
+ )
+ (when (not (class-p class))
+ (error "Unknown symref tool %s" semantic-symref-tool))
+ (setq inst (apply 'make-instance class args))
+ inst))
+
+ (defvar semantic-symref-last-result nil
+ "The last calculated symref result.")
+
+ (defun semantic-symref-data-debug-last-result ()
+ "Run the last symref data result in Data Debug."
+ (interactive)
+ (require 'eieio-datadebug)
+ (if semantic-symref-last-result
+ (progn
+ (data-debug-new-buffer "*Symbol Reference ADEBUG*")
+ (data-debug-insert-object-slots semantic-symref-last-result "]"))
+ (message "Empty results.")))
+
+ ;;; EXTERNAL API
+ ;;
+
+ ;;;###autoload
+ (defun semantic-symref-find-references-by-name (name &optional scope tool-return)
+ "Find a list of references to NAME in the current project.
+ Optional SCOPE specifies which file set to search. Defaults to 'project.
+ Refers to `semantic-symref-tool', to determine the reference tool to use
+ for the current buffer.
+ Returns an object of class `semantic-symref-result'.
+ TOOL-RETURN is an optional symbol, which will be assigned the tool used
+ to perform the search. This was added for use by a test harness."
+ (interactive "sName: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor name
+ :searchtype 'symbol
+ :searchscope (or scope 'project)
+ :resulttype 'line))
+ (result (semantic-symref-get-result inst)))
+ (when tool-return
+ (set tool-return inst))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+ ;;;###autoload
+ (defun semantic-symref-find-tags-by-name (name &optional scope)
+ "Find a list of references to NAME in the current project.
+ Optional SCOPE specifies which file set to search. Defaults to 'project.
+ Refers to `semantic-symref-tool', to determine the reference tool to use
+ for the current buffer.
+ Returns an object of class `semantic-symref-result'."
+ (interactive "sName: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor name
+ :searchtype 'tagname
+ :searchscope (or scope 'project)
+ :resulttype 'line))
+ (result (semantic-symref-get-result inst)))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+ ;;;###autoload
+ (defun semantic-symref-find-tags-by-regexp (name &optional scope)
+ "Find a list of references to NAME in the current project.
+ Optional SCOPE specifies which file set to search. Defaults to 'project.
+ Refers to `semantic-symref-tool', to determine the reference tool to use
+ for the current buffer.
+ Returns an object of class `semantic-symref-result'."
+ (interactive "sName: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor name
+ :searchtype 'tagregexp
+ :searchscope (or scope 'project)
+ :resulttype 'line))
+ (result (semantic-symref-get-result inst)))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+ ;;;###autoload
+ (defun semantic-symref-find-tags-by-completion (name &optional scope)
+ "Find a list of references to NAME in the current project.
+ Optional SCOPE specifies which file set to search. Defaults to 'project.
+ Refers to `semantic-symref-tool', to determine the reference tool to use
+ for the current buffer.
+ Returns an object of class `semantic-symref-result'."
+ (interactive "sName: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor name
+ :searchtype 'tagcompletions
+ :searchscope (or scope 'project)
+ :resulttype 'line))
+ (result (semantic-symref-get-result inst)))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+ ;;;###autoload
+ (defun semantic-symref-find-file-references-by-name (name &optional scope)
+ "Find a list of references to NAME in the current project.
+ Optional SCOPE specifies which file set to search. Defaults to 'project.
+ Refers to `semantic-symref-tool', to determine the reference tool to use
+ for the current buffer.
+ Returns an object of class `semantic-symref-result'."
+ (interactive "sName: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor name
+ :searchtype 'regexp
+ :searchscope (or scope 'project)
+ :resulttype 'file))
+ (result (semantic-symref-get-result inst)))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+ ;;;###autoload
+ (defun semantic-symref-find-text (text &optional scope)
+ "Find a list of occurances of TEXT in the current project.
+ TEXT is a regexp formatted for use with egrep.
+ Optional SCOPE specifies which file set to search. Defaults to 'project.
+ Refers to `semantic-symref-tool', to determine the reference tool to use
+ for the current buffer.
+ Returns an object of class `semantic-symref-result'."
+ (interactive "sEgrep style Regexp: ")
+ (let* ((inst (semantic-symref-instantiate
+ :searchfor text
+ :searchtype 'regexp
+ :searchscope (or scope 'project)
+ :resulttype 'line))
+ (result (semantic-symref-get-result inst)))
+ (prog1
+ (setq semantic-symref-last-result result)
+ (when (interactive-p)
+ (semantic-symref-data-debug-last-result))))
+ )
+
+ ;;; RESULTS
+ ;;
+ ;; The results class and methods provide features for accessing hits.
+ (defclass semantic-symref-result ()
+ ((created-by :initarg :created-by
+ :type semantic-symref-tool-baseclass
+ :documentation
+ "Back-pointer to the symref tool creating these results.")
+ (hit-files :initarg :hit-files
+ :type list
+ :documentation
+ "The list of files hit.")
+ (hit-text :initarg :hit-text
+ :type list
+ :documentation
+ "If the result doesn't provide full lines, then fill in hit-text.
+ GNU Global does completion search this way.")
+ (hit-lines :initarg :hit-lines
+ :type list
+ :documentation
+ "The list of line hits.
+ Each element is a cons cell of the form (LINE . FILENAME).")
+ (hit-tags :initarg :hit-tags
+ :type list
+ :documentation
+ "The list of tags with hits in them.
+ Use the `semantic-symref-hit-tags' method to get this list.")
+ )
+ "The results from a symbol reference search.")
+
+ (defmethod semantic-symref-result-get-files ((result semantic-symref-result))
+ "Get the list of files from the symref result RESULT."
+ (if (slot-boundp result :hit-files)
+ (oref result hit-files)
+ (let* ((lines (oref result :hit-lines))
+ (files (mapcar (lambda (a) (cdr a)) lines))
+ (ans nil))
+ (setq ans (list (car files))
+ files (cdr files))
+ (dolist (F files)
+ ;; This algorithm for uniqing the file list depends on the
+ ;; tool in question providing all the hits in the same file
+ ;; grouped together.
+ (when (not (string= F (car ans)))
+ (setq ans (cons F ans))))
+ (oset result hit-files (nreverse ans))
+ )
+ ))
+
+ (defmethod semantic-symref-result-get-tags ((result semantic-symref-result)
+ &optional open-buffers)
+ "Get the list of tags from the symref result RESULT.
+ Optional OPEN-BUFFERS indicates that the buffers that the hits are
+ in should remain open after scanning.
+ Note: This can be quite slow if most of the hits are not in buffers
+ already."
+ (if (and (slot-boundp result :hit-tags) (oref result hit-tags))
+ (oref result hit-tags)
+ ;; Calculate the tags.
+ (let ((lines (oref result :hit-lines))
+ (txt (oref (oref result :created-by) :searchfor))
+ (searchtype (oref (oref result :created-by) :searchtype))
+ (ans nil)
+ (out nil)
+ (buffs-to-kill nil))
+ (save-excursion
+ (setq
+ ans
+ (mapcar
+ (lambda (hit)
+ (let* ((line (car hit))
+ (file (cdr hit))
+ (buff (get-file-buffer file))
+ (tag nil)
+ )
+ (cond
+ ;; We have a buffer already. Check it out.
+ (buff
+ (set-buffer buff))
+
+ ;; We have a table, but it needs a refresh.
+ ;; This means we should load in that buffer.
+ (t
+ (let ((kbuff
+ (if open-buffers
+ ;; Even if we keep the buffers open, don't
+ ;; let EDE ask lots of questions.
+ (let ((ede-auto-add-method 'never))
+ (find-file-noselect file t))
+ ;; When not keeping the buffers open, then
+ ;; don't setup all the fancy froo-froo features
+ ;; either.
+ (semantic-find-file-noselect file t))))
+ (set-buffer kbuff)
+ (setq buffs-to-kill (cons kbuff buffs-to-kill))
+ (semantic-fetch-tags)
+ ))
+ )
+
+ ;; Too much baggage in goto-line
+ ;; (goto-line line)
+ (goto-char (point-min))
+ (forward-line (1- line))
+
+ ;; Search forward for the matching text
+ (re-search-forward (regexp-quote txt)
+ (point-at-eol)
+ t)
+
+ (setq tag (semantic-current-tag))
+
+ ;; If we are searching for a tag, but bound the tag we are looking
+ ;; for, see if it resides in some other parent tag.
+ ;;
+ ;; If there is no parent tag, then we still need to hang the originator
+ ;; in our list.
+ (when (and (eq searchtype 'symbol)
+ (string= (semantic-tag-name tag) txt))
+ (setq tag (or (semantic-current-tag-parent) tag)))
+
+ ;; Copy the tag, which adds a :filename property.
+ (when tag
+ (setq tag (semantic-tag-copy tag nil t))
+ ;; Ad this hit to the tag.
+ (semantic--tag-put-property tag :hit (list line)))
+ tag))
+ lines)))
+ ;; Kill off dead buffers, unless we were requested to leave them open.
+ (when (not open-buffers)
+ (mapc 'kill-buffer buffs-to-kill))
+ ;; Strip out duplicates.
+ (dolist (T ans)
+ (if (and T (not (semantic-equivalent-tag-p (car out) T)))
+ (setq out (cons T out))
+ (when T
+ ;; Else, add this line into the existing list of lines.
+ (let ((lines (append (semantic--tag-get-property (car out) :hit)
+ (semantic--tag-get-property T :hit))))
+ (semantic--tag-put-property (car out) :hit lines)))
+ ))
+ ;; Out is reversed... twice
+ (oset result :hit-tags (nreverse out)))))
+
+ ;;; SYMREF TOOLS
+ ;;
+ ;; The base symref tool provides something to hang new tools off of
+ ;; for finding symbol references.
+ (defclass semantic-symref-tool-baseclass ()
+ ((searchfor :initarg :searchfor
+ :type string
+ :documentation "The thing to search for.")
+ (searchtype :initarg :searchtype
+ :type symbol
+ :documentation "The type of search to do.
+ Values could be `symbol, `regexp, 'tagname, or 'completion.")
+ (searchscope :initarg :searchscope
+ :type symbol
+ :documentation
+ "The scope to search for.
+ Can be 'project, 'target, or 'file.")
+ (resulttype :initarg :resulttype
+ :type symbol
+ :documentation
+ "The kind of search results desired.
+ Can be 'line, 'file, or 'tag.
+ The type of result can be converted from 'line to 'file, or 'line to 'tag,
+ but not from 'file to 'line or 'tag.")
+ )
+ "Baseclass for all symbol references tools.
+ A symbol reference tool supplies functionality to identify the locations of
+ where different symbols are used.
+
+ Subclasses should be named `semantic-symref-tool-NAME', where
+ NAME is the name of the tool used in the configuration variable
+ `semantic-symref-tool'"
+ :abstract t)
+
+ (defmethod semantic-symref-get-result ((tool semantic-symref-tool-baseclass))
+ "Calculate the results of a search based on TOOL.
+ The symref TOOL should already contain the search criteria."
+ (let ((answer (semantic-symref-perform-search tool))
+ )
+ (when answer
+ (let ((answersym (if (eq (oref tool :resulttype) 'file)
+ :hit-files
+ (if (stringp (car answer))
+ :hit-text
+ :hit-lines))))
+ (semantic-symref-result (oref tool searchfor)
+ answersym
+ answer
+ :created-by tool))
+ )
+ ))
+
+ (defmethod semantic-symref-perform-search ((tool semantic-symref-tool-baseclass))
+ "Base search for symref tools should throw an error."
+ (error "Symref tool objects must implement `semantic-symref-perform-search'"))
+
+ (defmethod semantic-symref-parse-tool-output ((tool semantic-symref-tool-baseclass)
+ outputbuffer)
+ "Parse the entire OUTPUTBUFFER of a symref tool.
+ Calls the method `semantic-symref-parse-tool-output-one-line' over and
+ over until it returns nil."
+ (save-excursion
+ (set-buffer outputbuffer)
+ (goto-char (point-min))
+ (let ((result nil)
+ (hit nil))
+ (while (setq hit (semantic-symref-parse-tool-output-one-line tool))
+ (setq result (cons hit result)))
+ (nreverse result)))
+ )
+
+ (defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-baseclass))
+ "Base tool output parser is not implemented."
+ (error "Symref tool objects must implement `semantic-symref-parse-tool-output-one-line'"))
+
+ (provide 'semantic/symref)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/symref"
+ ;; End:
+
+ ;;; semantic/symref.el ends here
--- /dev/null
- (goto-line (semantic-tag-get-attribute tag :line)))
+ ;;; semantic/tag-file.el --- Routines that find files based on tags.
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+ ;;; 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; A tag, by itself, can have representations in several files.
+ ;; These routines will find those files.
+
+ (require 'semantic/tag)
+
+ (defvar ede-minor-mode)
+ (declare-function semanticdb-table-child-p "semantic/db")
+ (declare-function semanticdb-get-buffer "semantic/db")
+ (declare-function semantic-dependency-find-file-on-path "semantic/dep")
+ (declare-function ede-toplevel "ede/files")
+
+ ;;; Code:
+
+ ;;; Location a TAG came from.
+ ;;
+ ;;;###autoload
+ (define-overloadable-function semantic-go-to-tag (tag &optional parent)
+ "Go to the location of TAG.
+ TAG may be a stripped element, in which case PARENT specifies a
+ parent tag that has position information.
+ PARENT can also be a `semanticdb-table' object."
+ (:override
+ (save-match-data
+ (cond ((semantic-tag-in-buffer-p tag)
+ ;; We have a linked tag, go to that buffer.
+ (set-buffer (semantic-tag-buffer tag)))
+ ((semantic-tag-file-name tag)
+ ;; If it didn't have a buffer, but does have a file
+ ;; name, then we need to get to that file so the tag
+ ;; location is made accurate.
+ (set-buffer (find-file-noselect (semantic-tag-file-name tag))))
+ ((and parent (semantic-tag-p parent) (semantic-tag-in-buffer-p parent))
+ ;; The tag had nothing useful, but we have a parent with
+ ;; a buffer, then go there.
+ (set-buffer (semantic-tag-buffer parent)))
+ ((and parent (semantic-tag-p parent) (semantic-tag-file-name parent))
+ ;; Tag had nothing, and the parent only has a file-name, then
+ ;; find that file, and switch to that buffer.
+ (set-buffer (find-file-noselect (semantic-tag-file-name parent))))
+ ((and parent (featurep 'semantic/db)
+ (semanticdb-table-child-p parent))
+ (set-buffer (semanticdb-get-buffer parent)))
+ (t
+ ;; Well, just assume things are in the current buffer.
+ nil
+ )))
+ ;; We should be in the correct buffer now, try and figure out
+ ;; where the tag is.
+ (cond ((semantic-tag-with-position-p tag)
+ ;; If it's a number, go there
+ (goto-char (semantic-tag-start tag)))
+ ((semantic-tag-with-position-p parent)
+ ;; Otherwise, it's a trimmed vector, such as a parameter,
+ ;; or a structure part. If there is a parent, we can use it
+ ;; as a bounds for searching.
+ (goto-char (semantic-tag-start parent))
+ ;; Here we make an assumption that the text returned by
+ ;; the parser and concocted by us actually exists
+ ;; in the buffer.
+ (re-search-forward (semantic-tag-name tag)
+ (semantic-tag-end parent)
+ t))
+ ((semantic-tag-get-attribute tag :line)
+ ;; The tag has a line number in it. Go there.
- (goto-line (semantic-tag-get-attribute parent :line))
- (re-search-forward (semantic-tag-name tag) nil t)
- )
++ (goto-char (point-min))
++ (forward-line (1- (semantic-tag-get-attribute tag :line))))
+ ((and (semantic-tag-p parent) (semantic-tag-get-attribute parent :line))
+ ;; The tag has a line number in it. Go there.
++ (goto-char (point-min))
++ (forward-line (1- (semantic-tag-get-attribute parent :line)))
++ (re-search-forward (semantic-tag-name tag) nil t))
+ (t
+ ;; Take a guess that the tag has a unique name, and just
+ ;; search for it from the beginning of the buffer.
+ (goto-char (point-min))
+ (re-search-forward (semantic-tag-name tag) nil t)))
+ )
+ )
+
+ (make-obsolete-overload 'semantic-find-nonterminal
+ 'semantic-go-to-tag)
+
+ ;;; Dependencies
+ ;;
+ ;; A tag which is of type 'include specifies a dependency.
+ ;; Dependencies usually represent a file of some sort.
+ ;; Find the file described by a dependency.
+
+ ;;;###autoload
+ (define-overloadable-function semantic-dependency-tag-file (&optional tag)
+ "Find the filename represented from TAG.
+ Depends on `semantic-dependency-include-path' for searching. Always searches
+ `.' first, then searches additional paths."
+ (or tag (setq tag (car (semantic-find-tag-by-overlay nil))))
+ (unless (semantic-tag-of-class-p tag 'include)
+ (signal 'wrong-type-argument (list tag 'include)))
+ (save-excursion
+ (let ((result nil)
+ (default-directory default-directory)
+ (edefind nil)
+ (tag-fname nil))
+ (cond ((semantic-tag-in-buffer-p tag)
+ ;; If the tag has an overlay and buffer associated with it,
+ ;; switch to that buffer so that we get the right override metohds.
+ (set-buffer (semantic-tag-buffer tag)))
+ ((semantic-tag-file-name tag)
+ ;; If it didn't have a buffer, but does have a file
+ ;; name, then we need to get to that file so the tag
+ ;; location is made accurate.
+ ;;(set-buffer (find-file-noselect (semantic-tag-file-name tag)))
+ ;;
+ ;; 2/3/08
+ ;; The above causes unnecessary buffer loads all over the place. Ick!
+ ;; All we really need is for 'default-directory' to be set correctly.
+ (setq default-directory (file-name-directory (semantic-tag-file-name tag)))
+ ))
+ ;; Setup the filename represented by this include
+ (setq tag-fname (semantic-tag-include-filename tag))
+
+ ;; First, see if this file exists in the current EDE project
+ (if (and (fboundp 'ede-expand-filename) ede-minor-mode
+ (setq edefind
+ (condition-case nil
+ (let ((proj (ede-toplevel)))
+ (when proj
+ (ede-expand-filename proj tag-fname)))
+ (error nil))))
+ (setq result edefind))
+ (if (not result)
+ (setq result
+ ;; I don't have a plan for refreshing tags with a dependency
+ ;; stuck on them somehow. I'm thinking that putting a cache
+ ;; onto the dependancy finding with a hash table might be best.
+ ;;(if (semantic--tag-get-property tag 'dependency-file)
+ ;; (semantic--tag-get-property tag 'dependency-file)
+ (:override
+ (save-excursion
+ (require 'semantic/dep)
+ (semantic-dependency-find-file-on-path
+ tag-fname (semantic-tag-include-system-p tag))))
+ ;; )
+ ))
+ (if (stringp result)
+ (progn
+ (semantic--tag-put-property tag 'dependency-file result)
+ result)
+ ;; @todo: Do something to make this get flushed w/
+ ;; when the path is changed.
+ ;; @undo: Just eliminate
+ ;; (semantic--tag-put-property tag 'dependency-file 'none)
+ nil)
+ )))
+
+ (make-obsolete-overload 'semantic-find-dependency
+ 'semantic-dependency-tag-file)
+
+ ;;; PROTOTYPE FILE
+ ;;
+ ;; In C, a function in the .c file often has a representation in a
+ ;; corresponding .h file. This routine attempts to find the
+ ;; prototype file a given source file would be associated with.
+ ;; This can be used by prototype manager programs.
+ (define-overloadable-function semantic-prototype-file (buffer)
+ "Return a file in which prototypes belonging to BUFFER should be placed.
+ Default behavior (if not overridden) looks for a token specifying the
+ prototype file, or the existence of an EDE variable indicating which
+ file prototypes belong in."
+ (:override
+ ;; Perform some default behaviors
+ (if (and (fboundp 'ede-header-file) ede-minor-mode)
+ (save-excursion
+ (set-buffer buffer)
+ (ede-header-file))
+ ;; No EDE options for a quick answer. Search.
+ (save-excursion
+ (set-buffer buffer)
+ (if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t)
+ (match-string 1))))))
+
+ (semantic-alias-obsolete 'semantic-find-nonterminal
+ 'semantic-go-to-tag)
+
+ (semantic-alias-obsolete 'semantic-find-dependency
+ 'semantic-dependency-tag-file)
+
+
+ (provide 'semantic/tag-file)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/tag-file"
+ ;; End:
+
+ ;;; semantic/tag-file.el ends here
--- /dev/null
-;;; Compatibility aliases.
-;;
-(semantic-alias-obsolete 'semantic-nonterminal-protection
- 'semantic-tag-protection)
-(semantic-alias-obsolete 'semantic-nonterminal-protection-default
- 'semantic-tag-protection-default)
-(semantic-alias-obsolete 'semantic-nonterminal-abstract
- 'semantic-tag-abstract-p)
-(semantic-alias-obsolete 'semantic-nonterminal-abstract-default
- 'semantic-tag-abstract-p-default)
-(semantic-alias-obsolete 'semantic-nonterminal-leaf
- 'semantic-tag-leaf-p)
-(semantic-alias-obsolete 'semantic-nonterminal-leaf-default
- 'semantic-tag-leaf-p-default)
-(semantic-alias-obsolete 'semantic-nonterminal-static-default
- 'semantic-tag-static-p-default)
-(semantic-alias-obsolete 'semantic-nonterminal-full-name
- 'semantic-tag-full-name)
-(semantic-alias-obsolete 'semantic-nonterminal-full-name-default
- 'semantic-tag-full-name-default)
-
-;; TEMPORARY within betas of CEDET 1.0
-(semantic-alias-obsolete 'semantic-tag-static 'semantic-tag-static-p)
-(semantic-alias-obsolete 'semantic-tag-leaf 'semantic-tag-leaf-p)
-(semantic-alias-obsolete 'semantic-tag-abstract 'semantic-tag-abstract-p)
-
+ ;;; semantic/tag-ls.el --- Language Specific override functions for tags
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; There are some features of tags that are too langauge dependent to
+ ;; put in the core `semantic-tag' functionality. For instance, the
+ ;; protection of a tag (as specified by UML) could be almost anything.
+ ;; In Java, it is a type specifier. In C, there is a label. This
+ ;; informatin can be derived, and thus should not be stored in the tag
+ ;; itself. These are the functions that languages can use to derive
+ ;; the information.
+
+ (require 'semantic)
+
+ ;;; Code:
+
+ ;;; UML features:
+ ;;
+ ;; UML can represent several types of features of a tag
+ ;; such as the `protection' of a symbol, or if it is abstract,
+ ;; leaf, etc. Learn about UML to catch onto the lingo.
+
+ (define-overloadable-function semantic-tag-calculate-parent (tag)
+ "Attempt to calculate the parent of TAG.
+ The default behavior (if not overriden with `tag-calculate-parent')
+ is to search a buffer found with TAG, and if externally defined,
+ search locally, then semanticdb for that tag (when enabled.)")
+
+ (defun semantic-tag-calculate-parent-default (tag)
+ "Attempt to calculate the parent of TAG."
+ (when (semantic-tag-in-buffer-p tag)
+ (save-excursion
+ (set-buffer (semantic-tag-buffer tag))
+ (save-excursion
+ (goto-char (semantic-tag-start tag))
+ (semantic-current-tag-parent))
+ )))
+
+ (define-overloadable-function semantic-tag-protection (tag &optional parent)
+ "Return protection information about TAG with optional PARENT.
+ This function returns on of the following symbols:
+ nil - No special protection. Language dependent.
+ 'public - Anyone can access this TAG.
+ 'private - Only methods in the local scope can access TAG.
+ 'protected - Like private for outside scopes, like public for child
+ classes.
+ Some languages may choose to provide additional return symbols specific
+ to themselves. Use of this function should allow for this.
+
+ The default behavior (if not overridden with `tag-protection'
+ is to return a symbol based on type modifiers."
+ (and (not parent)
+ (semantic-tag-overlay tag)
+ (semantic-tag-in-buffer-p tag)
+ (setq parent (semantic-tag-calculate-parent tag)))
+ (:override))
+
+ (make-obsolete-overload 'semantic-nonterminal-protection
+ 'semantic-tag-protection)
+
+ (defun semantic-tag-protection-default (tag &optional parent)
+ "Return the protection of TAG as a child of PARENT default action.
+ See `semantic-tag-protection'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (prot nil))
+ (while (and (not prot) mods)
+ (if (stringp (car mods))
+ (let ((s (car mods)))
+ (setq prot
+ ;; A few silly defaults to get things started.
+ (cond ((or (string= s "public")
+ (string= s "extern")
+ (string= s "export"))
+ 'public)
+ ((string= s "private")
+ 'private)
+ ((string= s "protected")
+ 'protected)))))
+ (setq mods (cdr mods)))
+ prot))
+
+ (defun semantic-tag-protected-p (tag protection &optional parent)
+ "Non-nil if TAG is is protected.
+ PROTECTION is a symbol which can be returned by the method
+ `semantic-tag-protection'.
+ PARENT is the parent data type which contains TAG.
+
+ For these PROTECTIONs, true is returned if TAG is:
+ @table @asis
+ @item nil
+ Always true
+ @item private
+ True if nil.
+ @item protected
+ True if private or nil.
+ @item public
+ True if private, protected, or nil.
+ @end table"
+ (if (null protection)
+ t
+ (let ((tagpro (semantic-tag-protection tag parent)))
+ (or (and (eq protection 'private)
+ (null tagpro))
+ (and (eq protection 'protected)
+ (or (null tagpro)
+ (eq tagpro 'private)))
+ (and (eq protection 'public)
+ (not (eq tagpro 'public)))))
+ ))
+
+ (define-overloadable-function semantic-tag-abstract-p (tag &optional parent)
+ "Return non nil if TAG is abstract.
+ Optional PARENT is the parent tag of TAG.
+ In UML, abstract methods and classes have special meaning and behavior
+ in how methods are overridden. In UML, abstract methods are italicized.
+
+ The default behavior (if not overridden with `tag-abstract-p'
+ is to return true if `abstract' is in the type modifiers.")
+
+ (make-obsolete-overload 'semantic-nonterminal-abstract
+ 'semantic-tag-abstract-p)
+
+ (defun semantic-tag-abstract-p-default (tag &optional parent)
+ "Return non-nil if TAG is abstract as a child of PARENT default action.
+ See `semantic-tag-abstract-p'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (abs nil))
+ (while (and (not abs) mods)
+ (if (stringp (car mods))
+ (setq abs (or (string= (car mods) "abstract")
+ (string= (car mods) "virtual"))))
+ (setq mods (cdr mods)))
+ abs))
+
+ (define-overloadable-function semantic-tag-leaf-p (tag &optional parent)
+ "Return non nil if TAG is leaf.
+ Optional PARENT is the parent tag of TAG.
+ In UML, leaf methods and classes have special meaning and behavior.
+
+ The default behavior (if not overridden with `tag-leaf-p'
+ is to return true if `leaf' is in the type modifiers.")
+
+ (make-obsolete-overload 'semantic-nonterminal-leaf
+ 'semantic-tag-leaf-p)
+
+ (defun semantic-tag-leaf-p-default (tag &optional parent)
+ "Return non-nil if TAG is leaf as a child of PARENT default action.
+ See `semantic-tag-leaf-p'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (leaf nil))
+ (while (and (not leaf) mods)
+ (if (stringp (car mods))
+ ;; Use java FINAL as example default. There is none
+ ;; for C/C++
+ (setq leaf (string= (car mods) "final")))
+ (setq mods (cdr mods)))
+ leaf))
+
+ (define-overloadable-function semantic-tag-static-p (tag &optional parent)
+ "Return non nil if TAG is static.
+ Optional PARENT is the parent tag of TAG.
+ In UML, static methods and attributes mean that they are allocated
+ in the parent class, and are not instance specific.
+ UML notation specifies that STATIC entries are underlined.")
+
+ (defun semantic-tag-static-p-default (tag &optional parent)
+ "Return non-nil if TAG is static as a child of PARENT default action.
+ See `semantic-tag-static-p'."
+ (let ((mods (semantic-tag-modifiers tag))
+ (static nil))
+ (while (and (not static) mods)
+ (if (stringp (car mods))
+ (setq static (string= (car mods) "static")))
+ (setq mods (cdr mods)))
+ static))
+
+ ;;;###autoload
+ (define-overloadable-function semantic-tag-prototype-p (tag)
+ "Return non nil if TAG is a prototype.
+ For some laguages, such as C, a prototype is a declaration of
+ something without an implementation."
+ )
+
+ (defun semantic-tag-prototype-p-default (tag)
+ "Non-nil if TAG is a prototype."
+ (let ((p (semantic-tag-get-attribute tag :prototype-flag)))
+ (cond
+ ;; Trust the parser author.
+ (p p)
+ ;; Empty types might be a prototype.
+ ;; @todo - make this better.
+ ((eq (semantic-tag-class tag) 'type)
+ (not (semantic-tag-type-members tag)))
+ ;; No other heuristics.
+ (t nil))
+ ))
+
+ ;;; FULL NAMES
+ ;;
+ ;; For programmer convenience, a full name is not specified in source
+ ;; code. Instead some abbreviation is made, and the local environment
+ ;; will contain the info needed to determine the full name.
+
+ (define-overloadable-function semantic-tag-full-name (tag &optional stream-or-buffer)
+ "Return the fully qualified name of TAG in the package hierarchy.
+ STREAM-OR-BUFFER can be anything convertable by `semantic-something-to-stream',
+ but must be a toplevel semantic tag stream that contains TAG.
+ A Package Hierarchy is defined in UML by the way classes and methods
+ are organized on disk. Some language use this concept such that a
+ class can be accessed via it's fully qualified name, (such as Java.)
+ Other languages qualify names within a Namespace (such as C++) which
+ result in a different package like structure. Languages which do not
+ override this function with `tag-full-name' will use
+ `semantic-tag-name'. Override functions only need to handle
+ STREAM-OR-BUFFER with a tag stream value, or nil."
+ (let ((stream (semantic-something-to-tag-table
+ (or stream-or-buffer tag))))
+ (:override-with-args (tag stream))))
+
+ (make-obsolete-overload 'semantic-nonterminal-full-name
+ 'semantic-tag-full-name)
+
+ (defun semantic-tag-full-name-default (tag stream)
+ "Default method for `semantic-tag-full-name'.
+ Return the name of TAG found in the toplevel STREAM."
+ (semantic-tag-name tag))
+
+ (provide 'semantic/tag-ls)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/tag-ls"
+ ;; End:
+
+ ;;; semantic/tag-ls.el ends here
--- /dev/null
-
-;; @todo - I think we've waited long enough. Lets find out.
-;;
-;; ;; Compatibility code to be removed in future versions.
-;; (unless semantic-tag-expand-function
-;; ;; This line throws a byte compiler warning.
-;; (setq semantic-tag-expand-function semantic-expand-nonterminal)
-;; )
-
+ ;;; semantic/tag.el --- tag creation and access
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+ ;;; 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; I. The core production of semantic is the list of tags produced by the
+ ;; different parsers. This file provides 3 APIs related to tag access:
+ ;;
+ ;; 1) Primitive Tag Access
+ ;; There is a set of common features to all tags. These access
+ ;; functions can get these values.
+ ;; 2) Standard Tag Access
+ ;; A Standard Tag should be produced by most traditional languages
+ ;; with standard styles common to typed object oriented languages.
+ ;; These functions can access these data elements from a tag.
+ ;; 3) Generic Tag Access
+ ;; Access to tag structure in a more direct way.
+ ;; ** May not be forward compatible.
+ ;;
+ ;; II. There is also an API for tag creation. Use `semantic-tag' to create
+ ;; a new tag.
+ ;;
+ ;; III. Tag Comparison. Allows explicit or comparitive tests to see
+ ;; if two tags are the same.
+
+ ;;; Code:
+ ;;
+
+ ;; Keep this only so long as we have obsolete fcns.
+ (require 'semantic/fw)
+ (require 'semantic/lex)
+
+ (declare-function semantic-analyze-split-name "semantic/analyze/fcn")
+ (declare-function semantic-fetch-tags "semantic")
+ (declare-function semantic-clear-toplevel-cache "semantic")
+
+ (defconst semantic-tag-version "2.0pre7"
+ "Version string of semantic tags made with this code.")
+
+ (defconst semantic-tag-incompatible-version "1.0"
+ "Version string of semantic tags which are not currently compatible.
+ These old style tags may be loaded from a file with semantic db.
+ In this case, we must flush the old tags and start over.")
+ \f
+ ;;; Primitive Tag access system:
+ ;;
+ ;; Raw tags in semantic are lists of 5 elements:
+ ;;
+ ;; (NAME CLASS ATTRIBUTES PROPERTIES OVERLAY)
+ ;;
+ ;; Where:
+ ;;
+ ;; - NAME is a string that represents the tag name.
+ ;;
+ ;; - CLASS is a symbol that represent the class of the tag (for
+ ;; example, usual classes are `type', `function', `variable',
+ ;; `include', `package', `code').
+ ;;
+ ;; - ATTRIBUTES is a public list of attributes that describes
+ ;; language data represented by the tag (for example, a variable
+ ;; can have a `:constant-flag' attribute, a function an `:arguments'
+ ;; attribute, etc.).
+ ;;
+ ;; - PROPERTIES is a private list of properties used internally.
+ ;;
+ ;; - OVERLAY represent the location of data described by the tag.
+ ;;
+
+ (defsubst semantic-tag-name (tag)
+ "Return the name of TAG.
+ For functions, variables, classes, typedefs, etc., this is the identifier
+ that is being defined. For tags without an obvious associated name, this
+ may be the statement type, e.g., this may return @code{print} for python's
+ print statement."
+ (car tag))
+
+ (defsubst semantic-tag-class (tag)
+ "Return the class of TAG.
+ That is, the symbol 'variable, 'function, 'type, or other.
+ There is no limit to the symbols that may represent the class of a tag.
+ Each parser generates tags with classes defined by it.
+
+ For functional languages, typical tag classes are:
+
+ @table @code
+ @item type
+ Data types, named map for a memory block.
+ @item function
+ A function or method, or named execution location.
+ @item variable
+ A variable, or named storage for data.
+ @item include
+ Statement that represents a file from which more tags can be found.
+ @item package
+ Statement that declairs this file's package name.
+ @item code
+ Code that has not name or binding to any other symbol, such as in a script.
+ @end table
+ "
+ (nth 1 tag))
+
+ (defsubst semantic-tag-attributes (tag)
+ "Return the list of public attributes of TAG.
+ That is a property list: (ATTRIBUTE-1 VALUE-1 ATTRIBUTE-2 VALUE-2...)."
+ (nth 2 tag))
+
+ (defsubst semantic-tag-properties (tag)
+ "Return the list of private properties of TAG.
+ That is a property list: (PROPERTY-1 VALUE-1 PROPERTY-2 VALUE-2...)."
+ (nth 3 tag))
+
+ (defsubst semantic-tag-overlay (tag)
+ "Return the OVERLAY part of TAG.
+ That is, an overlay or an unloaded buffer representation.
+ This function can also return an array of the form [ START END ].
+ This occurs for tags that are not currently linked into a buffer."
+ (nth 4 tag))
+
+ (defsubst semantic--tag-overlay-cdr (tag)
+ "Return the cons cell whose car is the OVERLAY part of TAG.
+ That function is for internal use only."
+ (nthcdr 4 tag))
+
+ (defsubst semantic--tag-set-overlay (tag overlay)
+ "Set the overlay part of TAG with OVERLAY.
+ That function is for internal use only."
+ (setcar (semantic--tag-overlay-cdr tag) overlay))
+
+ (defsubst semantic-tag-start (tag)
+ "Return the start location of TAG."
+ (let ((o (semantic-tag-overlay tag)))
+ (if (semantic-overlay-p o)
+ (semantic-overlay-start o)
+ (aref o 0))))
+
+ (defsubst semantic-tag-end (tag)
+ "Return the end location of TAG."
+ (let ((o (semantic-tag-overlay tag)))
+ (if (semantic-overlay-p o)
+ (semantic-overlay-end o)
+ (aref o 1))))
+
+ (defsubst semantic-tag-bounds (tag)
+ "Return the location (START END) of data TAG describes."
+ (list (semantic-tag-start tag)
+ (semantic-tag-end tag)))
+
+ (defun semantic-tag-set-bounds (tag start end)
+ "In TAG, set the START and END location of data it describes."
+ (let ((o (semantic-tag-overlay tag)))
+ (if (semantic-overlay-p o)
+ (semantic-overlay-move o start end)
+ (semantic--tag-set-overlay tag (vector start end)))))
+
+ (defun semantic-tag-in-buffer-p (tag)
+ "Return the buffer TAG resides in IFF tag is already in a buffer.
+ If a tag is not in a buffer, return nil."
+ (let ((o (semantic-tag-overlay tag)))
+ ;; TAG is currently linked to a buffer, return it.
+ (when (and (semantic-overlay-p o)
+ (semantic-overlay-live-p o))
+ (semantic-overlay-buffer o))))
+
+ (defsubst semantic--tag-get-property (tag property)
+ "From TAG, extract the value of PROPERTY.
+ Return the value found, or nil if PROPERTY is not one of the
+ properties of TAG.
+ That function is for internal use only."
+ (plist-get (semantic-tag-properties tag) property))
+
+ (defun semantic-tag-buffer (tag)
+ "Return the buffer TAG resides in.
+ If TAG has an originating file, read that file into a (maybe new)
+ buffer, and return it.
+ Return nil if there is no buffer for this tag."
+ (let ((buff (semantic-tag-in-buffer-p tag)))
+ (if buff
+ buff
+ ;; TAG has an originating file, read that file into a buffer, and
+ ;; return it.
+ (if (semantic--tag-get-property tag :filename)
+ (save-match-data
+ (find-file-noselect (semantic--tag-get-property tag :filename)))
+ ;; TAG is not in Emacs right now, no buffer is available.
+ ))))
+
+ (defun semantic-tag-mode (&optional tag)
+ "Return the major mode active for TAG.
+ TAG defaults to the tag at point in current buffer.
+ If TAG has a :mode property return it.
+ If point is inside TAG bounds, return the major mode active at point.
+ Return the major mode active at beginning of TAG otherwise.
+ See also the function `semantic-ctxt-current-mode'."
+ (or tag (setq tag (semantic-current-tag)))
+ (or (semantic--tag-get-property tag :mode)
+ (let ((buffer (semantic-tag-buffer tag))
+ (start (semantic-tag-start tag))
+ (end (semantic-tag-end tag)))
+ (save-excursion
+ (and buffer (set-buffer buffer))
+ ;; Unless point is inside TAG bounds, move it to the
+ ;; beginning of TAG.
+ (or (and (>= (point) start) (< (point) end))
+ (goto-char start))
+ (semantic-ctxt-current-mode)))))
+
+ (defsubst semantic--tag-attributes-cdr (tag)
+ "Return the cons cell whose car is the ATTRIBUTES part of TAG.
+ That function is for internal use only."
+ (nthcdr 2 tag))
+
+ (defsubst semantic-tag-put-attribute (tag attribute value)
+ "Change value in TAG of ATTRIBUTE to VALUE.
+ If ATTRIBUTE already exists, its value is set to VALUE, otherwise the
+ new ATTRIBUTE VALUE pair is added.
+ Return TAG.
+ Use this function in a parser when not all attributes are known at the
+ same time."
+ (let* ((plist-cdr (semantic--tag-attributes-cdr tag)))
+ (when (consp plist-cdr)
+ (setcar plist-cdr
+ (semantic-tag-make-plist
+ (plist-put (car plist-cdr) attribute value))))
+ tag))
+
+ (defun semantic-tag-put-attribute-no-side-effect (tag attribute value)
+ "Change value in TAG of ATTRIBUTE to VALUE without side effects.
+ All cons cells in the attribute list are replicated so that there
+ are no side effects if TAG is in shared lists.
+ If ATTRIBUTE already exists, its value is set to VALUE, otherwise the
+ new ATTRIBUTE VALUE pair is added.
+ Return TAG."
+ (let* ((plist-cdr (semantic--tag-attributes-cdr tag)))
+ (when (consp plist-cdr)
+ (setcar plist-cdr
+ (semantic-tag-make-plist
+ (plist-put (copy-sequence (car plist-cdr))
+ attribute value))))
+ tag))
+
+ (defsubst semantic-tag-get-attribute (tag attribute)
+ "From TAG, return the value of ATTRIBUTE.
+ ATTRIBUTE is a symbol whose specification value to get.
+ Return the value found, or nil if ATTRIBUTE is not one of the
+ attributes of TAG."
+ (plist-get (semantic-tag-attributes tag) attribute))
+
+ ;; These functions are for internal use only!
+ (defsubst semantic--tag-properties-cdr (tag)
+ "Return the cons cell whose car is the PROPERTIES part of TAG.
+ That function is for internal use only."
+ (nthcdr 3 tag))
+
+ (defun semantic--tag-put-property (tag property value)
+ "Change value in TAG of PROPERTY to VALUE.
+ If PROPERTY already exists, its value is set to VALUE, otherwise the
+ new PROPERTY VALUE pair is added.
+ Return TAG.
+ That function is for internal use only."
+ (let* ((plist-cdr (semantic--tag-properties-cdr tag)))
+ (when (consp plist-cdr)
+ (setcar plist-cdr
+ (semantic-tag-make-plist
+ (plist-put (car plist-cdr) property value))))
+ tag))
+
+ (defun semantic--tag-put-property-no-side-effect (tag property value)
+ "Change value in TAG of PROPERTY to VALUE without side effects.
+ All cons cells in the property list are replicated so that there
+ are no side effects if TAG is in shared lists.
+ If PROPERTY already exists, its value is set to VALUE, otherwise the
+ new PROPERTY VALUE pair is added.
+ Return TAG.
+ That function is for internal use only."
+ (let* ((plist-cdr (semantic--tag-properties-cdr tag)))
+ (when (consp plist-cdr)
+ (setcar plist-cdr
+ (semantic-tag-make-plist
+ (plist-put (copy-sequence (car plist-cdr))
+ property value))))
+ tag))
+
+ (defun semantic-tag-file-name (tag)
+ "Return the name of the file from which TAG originated.
+ Return nil if that information can't be obtained.
+ If TAG is from a loaded buffer, then that buffer's filename is used.
+ If TAG is unlinked, but has a :filename property, then that is used."
+ (let ((buffer (semantic-tag-in-buffer-p tag)))
+ (if buffer
+ (buffer-file-name buffer)
+ (semantic--tag-get-property tag :filename))))
+ \f
+ ;;; Tag tests and comparisons.
+ (defsubst semantic-tag-p (tag)
+ "Return non-nil if TAG is most likely a semantic tag."
+ (condition-case nil
+ (and (consp tag)
+ (stringp (car tag)) ; NAME
+ (symbolp (nth 1 tag)) (nth 1 tag) ; TAG-CLASS
+ (listp (nth 2 tag)) ; ATTRIBUTES
+ (listp (nth 3 tag)) ; PROPERTIES
+ )
+ ;; If an error occurs, then it most certainly is not a tag.
+ (error nil)))
+
+ (defsubst semantic-tag-of-class-p (tag class)
+ "Return non-nil if class of TAG is CLASS."
+ (eq (semantic-tag-class tag) class))
+
+ (defsubst semantic-tag-type-members (tag)
+ "Return the members of the type that TAG describes.
+ That is the value of the `:members' attribute."
+ (semantic-tag-get-attribute tag :members))
+
+ (defsubst semantic-tag-type (tag)
+ "Return the value of the `:type' attribute of TAG.
+ For a function it would be the data type of the return value.
+ For a variable, it is the storage type of that variable.
+ For a data type, the type is the style of datatype, such as
+ struct or union."
+ (semantic-tag-get-attribute tag :type))
+
+ (defun semantic-tag-with-position-p (tag)
+ "Return non-nil if TAG has positional information."
+ (and (semantic-tag-p tag)
+ (let ((o (semantic-tag-overlay tag)))
+ (or (and (semantic-overlay-p o)
+ (semantic-overlay-live-p o))
+ (arrayp o)))))
+
+ (defun semantic-equivalent-tag-p (tag1 tag2)
+ "Compare TAG1 and TAG2 and return non-nil if they are equivalent.
+ Use `equal' on elements the name, class, and position.
+ Use this function if tags are being copied and regrouped to test
+ for if two tags represent the same thing, but may be constructed
+ of different cons cells."
+ (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
+ (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
+ (or (and (not (semantic-tag-overlay tag1))
+ (not (semantic-tag-overlay tag2)))
+ (and (semantic-tag-overlay tag1)
+ (semantic-tag-overlay tag2)
+ (equal (semantic-tag-bounds tag1)
+ (semantic-tag-bounds tag2))))))
+
+ (defun semantic-tag-similar-p (tag1 tag2 &rest ignorable-attributes)
+ "Test to see if TAG1 and TAG2 are similar.
+ Two tags are similar if their name, datatype, and various attributes
+ are the same.
+
+ Similar tags that have sub-tags such as arg lists or type members,
+ are similar w/out checking the sub-list of tags.
+ Optional argument IGNORABLE-ATTRIBUTES are attributes to ignore while comparing similarity."
+ (let* ((A1 (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2))
+ (semantic-tag-of-class-p tag1 (semantic-tag-class tag2))
+ (semantic-tag-of-type-p tag1 (semantic-tag-type tag2))))
+ (attr1 (semantic-tag-attributes tag1))
+ (A2 (= (length attr1) (length (semantic-tag-attributes tag2))))
+ (A3 t)
+ )
+ (when (and (not A2) ignorable-attributes)
+ (setq A2 t))
+ (while (and A2 attr1 A3)
+ (let ((a (car attr1))
+ (v (car (cdr attr1))))
+
+ (cond ((or (eq a :type) ;; already tested above.
+ (memq a ignorable-attributes)) ;; Ignore them...
+ nil)
+
+ ;; Don't test sublists of tags
+ ((and (listp v) (semantic-tag-p (car v)))
+ nil)
+
+ ;; The attributes are not the same?
+ ((not (equal v (semantic-tag-get-attribute tag2 a)))
+ (setq A3 nil))
+ (t
+ nil))
+ )
+ (setq attr1 (cdr (cdr attr1))))
+
+ (and A1 A2 A3)
+ ))
+
+ (defun semantic-tag-similar-with-subtags-p (tag1 tag2 &rest ignorable-attributes)
+ "Test to see if TAG1 and TAG2 are similar.
+ Uses `semantic-tag-similar-p' but also recurses through sub-tags, such
+ as argument lists and type members.
+ Optional argument IGNORABLE-ATTRIBUTES is passed down to
+ `semantic-tag-similar-p'."
+ (let ((C1 (semantic-tag-components tag1))
+ (C2 (semantic-tag-components tag2))
+ )
+ (if (or (/= (length C1) (length C2))
+ (not (semantic-tag-similar-p tag1 tag2 ignorable-attributes))
+ )
+ ;; Basic test fails.
+ nil
+ ;; Else, check component lists.
+ (catch 'component-dissimilar
+ (while C1
+
+ (if (not (semantic-tag-similar-with-subtags-p
+ (car C1) (car C2) ignorable-attributes))
+ (throw 'component-dissimilar nil))
+
+ (setq C1 (cdr C1))
+ (setq C2 (cdr C2))
+ )
+ ;; If we made it this far, we are ok.
+ t) )))
+
+
+ (defun semantic-tag-of-type-p (tag type)
+ "Compare TAG's type against TYPE. Non nil if equivalent.
+ TYPE can be a string, or a tag of class 'type.
+ This can be complex since some tags might have a :type that is a tag,
+ while other tags might just have a string. This function will also be
+ return true of TAG's type is compared directly to the declaration of a
+ data type."
+ (let* ((tagtype (semantic-tag-type tag))
+ (tagtypestring (cond ((stringp tagtype)
+ tagtype)
+ ((and (semantic-tag-p tagtype)
+ (semantic-tag-of-class-p tagtype 'type))
+ (semantic-tag-name tagtype))
+ (t "")))
+ (typestring (cond ((stringp type)
+ type)
+ ((and (semantic-tag-p type)
+ (semantic-tag-of-class-p type 'type))
+ (semantic-tag-name type))
+ (t "")))
+ )
+ (and
+ tagtypestring
+ (or
+ ;; Matching strings (input type is string)
+ (and (stringp type)
+ (string= tagtypestring type))
+ ;; Matching strings (tag type is string)
+ (and (stringp tagtype)
+ (string= tagtype typestring))
+ ;; Matching tokens, and the type of the type is the same.
+ (and (string= tagtypestring typestring)
+ (if (and (semantic-tag-type tagtype) (semantic-tag-type type))
+ (equal (semantic-tag-type tagtype) (semantic-tag-type type))
+ t))
+ ))
+ ))
+
+ (defun semantic-tag-type-compound-p (tag)
+ "Return non-nil the type of TAG is compound.
+ Compound implies a structure or similar data type.
+ Returns the list of tag members if it is compound."
+ (let* ((tagtype (semantic-tag-type tag))
+ )
+ (when (and (semantic-tag-p tagtype)
+ (semantic-tag-of-class-p tagtype 'type))
+ ;; We have the potential of this being a nifty compound type.
+ (semantic-tag-type-members tagtype)
+ )))
+
+ (defun semantic-tag-faux-p (tag)
+ "Return non-nil if TAG is a FAUX tag.
+ FAUX tags are created to represent a construct that is
+ not known to exist in the code.
+
+ Example: When the class browser sees methods to a class, but
+ cannot find the class, it will create a faux tag to represent the
+ class to store those methods."
+ (semantic--tag-get-property tag :faux-flag))
+ \f
+ ;;; Tag creation
+ ;;
+
+ ;; Is this function still necessary?
+ (defun semantic-tag-make-plist (args)
+ "Create a property list with ARGS.
+ Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN).
+ Where KEY is a symbol, and VALUE is the value for that symbol.
+ The return value will be a new property list, with these KEY/VALUE
+ pairs eliminated:
+
+ - KEY associated to nil VALUE.
+ - KEY associated to an empty string VALUE.
+ - KEY associated to a zero VALUE."
+ (let (plist key val)
+ (while args
+ (setq key (car args)
+ val (nth 1 args)
+ args (nthcdr 2 args))
+ (or (member val '("" nil))
+ (and (numberp val) (zerop val))
+ (setq plist (cons key (cons val plist)))))
+ ;; It is not useful to reverse the new plist.
+ plist))
+
+ (defsubst semantic-tag (name class &rest attributes)
+ "Create a generic semantic tag.
+ NAME is a string representing the name of this tag.
+ CLASS is the symbol that represents the class of tag this is,
+ such as 'variable, or 'function.
+ ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (list name class (semantic-tag-make-plist attributes) nil nil))
+
+ (defsubst semantic-tag-new-variable (name type &optional default-value &rest attributes)
+ "Create a semantic tag of class 'variable.
+ NAME is the name of this variable.
+ TYPE is a string or semantic tag representing the type of this variable.
+ Optional DEFAULT-VALUE is a string representing the default value of this variable.
+ ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'variable
+ :type type
+ :default-value default-value
+ attributes))
+
+ (defsubst semantic-tag-new-function (name type arg-list &rest attributes)
+ "Create a semantic tag of class 'function.
+ NAME is the name of this function.
+ TYPE is a string or semantic tag representing the type of this function.
+ ARG-LIST is a list of strings or semantic tags representing the
+ arguments of this function.
+ ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'function
+ :type type
+ :arguments arg-list
+ attributes))
+
+ (defsubst semantic-tag-new-type (name type members parents &rest attributes)
+ "Create a semantic tag of class 'type.
+ NAME is the name of this type.
+ TYPE is a string or semantic tag representing the type of this type.
+ MEMBERS is a list of strings or semantic tags representing the
+ elements that make up this type if it is a composite type.
+ PARENTS is a cons cell. (EXPLICIT-PARENTS . INTERFACE-PARENTS)
+ EXPLICIT-PARENTS can be a single string (Just one parent) or a
+ list of parents (in a multiple inheritance situation). It can also
+ be nil.
+ INTERFACE-PARENTS is a list of strings representing the names of
+ all INTERFACES, or abstract classes inherited from. It can also be
+ nil.
+ This slot can be interesting because the form:
+ ( nil \"string\")
+ is a valid parent where there is no explicit parent, and only an
+ interface.
+ ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'type
+ :type type
+ :members members
+ :superclasses (car parents)
+ :interfaces (cdr parents)
+ attributes))
+
+ (defsubst semantic-tag-new-include (name system-flag &rest attributes)
+ "Create a semantic tag of class 'include.
+ NAME is the name of this include.
+ SYSTEM-FLAG represents that we were able to identify this include as belonging
+ to the system, as opposed to belonging to the local project.
+ ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'include
+ :system-flag system-flag
+ attributes))
+
+ (defsubst semantic-tag-new-package (name detail &rest attributes)
+ "Create a semantic tag of class 'package.
+ NAME is the name of this package.
+ DETAIL is extra information about this package, such as a location where
+ it can be found.
+ ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'package
+ :detail detail
+ attributes))
+
+ (defsubst semantic-tag-new-code (name detail &rest attributes)
+ "Create a semantic tag of class 'code.
+ NAME is a name for this code.
+ DETAIL is extra information about the code.
+ ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'code
+ :detail detail
+ attributes))
+
+ (defsubst semantic-tag-set-faux (tag)
+ "Set TAG to be a new FAUX tag.
+ FAUX tags represent constructs not found in the source code.
+ You can identify a faux tag with `semantic-tag-faux-p'"
+ (semantic--tag-put-property tag :faux-flag t))
+
+ (defsubst semantic-tag-set-name (tag name)
+ "Set TAG name to NAME."
+ (setcar tag name))
+
+ ;;; Copying and cloning tags.
+ ;;
+ (defsubst semantic-tag-clone (tag &optional name)
+ "Clone TAG, creating a new TAG.
+ If optional argument NAME is not nil it specifies a new name for the
+ cloned tag."
+ ;; Right now, TAG is a list.
+ (list (or name (semantic-tag-name tag))
+ (semantic-tag-class tag)
+ (copy-sequence (semantic-tag-attributes tag))
+ (copy-sequence (semantic-tag-properties tag))
+ (semantic-tag-overlay tag)))
+
+ (defun semantic-tag-copy (tag &optional name keep-file)
+ "Return a copy of TAG unlinked from the originating buffer.
+ If optional argument NAME is non-nil it specifies a new name for the
+ copied tag.
+ If optional argument KEEP-FILE is non-nil, and TAG was linked to a
+ buffer, the originating buffer file name is kept in the `:filename'
+ property of the copied tag.
+ If KEEP-FILE is a string, and the orginating buffer is NOT available,
+ then KEEP-FILE is stored on the `:filename' property.
+ This runs the tag hook `unlink-copy-hook`."
+ ;; Right now, TAG is a list.
+ (let ((copy (semantic-tag-clone tag name)))
+
+ ;; Keep the filename if needed.
+ (when keep-file
+ (semantic--tag-put-property
+ copy :filename (or (semantic-tag-file-name copy)
+ (and (stringp keep-file)
+ keep-file)
+ )))
+
+ (when (semantic-tag-with-position-p tag)
+ ;; Convert the overlay to a vector, effectively 'unlinking' the tag.
+ (semantic--tag-set-overlay
+ copy (vector (semantic-tag-start copy) (semantic-tag-end copy)))
+
+ ;; Force the children to be copied also.
+ ;;(let ((chil (semantic--tag-copy-list
+ ;; (semantic-tag-components-with-overlays tag)
+ ;; keep-file)))
+ ;;;; Put the list into TAG.
+ ;;)
+
+ ;; Call the unlink-copy hook. This should tell tools that
+ ;; this tag is not part of any buffer.
+ (when (semantic-overlay-p (semantic-tag-overlay tag))
+ (semantic--tag-run-hooks copy 'unlink-copy-hook))
+ )
+ copy))
+
+ ;;(defun semantic--tag-copy-list (tags &optional keep-file)
+ ;; "Make copies of TAGS and return the list of TAGS."
+ ;; (let ((out nil))
+ ;; (dolist (tag tags out)
+ ;; (setq out (cons (semantic-tag-copy tag nil keep-file)
+ ;; out))
+ ;; )))
+
+ (defun semantic--tag-copy-properties (tag1 tag2)
+ "Copy private properties from TAG1 to TAG2.
+ Return TAG2.
+ This function is for internal use only."
+ (let ((plist (semantic-tag-properties tag1)))
+ (while plist
+ (semantic--tag-put-property tag2 (car plist) (nth 1 plist))
+ (setq plist (nthcdr 2 plist)))
+ tag2))
+
+ ;;; DEEP COPIES
+ ;;
+ (defun semantic-tag-deep-copy-one-tag (tag &optional filter)
+ "Make a deep copy of TAG, applying FILTER to each child-tag.
+ Properties and overlay info are not copied.
+ FILTER takes TAG as an argument, and should returns a semantic-tag.
+ It is safe for FILTER to modify the input tag and return it."
+ (when (not filter) (setq filter 'identity))
+ (when (not (semantic-tag-p tag))
+ (signal 'wrong-type-argument (list tag 'semantic-tag-p)))
+ (funcall filter (list (semantic-tag-name tag)
+ (semantic-tag-class tag)
+ (semantic--tag-deep-copy-attributes
+ (semantic-tag-attributes tag) filter)
+ nil
+ nil)))
+
+ (defun semantic--tag-deep-copy-attributes (attrs &optional filter)
+ "Make a deep copy of ATTRS, applying FILTER to each child-tag.
+
+ It is safe to modify ATTR, and return a permutaion of that list.
+
+ FILTER takes TAG as an argument, and should returns a semantic-tag.
+ It is safe for FILTER to modify the input tag and return it."
+ (when (car attrs)
+ (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag"))
+ (cons (car attrs)
+ (cons (semantic--tag-deep-copy-value (nth 1 attrs) filter)
+ (semantic--tag-deep-copy-attributes (nthcdr 2 attrs) filter)))))
+
+ (defun semantic--tag-deep-copy-value (value &optional filter)
+ "Make a deep copy of VALUE, applying FILTER to each child-tag.
+
+ It is safe to modify VALUE, and return a permutaion of that list.
+
+ FILTER takes TAG as an argument, and should returns a semantic-tag.
+ It is safe for FILTER to modify the input tag and return it."
+ (cond
+ ;; Another tag.
+ ((semantic-tag-p value)
+ (semantic-tag-deep-copy-one-tag value filter))
+
+ ;; A list of more tags
+ ((and (listp value) (semantic-tag-p (car value)))
+ (semantic--tag-deep-copy-tag-list value filter))
+
+ ;; Some arbitrary data.
+ (t value)))
+
+ (defun semantic--tag-deep-copy-tag-list (tags &optional filter)
+ "Make a deep copy of TAGS, applying FILTER to each child-tag.
+
+ It is safe to modify the TAGS list, and return a permutaion of that list.
+
+ FILTER takes TAG as an argument, and should returns a semantic-tag.
+ It is safe for FILTER to modify the input tag and return it."
+ (when (car tags)
+ (if (semantic-tag-p (car tags))
+ (cons (semantic-tag-deep-copy-one-tag (car tags) filter)
+ (semantic--tag-deep-copy-tag-list (cdr tags) filter))
+ (cons (car tags) (semantic--tag-deep-copy-tag-list (cdr tags) filter)))))
+
+ \f
+ ;;; Standard Tag Access
+ ;;
+
+ ;;; Common
+ ;;
+ (defsubst semantic-tag-modifiers (tag)
+ "Return the value of the `:typemodifiers' attribute of TAG."
+ (semantic-tag-get-attribute tag :typemodifiers))
+
+ (defun semantic-tag-docstring (tag &optional buffer)
+ "Return the documentation of TAG.
+ That is the value defined by the `:documentation' attribute.
+ Optional argument BUFFER indicates where to get the text from.
+ If not provided, then only the POSITION can be provided.
+
+ If you want to get documentation for languages that do not store
+ the documentation string in the tag itself, use
+ `semantic-documentation-for-tag' instead."
+ (let ((p (semantic-tag-get-attribute tag :documentation)))
+ (cond
+ ((stringp p) p) ;; it is the doc string.
+
+ ((semantic-lex-token-with-text-p p)
+ (semantic-lex-token-text p))
+
+ ((and (semantic-lex-token-without-text-p p)
+ buffer)
+ (with-current-buffer buffer
+ (semantic-lex-token-text (car (semantic-lex p (1+ p))))))
+
+ (t nil))))
+
+ ;;; Generic attributes for tags of any class.
+ ;;
+ (defsubst semantic-tag-named-parent (tag)
+ "Return the parent of TAG.
+ That is the value of the `:parent' attribute.
+ If a definition can occur outside an actual parent structure, but
+ refers to that parent by name, then the :parent attribute should be used."
+ (semantic-tag-get-attribute tag :parent))
+
+ ;;; Tags of class `type'
+
+ (defun semantic-tag-type-superclasses (tag)
+ "Return the list of superclass names of the type that TAG describes."
+ (let ((supers (semantic-tag-get-attribute tag :superclasses)))
+ (cond ((stringp supers)
+ ;; If we have a string, make it a list.
+ (list supers))
+ ((semantic-tag-p supers)
+ ;; If we have one tag, return just the name.
+ (list (semantic-tag-name supers)))
+ ((and (consp supers) (semantic-tag-p (car supers)))
+ ;; If we have a tag list, then return the names.
+ (mapcar (lambda (s) (semantic-tag-name s))
+ supers))
+ ((consp supers)
+ ;; A list of something, return it.
+ supers))))
+
+ (defun semantic--tag-find-parent-by-name (name supers)
+ "Find the superclass NAME in the list of SUPERS.
+ If a simple search doesn't do it, try splitting up the names
+ in SUPERS."
+ (let ((stag nil))
+ (setq stag (semantic-find-first-tag-by-name name supers))
+
+ (when (not stag)
+ (require 'semantic/analyze/fcn)
+ (dolist (S supers)
+ (let* ((sname (semantic-tag-name S))
+ (splitparts (semantic-analyze-split-name sname))
+ (parts (if (stringp splitparts)
+ (list splitparts)
+ (nreverse splitparts))))
+ (when (string= name (car parts))
+ (setq stag S))
+ )))
+
+ stag))
+
+ (defun semantic-tag-type-superclass-protection (tag parentstring)
+ "Return the inheritance protection in TAG from PARENTSTRING.
+ PARENTSTRING is the name of the parent being inherited.
+ The return protection is a symbol, 'public, 'protection, and 'private."
+ (let ((supers (semantic-tag-get-attribute tag :superclasses)))
+ (cond ((stringp supers)
+ 'public)
+ ((semantic-tag-p supers)
+ (let ((prot (semantic-tag-get-attribute supers :protection)))
+ (or (cdr (assoc prot '(("public" . public)
+ ("protected" . protected)
+ ("private" . private))))
+ 'public)))
+ ((and (consp supers) (stringp (car supers)))
+ 'public)
+ ((and (consp supers) (semantic-tag-p (car supers)))
+ (let* ((stag (semantic--tag-find-parent-by-name parentstring supers))
+ (prot (when stag
+ (semantic-tag-get-attribute stag :protection))))
+ (or (cdr (assoc prot '(("public" . public)
+ ("protected" . protected)
+ ("private" . private))))
+ (when (equal prot "unspecified")
+ (if (semantic-tag-of-type-p tag "class")
+ 'private
+ 'public))
+ 'public))))
+ ))
+
+ (defsubst semantic-tag-type-interfaces (tag)
+ "Return the list of interfaces of the type that TAG describes."
+ ;; @todo - make this as robust as the above.
+ (semantic-tag-get-attribute tag :interfaces))
+
+ ;;; Tags of class `function'
+ ;;
+ (defsubst semantic-tag-function-arguments (tag)
+ "Return the arguments of the function that TAG describes.
+ That is the value of the `:arguments' attribute."
+ (semantic-tag-get-attribute tag :arguments))
+
+ (defsubst semantic-tag-function-throws (tag)
+ "Return the exceptions the function that TAG describes can throw.
+ That is the value of the `:throws' attribute."
+ (semantic-tag-get-attribute tag :throws))
+
+ (defsubst semantic-tag-function-parent (tag)
+ "Return the parent of the function that TAG describes.
+ That is the value of the `:parent' attribute.
+ A function has a parent if it is a method of a class, and if the
+ function does not appear in body of it's parent class."
+ (semantic-tag-named-parent tag))
+
+ (defsubst semantic-tag-function-destructor-p (tag)
+ "Return non-nil if TAG describes a destructor function.
+ That is the value of the `:destructor-flag' attribute."
+ (semantic-tag-get-attribute tag :destructor-flag))
+
+ (defsubst semantic-tag-function-constructor-p (tag)
+ "Return non-nil if TAG describes a constructor function.
+ That is the value of the `:constructor-flag' attribute."
+ (semantic-tag-get-attribute tag :constructor-flag))
+
+ ;;; Tags of class `variable'
+ ;;
+ (defsubst semantic-tag-variable-default (tag)
+ "Return the default value of the variable that TAG describes.
+ That is the value of the attribute `:default-value'."
+ (semantic-tag-get-attribute tag :default-value))
+
+ (defsubst semantic-tag-variable-constant-p (tag)
+ "Return non-nil if the variable that TAG describes is a constant.
+ That is the value of the attribute `:constant-flag'."
+ (semantic-tag-get-attribute tag :constant-flag))
+
+ ;;; Tags of class `include'
+ ;;
+ (defsubst semantic-tag-include-system-p (tag)
+ "Return non-nil if the include that TAG describes is a system include.
+ That is the value of the attribute `:system-flag'."
+ (semantic-tag-get-attribute tag :system-flag))
+
+ (define-overloadable-function semantic-tag-include-filename (tag)
+ "Return a filename representation of TAG.
+ The default action is to return the `semantic-tag-name'.
+ Some languages do not use full filenames in their include statements.
+ Override this method to translate the code represenation
+ into a filename. (A relative filename if necessary.)
+
+ See `semantic-dependency-tag-file' to expand an include
+ tag to a full file name.")
+
+ (defun semantic-tag-include-filename-default (tag)
+ "Return a filename representation of TAG.
+ Returns `semantic-tag-name'."
+ (semantic-tag-name tag))
+
+ ;;; Tags of class `code'
+ ;;
+ (defsubst semantic-tag-code-detail (tag)
+ "Return detail information from code that TAG describes.
+ That is the value of the attribute `:detail'."
+ (semantic-tag-get-attribute tag :detail))
+
+ ;;; Tags of class `alias'
+ ;;
+ (defsubst semantic-tag-new-alias (name meta-tag-class value &rest attributes)
+ "Create a semantic tag of class alias.
+ NAME is a name for this alias.
+ META-TAG-CLASS is the class of the tag this tag is an alias.
+ VALUE is the aliased definition.
+ ATTRIBUTES is a list of additional attributes belonging to this tag."
+ (apply 'semantic-tag name 'alias
+ :aliasclass meta-tag-class
+ :definition value
+ attributes))
+
+ (defsubst semantic-tag-alias-class (tag)
+ "Return the class of tag TAG is an alias."
+ (semantic-tag-get-attribute tag :aliasclass))
+
+ (define-overloadable-function semantic-tag-alias-definition (tag)
+ "Return the definition TAG is an alias.
+ The returned value is a tag of the class that
+ `semantic-tag-alias-class' returns for TAG.
+ The default is to return the value of the :definition attribute.
+ Return nil if TAG is not of class 'alias."
+ (when (semantic-tag-of-class-p tag 'alias)
+ (:override
+ (semantic-tag-get-attribute tag :definition))))
+
+ ;;; Language Specific Tag access via overload
+ ;;
+ ;;;###autoload
+ (define-overloadable-function semantic-tag-components (tag)
+ "Return a list of components for TAG.
+ A Component is a part of TAG which itself may be a TAG.
+ Examples include the elements of a structure in a
+ tag of class `type, or the list of arguments to a
+ tag of class 'function."
+ )
+
+ (defun semantic-tag-components-default (tag)
+ "Return a list of components for TAG.
+ Perform the described task in `semantic-tag-components'."
+ (cond ((semantic-tag-of-class-p tag 'type)
+ (semantic-tag-type-members tag))
+ ((semantic-tag-of-class-p tag 'function)
+ (semantic-tag-function-arguments tag))
+ (t nil)))
+
+ (define-overloadable-function semantic-tag-components-with-overlays (tag)
+ "Return the list of top level components belonging to TAG.
+ Children are any sub-tags which contain overlays.
+
+ Default behavior is to get `semantic-tag-components' in addition
+ to the components of an anonymous types (if applicable.)
+
+ Note for language authors:
+ If a mode defines a language tag that has tags in it with overlays
+ you should still return them with this function.
+ Ignoring this step will prevent several features from working correctly."
+ )
+
+ (defun semantic-tag-components-with-overlays-default (tag)
+ "Return the list of top level components belonging to TAG.
+ Children are any sub-tags which contain overlays.
+ The default action collects regular components of TAG, in addition
+ to any components beloning to an anonymous type."
+ (let ((explicit-children (semantic-tag-components tag))
+ (type (semantic-tag-type tag))
+ (anon-type-children nil)
+ (all-children nil))
+ ;; Identify if this tag has an anonymous structure as
+ ;; its type. This implies it may have children with overlays.
+ (when (and type (semantic-tag-p type))
+ (setq anon-type-children (semantic-tag-components type))
+ ;; Add anonymous children
+ (while anon-type-children
+ (when (semantic-tag-with-position-p (car anon-type-children))
+ (setq all-children (cons (car anon-type-children) all-children)))
+ (setq anon-type-children (cdr anon-type-children))))
+ ;; Add explicit children
+ (while explicit-children
+ (when (semantic-tag-with-position-p (car explicit-children))
+ (setq all-children (cons (car explicit-children) all-children)))
+ (setq explicit-children (cdr explicit-children)))
+ ;; Return
+ (nreverse all-children)))
+
+ (defun semantic-tag-children-compatibility (tag &optional positiononly)
+ "Return children of TAG.
+ If POSITIONONLY is nil, use `semantic-tag-components'.
+ If POSITIONONLY is non-nil, use `semantic-tag-components-with-overlays'.
+ DO NOT use this fcn in new code. Use one of the above instead."
+ (if positiononly
+ (semantic-tag-components-with-overlays tag)
+ (semantic-tag-components tag)))
+ \f
+ ;;; Tag Region
+ ;;
+ ;; A Tag represents a region in a buffer. You can narrow to that tag.
+ ;;
+ (defun semantic-narrow-to-tag (&optional tag)
+ "Narrow to the region specified by the bounds of TAG.
+ See `semantic-tag-bounds'."
+ (interactive)
+ (if (not tag) (setq tag (semantic-current-tag)))
+ (narrow-to-region (semantic-tag-start tag)
+ (semantic-tag-end tag)))
+
+ (defmacro semantic-with-buffer-narrowed-to-current-tag (&rest body)
+ "Execute BODY with the buffer narrowed to the current tag."
+ `(save-restriction
+ (semantic-narrow-to-tag (semantic-current-tag))
+ ,@body))
+ (put 'semantic-with-buffer-narrowed-to-current-tag 'lisp-indent-function 0)
+ (add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec semantic-with-buffer-narrowed-to-current-tag
+ (def-body))))
+
+ (defmacro semantic-with-buffer-narrowed-to-tag (tag &rest body)
+ "Narrow to TAG, and execute BODY."
+ `(save-restriction
+ (semantic-narrow-to-tag ,tag)
+ ,@body))
+ (put 'semantic-with-buffer-narrowed-to-tag 'lisp-indent-function 1)
+ (add-hook 'edebug-setup-hook
+ (lambda ()
+ (def-edebug-spec semantic-with-buffer-narrowed-to-tag
+ (def-body))))
+ \f
+ ;;; Tag Hooks
+ ;;
+ ;; Semantic may want to provide special hooks when specific operations
+ ;; are about to happen on a given tag. These routines allow for hook
+ ;; maintenance on a tag.
+
+ ;; Internal global variable used to manage tag hooks. For example,
+ ;; some implementation of `remove-hook' checks that the hook variable
+ ;; is `default-boundp'.
+ (defvar semantic--tag-hook-value)
+
+ (defun semantic-tag-add-hook (tag hook function &optional append)
+ "Onto TAG, add to the value of HOOK the function FUNCTION.
+ FUNCTION is added (if necessary) at the beginning of the hook list
+ unless the optional argument APPEND is non-nil, in which case
+ FUNCTION is added at the end.
+ HOOK should be a symbol, and FUNCTION may be any valid function.
+ See also the function `add-hook'."
+ (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)))
+ (add-hook 'semantic--tag-hook-value function append)
+ (semantic--tag-put-property tag hook semantic--tag-hook-value)
+ semantic--tag-hook-value))
+
+ (defun semantic-tag-remove-hook (tag hook function)
+ "Onto TAG, remove from the value of HOOK the function FUNCTION.
+ HOOK should be a symbol, and FUNCTION may be any valid function. If
+ FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in
+ the list of hooks to run in HOOK, then nothing is done.
+ See also the function `remove-hook'."
+ (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)))
+ (remove-hook 'semantic--tag-hook-value function)
+ (semantic--tag-put-property tag hook semantic--tag-hook-value)
+ semantic--tag-hook-value))
+
+ (defun semantic--tag-run-hooks (tag hook &rest args)
+ "Run for TAG all expressions saved on the property HOOK.
+ Each hook expression must take at least one argument, the TAG.
+ For any given situation, additional ARGS may be passed."
+ (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))
+ (arglist (cons tag args)))
+ (condition-case err
+ ;; If a hook bombs, ignore it! Usually this is tied into
+ ;; some sort of critical system.
+ (apply 'run-hook-with-args 'semantic--tag-hook-value arglist)
+ (error (message "Error: %S" err)))))
+ \f
+ ;;; Tags and Overlays
+ ;;
+ ;; Overlays are used so that we can quickly identify tags from
+ ;; buffer positions and regions using built in Emacs commands.
+ ;;
+ (defsubst semantic--tag-unlink-list-from-buffer (tags)
+ "Convert TAGS from using an overlay to using an overlay proxy.
+ This function is for internal use only."
+ (mapcar 'semantic--tag-unlink-from-buffer tags))
+
+ (defun semantic--tag-unlink-from-buffer (tag)
+ "Convert TAG from using an overlay to using an overlay proxy.
+ This function is for internal use only."
+ (when (semantic-tag-p tag)
+ (let ((o (semantic-tag-overlay tag)))
+ (when (semantic-overlay-p o)
+ (semantic--tag-set-overlay
+ tag (vector (semantic-overlay-start o)
+ (semantic-overlay-end o)))
+ (semantic-overlay-delete o))
+ ;; Look for a link hook on TAG.
+ (semantic--tag-run-hooks tag 'unlink-hook)
+ ;; Fix the sub-tags which contain overlays.
+ (semantic--tag-unlink-list-from-buffer
+ (semantic-tag-components-with-overlays tag)))))
+
+ (defsubst semantic--tag-link-list-to-buffer (tags)
+ "Convert TAGS from using an overlay proxy to using an overlay.
+ This function is for internal use only."
+ (mapcar 'semantic--tag-link-to-buffer tags))
+
+ (defun semantic--tag-link-to-buffer (tag)
+ "Convert TAG from using an overlay proxy to using an overlay.
+ This function is for internal use only."
+ (when (semantic-tag-p tag)
+ (let ((o (semantic-tag-overlay tag)))
+ (when (and (vectorp o) (= (length o) 2))
+ (setq o (semantic-make-overlay (aref o 0) (aref o 1)
+ (current-buffer)))
+ (semantic--tag-set-overlay tag o)
+ (semantic-overlay-put o 'semantic tag)
+ ;; Clear the :filename property
+ (semantic--tag-put-property tag :filename nil))
+ ;; Look for a link hook on TAG.
+ (semantic--tag-run-hooks tag 'link-hook)
+ ;; Fix the sub-tags which contain overlays.
+ (semantic--tag-link-list-to-buffer
+ (semantic-tag-components-with-overlays tag)))))
+
+ (defun semantic--tag-unlink-cache-from-buffer ()
+ "Convert all tags in the current cache to use overlay proxys.
+ This function is for internal use only."
+ (require 'semantic)
+ (semantic--tag-unlink-list-from-buffer
+ ;; @todo- use fetch-tags-fast?
+ (semantic-fetch-tags)))
+
+ (defvar semantic--buffer-cache)
+
+ (defun semantic--tag-link-cache-to-buffer ()
+ "Convert all tags in the current cache to use overlays.
+ This function is for internal use only."
+ (require 'semantic)
+ (condition-case nil
+ ;; In this unique case, we cannot call the usual toplevel fn.
+ ;; because we don't want a reparse, we want the old overlays.
+ (semantic--tag-link-list-to-buffer
+ semantic--buffer-cache)
+ ;; Recover when there is an error restoring the cache.
+ (error (message "Error recovering tag list")
+ (semantic-clear-toplevel-cache)
+ nil)))
+ \f
+ ;;; Tag Cooking
+ ;;
+ ;; Raw tags from a parser follow a different positional format than
+ ;; those used in the buffer cache. Raw tags need to be cooked into
+ ;; semantic cache friendly tags for use by the masses.
+ ;;
+ (defsubst semantic--tag-expanded-p (tag)
+ "Return non-nil if TAG is expanded.
+ This function is for internal use only.
+ See also the function `semantic--expand-tag'."
+ ;; In fact a cooked tag is actually a list of cooked tags
+ ;; because a raw tag can be expanded in several cooked ones!
+ (when (consp tag)
+ (while (and (semantic-tag-p (car tag))
+ (vectorp (semantic-tag-overlay (car tag))))
+ (setq tag (cdr tag)))
+ (null tag)))
+
+ (defvar semantic-tag-expand-function nil
+ "Function used to expand a tag.
+ It is passed each tag production, and must return a list of tags
+ derived from it, or nil if it does not need to be expanded.
+
+ Languages with compound definitions should use this function to expand
+ from one compound symbol into several. For example, in C or Java the
+ following definition is easily parsed into one tag:
+
+ int a, b;
+
+ This function should take this compound tag and turn it into two tags,
+ one for A, and the other for B.")
+ (make-variable-buffer-local 'semantic-tag-expand-function)
+
+ (defun semantic--tag-expand (tag)
+ "Convert TAG from a raw state to a cooked state, and expand it.
+ Returns a list of cooked tags.
+
+ The parser returns raw tags with positional data START END at the
+ end of the tag data structure (a list for now). We convert it from
+ that to a cooked state that uses an overlay proxy, that is, a vector
+ \[START END].
+
+ The raw tag is changed with side effects and maybe expanded in
+ several derived tags when the variable `semantic-tag-expand-function'
+ is set.
+
+ This function is for internal use only."
+ (if (semantic--tag-expanded-p tag)
+ ;; Just return TAG if it is already expanded (by a grammar
+ ;; semantic action), or if it isn't recognized as a valid
+ ;; semantic tag.
+ tag
+
+ ;; Try to cook the tag. This code will be removed when tag will
+ ;; be directly created with the right format.
+ (condition-case nil
+ (let ((ocdr (semantic--tag-overlay-cdr tag)))
+ ;; OCDR contains the sub-list of TAG whose car is the
+ ;; OVERLAY part of TAG. That is, a list (OVERLAY START END).
+ ;; Convert it into an overlay proxy ([START END]).
+ (semantic--tag-set-overlay
+ tag (vector (nth 1 ocdr) (nth 2 ocdr)))
+ ;; Remove START END positions at end of tag.
+ (setcdr ocdr nil)
+ ;; At this point (length TAG) must be 5!
+ ;;(unless (= (length tag) 5)
+ ;; (error "Tag expansion failed"))
+ )
+ (error
+ (message "A Rule must return a single tag-line list!")
+ (debug tag)
+ nil))
-
-\f
-;;; EDEBUG display support
-;;
-(eval-after-load "cedet-edebug"
- '(progn
- (cedet-edebug-add-print-override
- '(semantic-tag-p object)
- '(concat "#<TAG " (semantic-format-tag-name object) ">"))
- (cedet-edebug-add-print-override
- '(and (listp object) (semantic-tag-p (car object)))
- '(cedet-edebug-prin1-recurse object))
- ))
+ ;; Expand based on local configuration
+ (if semantic-tag-expand-function
+ (or (funcall semantic-tag-expand-function tag)
+ (list tag))
+ (list tag))))
+ \f
+ ;; Foreign tags
+ ;;
+ (defmacro semantic-foreign-tag-invalid (tag)
+ "Signal that TAG is an invalid foreign tag."
+ `(signal 'wrong-type-argument '(semantic-foreign-tag-p ,tag)))
+
+ (defsubst semantic-foreign-tag-p (tag)
+ "Return non-nil if TAG is a foreign tag.
+ That is, a tag unlinked from the originating buffer, which carries the
+ originating buffer file name, and major mode."
+ (and (semantic-tag-p tag)
+ (semantic--tag-get-property tag :foreign-flag)))
+
+ (defsubst semantic-foreign-tag-check (tag)
+ "Check that TAG is a valid foreign tag.
+ Signal an error if not."
+ (or (semantic-foreign-tag-p tag)
+ (semantic-foreign-tag-invalid tag)))
+
+ (defun semantic-foreign-tag (&optional tag)
+ "Return a copy of TAG as a foreign tag, or nil if it can't be done.
+ TAG defaults to the tag at point in current buffer.
+ See also `semantic-foreign-tag-p'."
+ (or tag (setq tag (semantic-current-tag)))
+ (when (semantic-tag-p tag)
+ (let ((ftag (semantic-tag-copy tag nil t))
+ ;; Do extra work for the doc strings, since this is a
+ ;; common use case.
+ (doc (condition-case nil
+ (semantic-documentation-for-tag tag)
+ (error nil))))
+ ;; A foreign tag must carry its originating buffer file name!
+ (when (semantic--tag-get-property ftag :filename)
+ (semantic--tag-put-property ftag :mode (semantic-tag-mode tag))
+ (semantic--tag-put-property ftag :documentation doc)
+ (semantic--tag-put-property ftag :foreign-flag t)
+ ftag))))
+
+ ;; High level obtain/insert foreign tag overloads
+ (define-overloadable-function semantic-obtain-foreign-tag (&optional tag)
+ "Obtain a foreign tag from TAG.
+ TAG defaults to the tag at point in current buffer.
+ Return the obtained foreign tag or nil if failed."
+ (semantic-foreign-tag tag))
+
+ (defun semantic-insert-foreign-tag-default (foreign-tag)
+ "Insert FOREIGN-TAG into the current buffer.
+ The default behavior assumes the current buffer is a language file,
+ and attempts to insert a prototype/function call."
+ ;; Long term goal: Have a mechanism for a tempo-like template insert
+ ;; for the given tag.
+ (insert (semantic-format-tag-prototype foreign-tag)))
+
+ (define-overloadable-function semantic-insert-foreign-tag (foreign-tag)
+ "Insert FOREIGN-TAG into the current buffer.
+ Signal an error if FOREIGN-TAG is not a valid foreign tag.
+ This function is overridable with the symbol `insert-foreign-tag'."
+ (semantic-foreign-tag-check foreign-tag)
+ (:override)
+ (message (semantic-format-tag-summarize foreign-tag)))
+
+ ;;; Support log modes here
+ (define-mode-local-override semantic-insert-foreign-tag
+ log-edit-mode (foreign-tag)
+ "Insert foreign tags into log-edit mode."
+ (insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
+
+ (define-mode-local-override semantic-insert-foreign-tag
+ change-log-mode (foreign-tag)
+ "Insert foreign tags into log-edit mode."
+ (insert (concat "(" (semantic-format-tag-name foreign-tag) "): ")))
-(semantic-alias-obsolete 'semantic-token-name
- 'semantic-tag-name)
-
-(semantic-alias-obsolete 'semantic-token-token
- 'semantic-tag-class)
-
-(semantic-alias-obsolete 'semantic-token-extra-specs
- 'semantic-tag-attributes)
-
-(semantic-alias-obsolete 'semantic-token-properties
- 'semantic-tag-properties)
-
-(semantic-alias-obsolete 'semantic-token-properties-cdr
- 'semantic--tag-properties-cdr)
-
-(semantic-alias-obsolete 'semantic-token-overlay
- 'semantic-tag-overlay)
-
-(semantic-alias-obsolete 'semantic-token-overlay-cdr
- 'semantic--tag-overlay-cdr)
-
-(semantic-alias-obsolete 'semantic-token-start
- 'semantic-tag-start)
-
-(semantic-alias-obsolete 'semantic-token-end
- 'semantic-tag-end)
-
-(semantic-alias-obsolete 'semantic-token-extent
- 'semantic-tag-bounds)
-
-(semantic-alias-obsolete 'semantic-token-buffer
- 'semantic-tag-buffer)
-
-(semantic-alias-obsolete 'semantic-token-put
- 'semantic--tag-put-property)
-
-(semantic-alias-obsolete 'semantic-token-put-no-side-effect
- 'semantic--tag-put-property-no-side-effect)
-
-(semantic-alias-obsolete 'semantic-token-get
- 'semantic--tag-get-property)
-
-(semantic-alias-obsolete 'semantic-token-add-extra-spec
- 'semantic-tag-put-attribute)
-
-(semantic-alias-obsolete 'semantic-token-extra-spec
- 'semantic-tag-get-attribute)
-
-(semantic-alias-obsolete 'semantic-token-type
- 'semantic-tag-type)
-
-(semantic-alias-obsolete 'semantic-token-modifiers
- 'semantic-tag-modifiers)
-
-(semantic-alias-obsolete 'semantic-token-docstring
- 'semantic-tag-docstring)
-
-(semantic-alias-obsolete 'semantic-token-type-parts
- 'semantic-tag-type-members)
-
+ \f
+ ;;; Compatibility
+ ;;
+ (defconst semantic-token-version
+ semantic-tag-version)
+ (defconst semantic-token-incompatible-version
+ semantic-tag-incompatible-version)
+
-(semantic-alias-obsolete 'semantic-token-type-parent-superclass
- 'semantic-tag-type-superclasses)
-
-(semantic-alias-obsolete 'semantic-token-type-parent-implement
- 'semantic-tag-type-interfaces)
-
-(semantic-alias-obsolete 'semantic-token-type-extra-specs
- 'semantic-tag-attributes)
-
-(semantic-alias-obsolete 'semantic-token-type-extra-spec
- 'semantic-tag-get-attribute)
-
-(semantic-alias-obsolete 'semantic-token-type-modifiers
- 'semantic-tag-modifiers)
-
-(semantic-alias-obsolete 'semantic-token-function-args
- 'semantic-tag-function-arguments)
-
-(semantic-alias-obsolete 'semantic-token-function-extra-specs
- 'semantic-tag-attributes)
-
-(semantic-alias-obsolete 'semantic-token-function-extra-spec
- 'semantic-tag-get-attribute)
-
-(semantic-alias-obsolete 'semantic-token-function-modifiers
- 'semantic-tag-modifiers)
-
-(semantic-alias-obsolete 'semantic-token-function-throws
- 'semantic-tag-function-throws)
-
-(semantic-alias-obsolete 'semantic-token-function-parent
- 'semantic-tag-function-parent)
-
-(semantic-alias-obsolete 'semantic-token-function-destructor
- 'semantic-tag-function-destructor-p)
-
-(semantic-alias-obsolete 'semantic-token-variable-default
- 'semantic-tag-variable-default)
-
-(semantic-alias-obsolete 'semantic-token-variable-extra-specs
- 'semantic-tag-attributes)
-
-(semantic-alias-obsolete 'semantic-token-variable-extra-spec
- 'semantic-tag-get-attribute)
-
-(semantic-alias-obsolete 'semantic-token-variable-modifiers
- 'semantic-tag-modifiers)
-
-(semantic-alias-obsolete 'semantic-token-variable-const
- 'semantic-tag-variable-constant-p)
-
-(semantic-alias-obsolete 'semantic-token-variable-optsuffix
- 'semantic-tag-variable-optsuffix)
-
-(semantic-alias-obsolete 'semantic-token-include-system
- 'semantic-tag-include-system-p)
-
-(semantic-alias-obsolete 'semantic-token-p
- 'semantic-tag-p)
-
-(semantic-alias-obsolete 'semantic-token-with-position-p
- 'semantic-tag-with-position-p)
-
+ (defsubst semantic-token-type-parent (tag)
+ "Return the parent of the type that TAG describes.
+ The return value is a list. A value of nil means no parents.
+ The `car' of the list is either the parent class, or a list
+ of parent classes. The `cdr' of the list is the list of
+ interfaces, or abstract classes which are parents of TAG."
+ (cons (semantic-tag-get-attribute tag :superclasses)
+ (semantic-tag-type-interfaces tag)))
+ (make-obsolete 'semantic-token-type-parent
+ "\
+ use `semantic-tag-type-superclass' \
+ and `semantic-tag-type-interfaces' instead")
+
-(semantic-alias-obsolete 'semantic-nonterminal-children
- 'semantic-tag-children-compatibility)
-
-(semantic-alias-obsolete 'semantic-narrow-to-token
- 'semantic-narrow-to-tag)
-
-(semantic-alias-obsolete 'semantic-with-buffer-narrowed-to-current-token
- 'semantic-with-buffer-narrowed-to-current-tag)
-
-(semantic-alias-obsolete 'semantic-with-buffer-narrowed-to-token
- 'semantic-with-buffer-narrowed-to-tag)
-
-(semantic-alias-obsolete 'semantic-deoverlay-token
- 'semantic--tag-unlink-from-buffer)
-
-(semantic-alias-obsolete 'semantic-overlay-token
- 'semantic--tag-link-to-buffer)
-
-(semantic-alias-obsolete 'semantic-deoverlay-list
- 'semantic--tag-unlink-list-from-buffer)
-
-(semantic-alias-obsolete 'semantic-overlay-list
- 'semantic--tag-link-list-to-buffer)
-
-(semantic-alias-obsolete 'semantic-deoverlay-cache
- 'semantic--tag-unlink-cache-from-buffer)
-
-(semantic-alias-obsolete 'semantic-overlay-cache
- 'semantic--tag-link-cache-to-buffer)
-
-(semantic-alias-obsolete 'semantic-cooked-token-p
- 'semantic--tag-expanded-p)
-
+ (semantic-alias-obsolete 'semantic-tag-make-assoc-list
+ 'semantic-tag-make-plist)
+
-(semantic-alias-obsolete 'semantic-raw-to-cooked-token
- 'semantic--tag-expand)
-
-;; Lets test this out during this short transition.
-(semantic-alias-obsolete 'semantic-clone-tag
- 'semantic-tag-clone)
-
-(semantic-alias-obsolete 'semantic-token
- 'semantic-tag)
-
-(semantic-alias-obsolete 'semantic-token-new-variable
- 'semantic-tag-new-variable)
-
-(semantic-alias-obsolete 'semantic-token-new-function
- 'semantic-tag-new-function)
-
-(semantic-alias-obsolete 'semantic-token-new-type
- 'semantic-tag-new-type)
-
-(semantic-alias-obsolete 'semantic-token-new-include
- 'semantic-tag-new-include)
-
-(semantic-alias-obsolete 'semantic-token-new-package
- 'semantic-tag-new-package)
-
-(semantic-alias-obsolete 'semantic-equivalent-tokens-p
- 'semantic-equivalent-tag-p)
-
+ (semantic-varalias-obsolete 'semantic-expand-nonterminal
+ 'semantic-tag-expand-function)
+
+ (provide 'semantic/tag)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/tag"
+ ;; End:
+
+ ;;; semantic/tag.el ends here
--- /dev/null
-(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)
- )
-
+ ;;; semantic/util-modes.el --- Semantic minor modes
+
+ ;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Authors: Eric M. Ludlam <zappo@gnu.org>
+ ;; David Ponce <david@dponce.com>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Semantic utility minor modes.
+ ;;
+
+ ;;; Code:
+ (require 'semantic)
+
- "*If non-nil, show enabled minor modes in the mode line.
+ ;;; 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
- (semantic-propertize "S" 'face 'bold)
- "*Prefix added to minor mode indicators in the mode line."
++ "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
- "*If non-nil enable global use of variable `semantic-highlight-edits-mode'.
++ (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-hook)))
+ (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-hook)
+ (setq arg -1)
+ (setq arg 1)))
+ ;; Add or remove the MODE toggle function from
+ ;; `semantic-init-hook'. Then turn MODE on or off in every
+ ;; Semantic enabled buffer.
+ (cond
+ ;; Turn off if ARG < 0
+ ((< arg 0)
+ (remove-hook 'semantic-init-hook mode)
+ (semantic-map-buffers #'(lambda () (funcall mode -1)))
+ nil)
+ ;; Turn on if ARG > 0
+ ((> arg 0)
+ (add-hook 'semantic-init-hook mode)
+ (semantic-map-buffers #'(lambda () (funcall mode 1)))
+ t)
+ ;; Otherwise just check MODE state
+ (t
+ (memq mode semantic-init-hook))
+ ))
+ \f
+ ;;;;
+ ;;;; Minor mode to highlight areas that a user edits.
+ ;;;;
+
+ ;;;###autoload
+ (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)))
+
+ ;;;###autoload
+ (defcustom global-semantic-highlight-edits-mode nil
- "*Hook run at the end of function `semantic-highlight-edits-mode'."
++ "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
- "*Face used to show dirty tokens in `semantic-highlight-edits-mode'."
++ "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")))
- "*If non-nil, enable global use of `semantic-show-unmatched-syntax-mode'.
++ "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)
+
+ ;;;###autoload
+ (defun semantic-highlight-edits-mode (&optional arg)
+ "Minor mode for highlighting changes made in a buffer.
+ Changes are tracked by semantic so that the incremental parser can work
+ properly.
+ This mode will highlight those changes as they are made, and clear them
+ when the incremental parser accounts for those edits.
+ With prefix argument ARG, turn on if positive, otherwise off. The
+ minor mode can be turned on only if semantic feature is available and
+ the current buffer was set up for parsing. Return non-nil if the
+ minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-highlight-edits-mode 0 1))))
+ (setq semantic-highlight-edits-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-highlight-edits-mode)))
+ (semantic-highlight-edits-mode-setup)
+ (run-hooks 'semantic-highlight-edits-mode-hook)
+ (if (interactive-p)
+ (message "highlight-edits minor mode %sabled"
+ (if semantic-highlight-edits-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-highlight-edits-mode)
+
+ (semantic-add-minor-mode 'semantic-highlight-edits-mode
+ "e"
+ semantic-highlight-edits-mode-map)
+
+ \f
+ ;;;;
+ ;;;; Minor mode to show unmatched-syntax elements
+ ;;;;
+
+ ;;;###autoload
+ (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)))
+
+ ;;;###autoload
+ (defcustom global-semantic-show-unmatched-syntax-mode nil
- "*Hook run at the end of function `semantic-show-unmatched-syntax-mode'."
++ "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
- "*Face used to show unmatched syntax in.
++ "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")))
- "*If non-nil enable global use of `semantic-show-parser-state-mode'.
++ "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)
+
+ ;;;###autoload
+ (defun semantic-show-unmatched-syntax-mode (&optional arg)
+ "Minor mode to highlight unmatched lexical syntax tokens.
+ When a parser executes, some elements in the buffer may not match any
+ parser rules. These text characters are considered unmatched syntax.
+ Often time, the display of unmatched syntax can expose coding
+ problems before the compiler is run.
+
+ With prefix argument ARG, turn on if positive, otherwise off. The
+ minor mode can be turned on only if semantic feature is available and
+ the current buffer was set up for parsing. Return non-nil if the
+ minor mode is enabled.
+
+ \\{semantic-show-unmatched-syntax-mode-map}"
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-show-unmatched-syntax-mode 0 1))))
+ (setq semantic-show-unmatched-syntax-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-show-unmatched-syntax-mode)))
+ (semantic-show-unmatched-syntax-mode-setup)
+ (run-hooks 'semantic-show-unmatched-syntax-mode-hook)
+ (if (interactive-p)
+ (message "show-unmatched-syntax minor mode %sabled"
+ (if semantic-show-unmatched-syntax-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-show-unmatched-syntax-mode)
+
+ (semantic-add-minor-mode 'semantic-show-unmatched-syntax-mode
+ "u"
+ semantic-show-unmatched-syntax-mode-map)
+
+ (defun semantic-show-unmatched-syntax-next ()
+ "Move forward to the next occurrence of unmatched syntax."
+ (interactive)
+ (let ((o (semantic-next-unmatched-syntax (point))))
+ (if o
+ (goto-char (semantic-overlay-start o)))))
+
+ \f
+ ;;;;
+ ;;;; Minor mode to display the parser state in the modeline.
+ ;;;;
+
+ ;;;###autoload
+ (defcustom global-semantic-show-parser-state-mode nil
- "*Hook run at the end of function `semantic-show-parser-state-mode'."
++ "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))))
+
+ ;;;###autoload
+ (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
- "*If non-nil, enable global use of `semantic-stickyfunc-mode'.
++ "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-hook)
+ (add-hook 'semantic-edits-incremental-reparse-failed-hook
+ '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-hook)
+ (add-hook 'semantic-before-idle-scheduler-reparse-hook
+ 'semantic-show-parser-state-auto-marker nil t)
+ (semantic-make-local-hook 'semantic-after-idle-scheduler-reparse-hook)
+ (add-hook 'semantic-after-idle-scheduler-reparse-hook
+ '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-hook
+ '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-hook
+ 'semantic-show-parser-state-auto-marker t)
+ (remove-hook 'semantic-after-idle-scheduler-reparse-hook
+ 'semantic-show-parser-state-marker t)
+ )
+ semantic-show-parser-state-mode)
+
+ ;;;###autoload
+ (defun semantic-show-parser-state-mode (&optional arg)
+ "Minor mode for displaying parser cache state in the modeline.
+ The cache can be in one of three states. They are
+ Up to date, Partial reprase needed, and Full reparse needed.
+ The state is indicated in the modeline with the following characters:
+ `-' -> The cache is up to date.
+ `!' -> The cache requires a full update.
+ `~' -> The cache needs to be incrementally parsed.
+ `%' -> The cache is not currently parseable.
+ `@' -> Auto-parse in progress (not set here.)
+ With prefix argument ARG, turn on if positive, otherwise off. The
+ minor mode can be turned on only if semantic feature is available and
+ the current buffer was set up for parsing. Return non-nil if the
+ minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-show-parser-state-mode 0 1))))
+ (setq semantic-show-parser-state-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-show-parser-state-mode)))
+ (semantic-show-parser-state-mode-setup)
+ (run-hooks 'semantic-show-parser-state-mode-hook)
+ (if (interactive-p)
+ (message "show-parser-state minor mode %sabled"
+ (if semantic-show-parser-state-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-show-parser-state-mode)
+
+ (semantic-add-minor-mode 'semantic-show-parser-state-mode
+ ""
+ semantic-show-parser-state-mode-map)
+
+ (defvar semantic-show-parser-state-string nil
+ "String showing the parser state for this buffer.
+ See `semantic-show-parser-state-marker' for details.")
+ (make-variable-buffer-local 'semantic-show-parser-state-string)
+
+ (defun semantic-show-parser-state-marker (&rest ignore)
+ "Set `semantic-show-parser-state-string' to indicate parser state.
+ This marker is one of the following:
+ `-' -> The cache is up to date.
+ `!' -> The cache requires a full update.
+ `~' -> The cache needs to be incrementally parsed.
+ `%' -> The cache is not currently parseable.
+ `@' -> Auto-parse in progress (not set here.)
+ Arguments IGNORE are ignored, and accepted so this can be used as a hook
+ in many situations."
+ (setq semantic-show-parser-state-string
+ (cond ((semantic-parse-tree-needs-rebuild-p)
+ "!")
+ ((semantic-parse-tree-needs-update-p)
+ "^")
+ ((semantic-parse-tree-unparseable-p)
+ "%")
+ (t
+ "-")))
+ ;;(message "Setup mode line indicator to [%s]" semantic-show-parser-state-string)
+ (semantic-mode-line-update))
+
+ (defun semantic-show-parser-state-auto-marker ()
+ "Hook function run before an autoparse.
+ Set up `semantic-show-parser-state-marker' to show `@'
+ to indicate a parse in progress."
+ (unless (semantic-parse-tree-up-to-date-p)
+ (setq semantic-show-parser-state-string "@")
+ (semantic-mode-line-update)
+ ;; For testing.
+ ;;(sit-for 1)
+ ))
+
+ \f
+ ;;;;
+ ;;;; Minor mode to make function decls sticky.
+ ;;;;
+
+ ;;;###autoload
+ (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)))
+
+ ;;;###autoload
+ (defcustom global-semantic-stickyfunc-mode nil
- "*Hook run at the end of function `semantic-stickyfunc-mode'."
++ "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
- "*String used to indent the stickyfunc header.
++ "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.
+ "")
- "*If non-nil, enable global use of `semantic-highlight-func-mode'.
++ "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)
+
+ ;;;###autoload
+ (defun semantic-stickyfunc-mode (&optional arg)
+ "Minor mode to show the title of a tag in the header line.
+ Enables/disables making the header line of functions sticky.
+ A function (or other tag class specified by
+ `semantic-stickyfunc-sticky-classes') has a header line, meaning the
+ first line which describes the rest of the construct. This first
+ line is what is displayed in the Emacs 21 header line.
+
+ With prefix argument ARG, turn on if positive, otherwise off. The
+ minor mode can be turned on only if semantic feature is available and
+ the current buffer was set up for parsing. Return non-nil if the
+ minor mode is enabled."
+ (interactive
+ (list (or current-prefix-arg
+ (if semantic-stickyfunc-mode 0 1))))
+ (setq semantic-stickyfunc-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not semantic-stickyfunc-mode)))
+ (semantic-stickyfunc-mode-setup)
+ (run-hooks 'semantic-stickyfunc-mode-hook)
+ (if (interactive-p)
+ (message "Stickyfunc minor mode %sabled"
+ (if semantic-stickyfunc-mode "en" "dis")))
+ (semantic-mode-line-update)
+ semantic-stickyfunc-mode)
+
+ (defvar semantic-stickyfunc-sticky-classes
+ '(function type)
+ "List of tag classes which sticky func will display in the header line.")
+ (make-variable-buffer-local 'semantic-stickyfunc-sticky-classes)
+
+ (defun semantic-stickyfunc-tag-to-stick ()
+ "Return the tag to stick at the current point."
+ (let ((tags (nreverse (semantic-find-tag-by-overlay (point)))))
+ ;; Get rid of non-matching tags.
+ (while (and tags
+ (not (member
+ (semantic-tag-class (car tags))
+ semantic-stickyfunc-sticky-classes))
+ )
+ (setq tags (cdr tags)))
+ (car tags)))
+
+ (defun semantic-stickyfunc-fetch-stickyline ()
+ "Make the function at the top of the current window sticky.
+ Capture it's function declaration, and place it in the header line.
+ If there is no function, disable the header line."
+ (let ((str
+ (save-excursion
+ (goto-char (window-start (selected-window)))
+ (forward-line -1)
+ (end-of-line)
+ ;; Capture this function
+ (let* ((tag (semantic-stickyfunc-tag-to-stick)))
+ ;; TAG is nil if there was nothing of the apropriate type there.
+ (if (not tag)
+ ;; Set it to be the text under the header line
+ (buffer-substring (point-at-bol) (point-at-eol))
+ ;; Get it
+ (goto-char (semantic-tag-start tag))
+ ;; Klaus Berndl <klaus.berndl@sdm.de>:
+ ;; goto the tag name; this is especially needed for languages
+ ;; like c++ where a often used style is like:
+ ;; void
+ ;; ClassX::methodM(arg1...)
+ ;; {
+ ;; ...
+ ;; }
+ ;; Without going to the tag-name we would get"void" in the
+ ;; header line which is IMHO not really useful
+ (search-forward (semantic-tag-name tag) nil t)
+ (buffer-substring (point-at-bol) (point-at-eol))
+ ))))
+ (start 0))
+ (while (string-match "%" str start)
+ (setq str (replace-match "%%" t t str 0)
+ start (1+ (match-end 0)))
+ )
+ ;; In 21.4 (or 22.1) the heder doesn't expand tabs. Hmmmm.
+ ;; We should replace them here.
+ ;;
+ ;; This hack assumes that tabs are kept smartly at tab boundaries
+ ;; instead of in a tab boundary where it might only represent 4 spaces.
+ (while (string-match "\t" str start)
+ (setq str (replace-match " " t t str 0)))
+ str))
+
+ (defun semantic-stickyfunc-menu (event)
+ "Popup a menu that can help a user understand stickyfunc-mode.
+ Argument EVENT describes the event that caused this function to be called."
+ (interactive "e")
+ (let* ((startwin (selected-window))
+ (win (car (car (cdr event))))
+ )
+ (select-window win t)
+ (save-excursion
+ (goto-char (window-start win))
+ (sit-for 0)
+ (popup-menu semantic-stickyfunc-popup-menu event)
+ )
+ (select-window startwin)))
+
+
+ (semantic-add-minor-mode 'semantic-stickyfunc-mode
+ "" ;; Don't need indicator. It's quite visible
+ semantic-stickyfunc-mode-map)
+
+
+ \f
+ ;;;;
+ ;;;; Minor mode to make highlight the current function
+ ;;;;
+
+ ;; Highlight the first like of the function we are in if it is different
+ ;; from the the tag going off the top of the screen.
+
+ ;;;###autoload
+ (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)))
+
+ ;;;###autoload
+ (defcustom global-semantic-highlight-func-mode nil
- "*Hook run at the end of function `semantic-highlight-func-mode'."
++ "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)
+
+ ;;;###autoload
+ (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-stickyfunc-sticky-classes') is highlighted, meaning the
+ first line which describes the rest of the construct.
+
+ See `semantic-stickyfunc-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)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: semantic/loaddefs
+ ;; generated-autoload-load-name: "semantic/util-modes"
+ ;; End:
+
+ ;;; semantic/util-modes.el ends here
--- /dev/null
-(require 'assoc)
+ ;;; semantic/util.el --- Utilities for use with semantic tag tables
+
+ ;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007,
+ ;;; 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <zappo@gnu.org>
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Semantic utility API for use with semantic tag tables.
+ ;;
+
-(declare-function semanticdb-file-stream "semantic/db")
-(declare-function semanticdb-abstract-table-child-p "semantic/db")
-(declare-function semanticdb-refresh-table "semantic/db")
-(declare-function semanticdb-get-tags "semantic/db")
-(declare-function semanticdb-find-results-p "semantic/db-find")
-
-;; For semantic-find-tags-by-class, semantic--find-tags-by-function,
-;; and semantic-brute-find-tag-standard:
-(eval-when-compile (require 'semantic/find))
+ (require 'semantic)
+
++(eval-when-compile
++ (require 'semantic/db-find)
++ ;; For semantic-find-tags-by-class, semantic--find-tags-by-function,
++ ;; and semantic-brute-find-tag-standard:
++ (require 'semantic/find))
++
+ (declare-function data-debug-insert-stuff-list "data-debug")
+ (declare-function data-debug-insert-thing "data-debug")
- (let (
- ;(name (thing-at-point 'symbol))
- (strm (cdr (semantic-fetch-tags)))
++(declare-function semantic-ctxt-current-symbol-and-bounds "semantic/ctxt")
+
+ ;;; Code:
+
+ (defvar semantic-type-relation-separator-character '(".")
+ "Character strings used to separate a parent/child relationship.
+ This list of strings are used for displaying or finding separators
+ in variable field dereferencing. The first character will be used for
+ display. In C, a type field is separated like this: \"type.field\"
+ thus, the character is a \".\". In C, and additional value of \"->\"
+ would be in the list, so that \"type->field\" could be found.")
+ (make-variable-buffer-local 'semantic-type-relation-separator-character)
+
+ (defvar semantic-equivalent-major-modes nil
+ "List of major modes which are considered equivalent.
+ Equivalent modes share a parser, and a set of override methods.
+ A value of nil means that the current major mode is the only one.")
+ (make-variable-buffer-local 'semantic-equivalent-major-modes)
+
+ ;; These semanticdb calls will throw warnings in the byte compiler.
+ ;; Doing the right thing to make them available at compile time
+ ;; really messes up the compilation sequence.
+ (defun semantic-file-tag-table (file)
+ "Return a tag table for FILE.
+ If it is loaded, return the stream after making sure it's ok.
+ If FILE is not loaded, check to see if `semanticdb' feature exists,
+ and use it to get tags from files not in memory.
+ If FILE is not loaded, and semanticdb is not available, find the file
+ and parse it."
+ (save-match-data
+ (if (find-buffer-visiting file)
+ (save-excursion
+ (set-buffer (find-buffer-visiting file))
+ (semantic-fetch-tags))
+ ;; File not loaded
+ (if (and (require 'semantic/db-mode)
+ (semanticdb-minor-mode-p))
+ ;; semanticdb is around, use it.
+ (semanticdb-file-stream file)
+ ;; Get the stream ourselves.
+ (save-excursion
+ (set-buffer (find-file-noselect file))
+ (semantic-fetch-tags))))))
+
+ (semantic-alias-obsolete 'semantic-file-token-stream
+ 'semantic-file-tag-table)
+
+ (defun semantic-something-to-tag-table (something)
+ "Convert SOMETHING into a semantic tag table.
+ Something can be a tag with a valid BUFFER property, a tag table, a
+ buffer, or a filename. If SOMETHING is nil return nil."
+ (cond
+ ;; A list of tags
+ ((and (listp something)
+ (semantic-tag-p (car something)))
+ something)
+ ;; A buffer
+ ((bufferp something)
+ (save-excursion
+ (set-buffer something)
+ (semantic-fetch-tags)))
+ ;; A Tag: Get that tag's buffer
+ ((and (semantic-tag-with-position-p something)
+ (semantic-tag-in-buffer-p something))
+ (save-excursion
+ (set-buffer (semantic-tag-buffer something))
+ (semantic-fetch-tags)))
+ ;; Tag with a file name in it
+ ((and (semantic-tag-p something)
+ (semantic-tag-file-name something)
+ (file-exists-p (semantic-tag-file-name something)))
+ (semantic-file-tag-table
+ (semantic-tag-file-name something)))
+ ;; A file name
+ ((and (stringp something)
+ (file-exists-p something))
+ (semantic-file-tag-table something))
+ ;; A Semanticdb table
+ ((and (featurep 'semantic/db)
+ (semanticdb-minor-mode-p)
+ (semanticdb-abstract-table-child-p something))
+ (semanticdb-refresh-table something)
+ (semanticdb-get-tags something))
+ ;; Semanticdb find-results
+ ((and (featurep 'semantic/db)
+ (semanticdb-minor-mode-p)
+ (require 'semantic/db-find)
+ (semanticdb-find-results-p something))
+ (semanticdb-strip-find-results something))
+ ;; NOTE: This commented out since if a search result returns
+ ;; empty, that empty would turn into everything on the next search.
+ ;; Use the current buffer for nil
+ ;; ((null something)
+ ;; (semantic-fetch-tags))
+ ;; don't know what it is
+ (t nil)))
+
+ (semantic-alias-obsolete 'semantic-something-to-stream
+ 'semantic-something-to-tag-table)
+
+ ;;; Recursive searching through dependency trees
+ ;;
+ ;; This will depend on the general searching APIS defined above.
+ ;; but will add full recursion through the dependencies list per
+ ;; stream.
+ (defun semantic-recursive-find-nonterminal-by-name (name buffer)
+ "Recursively find the first occurrence of NAME.
+ Start search with BUFFER. Recurse through all dependencies till found.
+ The return item is of the form (BUFFER TOKEN) where BUFFER is the buffer
+ in which TOKEN (the token found to match NAME) was found.
+
+ THIS ISN'T USED IN SEMANTIC. DELETE ME SOON."
+ (save-excursion
+ (set-buffer buffer)
+ (let* ((stream (semantic-fetch-tags))
+ (includelist (or (semantic-find-tags-by-class 'include stream)
+ "empty.silly.thing"))
+ (found (semantic-find-first-tag-by-name name stream))
+ (unfound nil))
+ (while (and (not found) includelist)
+ (let ((fn (semantic-dependency-tag-file (car includelist))))
+ (if (and fn (not (member fn unfound)))
+ (save-excursion
+ (save-match-data
+ (set-buffer (find-file-noselect fn)))
+ (message "Scanning %s" (buffer-file-name))
+ (setq stream (semantic-fetch-tags))
+ (setq found (semantic-find-first-tag-by-name name stream))
+ (if found
+ (setq found (cons (current-buffer) (list found)))
+ (setq includelist
+ (append includelist
+ (semantic-find-tags-by-class
+ 'include stream))))
+ (setq unfound (cons fn unfound)))))
+ (setq includelist (cdr includelist)))
+ found)))
+ (make-obsolete 'semantic-recursive-find-nonterminal-by-name
+ "Do not use this function.")
+
+ ;;; Completion APIs
+ ;;
+ ;; These functions provide minibuffer reading/completion for lists of
+ ;; nonterminals.
+ (defvar semantic-read-symbol-history nil
+ "History for a symbol read.")
+
+ (defun semantic-read-symbol (prompt &optional default stream filter)
+ "Read a symbol name from the user for the current buffer.
+ PROMPT is the prompt to use.
+ Optional arguments:
+ DEFAULT is the default choice. If no default is given, one is read
+ from under point.
+ STREAM is the list of tokens to complete from.
+ FILTER is provides a filter on the types of things to complete.
+ FILTER must be a function to call on each element."
+ (if (not default) (setq default (thing-at-point 'symbol)))
+ (if (not stream) (setq stream (semantic-fetch-tags)))
+ (setq stream
+ (if filter
+ (semantic--find-tags-by-function filter stream)
+ (semantic-brute-find-tag-standard stream)))
+ (if (and default (string-match ":" prompt))
+ (setq prompt
+ (concat (substring prompt 0 (match-end 0))
+ " (default: " default ") ")))
+ (completing-read prompt stream nil t ""
+ 'semantic-read-symbol-history
+ default))
+
+ (defun semantic-read-variable (prompt &optional default stream)
+ "Read a variable name from the user for the current buffer.
+ PROMPT is the prompt to use.
+ Optional arguments:
+ DEFAULT is the default choice. If no default is given, one is read
+ from under point.
+ STREAM is the list of tokens to complete from."
+ (semantic-read-symbol
+ prompt default
+ (or (semantic-find-tags-by-class
+ 'variable (or stream (current-buffer)))
+ (error "No local variables"))))
+
+ (defun semantic-read-function (prompt &optional default stream)
+ "Read a function name from the user for the current buffer.
+ PROMPT is the prompt to use.
+ Optional arguments:
+ DEFAULT is the default choice. If no default is given, one is read
+ from under point.
+ STREAM is the list of tags to complete from."
+ (semantic-read-symbol
+ prompt default
+ (or (semantic-find-tags-by-class
+ 'function (or stream (current-buffer)))
+ (error "No local functions"))))
+
+ (defun semantic-read-type (prompt &optional default stream)
+ "Read a type name from the user for the current buffer.
+ PROMPT is the prompt to use.
+ Optional arguments:
+ DEFAULT is the default choice. If no default is given, one is read
+ from under point.
+ STREAM is the list of tags to complete from."
+ (semantic-read-symbol
+ prompt default
+ (or (semantic-find-tags-by-class
+ 'type (or stream (current-buffer)))
+ (error "No local types"))))
+
+ \f
+ ;;; Interactive Functions for
+ ;;
+ (defun semantic-describe-tag (&optional tag)
+ "Describe TAG in the minibuffer.
+ If TAG is nil, describe the tag under the cursor."
+ (interactive)
+ (if (not tag) (setq tag (semantic-current-tag)))
+ (semantic-fetch-tags)
+ (if tag (message (semantic-format-tag-summarize tag))))
+
+ \f
+ ;;; Putting keys on tags.
+ ;;
+ (defun semantic-add-label (label value &optional tag)
+ "Add a LABEL with VALUE on TAG.
+ If TAG is not specified, use the tag at point."
+ (interactive "sLabel: \nXValue (eval): ")
+ (if (not tag)
+ (progn
+ (semantic-fetch-tags)
+ (setq tag (semantic-current-tag))))
+ (semantic--tag-put-property tag (intern label) value)
+ (message "Added label %s with value %S" label value))
+
+ (defun semantic-show-label (label &optional tag)
+ "Show the value of LABEL on TAG.
+ If TAG is not specified, use the tag at point."
+ (interactive "sLabel: ")
+ (if (not tag)
+ (progn
+ (semantic-fetch-tags)
+ (setq tag (semantic-current-tag))))
+ (message "%s: %S" label (semantic--tag-get-property tag (intern label))))
+
+ \f
+ ;;; Hacks
+ ;;
+ ;; Some hacks to help me test these functions
+ (defun semantic-describe-buffer-var-helper (varsym buffer)
+ "Display to standard out the value of VARSYM in BUFFER."
+ (require 'data-debug)
+ (let ((value (save-excursion
+ (set-buffer buffer)
+ (symbol-value varsym))))
+ (cond
+ ((and (consp value)
+ (< (length value) 10))
+ ;; Draw the list of things in the list.
+ (princ (format " %s: #<list of %d items>\n"
+ varsym (length value)))
+ (data-debug-insert-stuff-list
+ value " " )
+ )
+ (t
+ ;; Else do a one-liner.
+ (data-debug-insert-thing
+ value " " (concat " " (symbol-name varsym) ": "))
+ ))))
+
+ (defun semantic-describe-buffer ()
+ "Describe the semantic environment for the current buffer."
+ (interactive)
+ (let ((buff (current-buffer))
+ )
+
+ (with-output-to-temp-buffer (help-buffer)
+ (help-setup-xref (list #'semantic-describe-buffer) (interactive-p))
+ (with-current-buffer standard-output
+ (princ "Semantic Configuration in ")
+ (princ (buffer-name buff))
+ (princ "\n\n")
+
+ (princ "Buffer specific configuration items:\n")
+ (let ((vars '(major-mode
+ semantic-case-fold
+ semantic-expand-nonterminal
+ semantic-parser-name
+ semantic-parse-tree-state
+ semantic-lex-analyzer
+ semantic-lex-reset-hooks
+ )))
+ (dolist (V vars)
+ (semantic-describe-buffer-var-helper V buff)))
+
+ (princ "\nGeneral configuration items:\n")
+ (let ((vars '(semantic-inhibit-functions
+ semantic-init-hook
+ semantic-init-db-hook
+ semantic-unmatched-syntax-hook
+ semantic--before-fetch-tags-hook
+ semantic-after-toplevel-bovinate-hook
+ semantic-after-toplevel-cache-change-hook
+ semantic-before-toplevel-cache-flush-hook
+ semantic-dump-parse
+
+ )))
+ (dolist (V vars)
+ (semantic-describe-buffer-var-helper V buff)))
+
+ (princ "\n\n")
+ (mode-local-describe-bindings-2 buff)
+ )))
+ )
+
+ (defun semantic-current-tag-interactive (p)
+ "Display the current token.
+ Argument P is the point to search from in the current buffer."
+ (interactive "d")
+ (require 'semantic/find)
+ (let ((tok (semantic-brute-find-innermost-tag-by-position
+ p (current-buffer))))
+ (message (mapconcat 'semantic-abbreviate-nonterminal tok ","))
+ (car tok))
+ )
+
+ (defun semantic-hack-search ()
+ "Display info about something under the cursor using generic methods."
+ (interactive)
+ (require 'semantic/find)
-; (if name
- (setq res
-; (semantic-find-nonterminal-by-name name strm)
-; (semantic-find-nonterminal-by-type name strm)
-; (semantic-recursive-find-nonterminal-by-name name (current-buffer))
- (semantic-brute-find-tag-by-position (point) strm)
-
- )
-; )
++ (let ((strm (cdr (semantic-fetch-tags)))
+ (res nil))
- (if (and (featurep 'semantic/db) (semanticdb-minor-mode-p))
++ (setq res (semantic-brute-find-tag-by-position (point) strm))
+ (if res
+ (progn
+ (pop-to-buffer "*SEMANTIC HACK RESULTS*")
+ (require 'pp)
+ (erase-buffer)
+ (insert (pp-to-string res) "\n")
+ (goto-char (point-min))
+ (shrink-window-if-larger-than-buffer))
+ (message "nil"))))
+
+ (defun semantic-assert-valid-token (tok)
+ "Assert that TOK is a valid token."
+ (if (semantic-tag-p tok)
+ (if (semantic-tag-with-position-p tok)
+ (let ((o (semantic-tag-overlay tok)))
+ (if (and (semantic-overlay-p o)
+ (not (semantic-overlay-live-p o)))
+ (let ((debug-on-error t))
+ (error "Tag %s is invalid!" (semantic-tag-name tok)))
+ ;; else, tag is OK.
+ ))
+ ;; Positionless tags are also ok.
+ )
+ (let ((debug-on-error t))
+ (error "Not a semantic tag: %S" tok))))
+
+ (defun semantic-sanity-check (&optional cache over notfirst)
+ "Perform a sanity check on the current buffer.
+ The buffer's set of overlays, and those overlays found via the cache
+ are verified against each other.
+ CACHE, and OVER are the semantic cache, and the overlay list.
+ NOTFIRST indicates that this was not the first call in the recursive use."
+ (interactive)
+ (if (and (not cache) (not over) (not notfirst))
+ (setq cache semantic--buffer-cache
+ over (semantic-overlays-in (point-min) (point-max))))
+ (while cache
+ (let ((chil (semantic-tag-components-with-overlays (car cache))))
+ (if (not (memq (semantic-tag-overlay (car cache)) over))
+ (message "Tag %s not in buffer overlay list."
+ (semantic-format-tag-concise-prototype (car cache))))
+ (setq over (delq (semantic-tag-overlay (car cache)) over))
+ (setq over (semantic-sanity-check chil over t))
+ (setq cache (cdr cache))))
+ (if (not notfirst)
+ ;; Strip out all overlays which aren't semantic overlays
+ (let ((o nil))
+ (while over
+ (when (and (semantic-overlay-get (car over) 'semantic)
+ (not (eq (semantic-overlay-get (car over) 'semantic)
+ 'unmatched)))
+ (setq o (cons (car over) o)))
+ (setq over (cdr over)))
+ (message "Remaining overlays: %S" o)))
+ over)
+
+ ;;; Interactive commands (from Senator).
+
+ ;; The Senator library from upstream CEDET is not included in the
+ ;; built-in version of Emacs. The plan is to fold it into the
+ ;; different parts of CEDET and Emacs, so that it works
+ ;; "transparently". Here are some interactive commands based on
+ ;; Senator.
+
+ ;; Symbol completion
+
+ (defun semantic-find-tag-for-completion (prefix)
+ "Find all tags with name starting with PREFIX.
+ This uses `semanticdb' when available."
+ (let (result ctxt)
+ ;; Try the Semantic analyzer
+ (condition-case nil
+ (and (featurep 'semantic/analyze)
+ (setq ctxt (semantic-analyze-current-context))
+ (setq result (semantic-analyze-possible-completions ctxt)))
+ (error nil))
+ (or result
+ ;; If the analyzer fails, then go into boring completion.
++ (if (and (featurep 'semantic/db)
++ (semanticdb-minor-mode-p)
++ (require 'semantic/db-find))
+ (semanticdb-fast-strip-find-results
+ (semanticdb-deep-find-tags-for-completion prefix))
+ (semantic-deep-find-tags-for-completion prefix (current-buffer))))))
+
+ (defun semantic-complete-symbol (&optional predicate)
+ "Complete the symbol under point, using Semantic facilities.
+ When called from a program, optional arg PREDICATE is a predicate
+ determining which symbols are considered."
+ (interactive)
++ (require 'semantic/ctxt)
+ (let* ((start (car (nth 2 (semantic-ctxt-current-symbol-and-bounds
+ (point)))))
+ (pattern (regexp-quote (buffer-substring start (point))))
+ collection completion)
+ (when start
+ (if (and semantic--completion-cache
+ (eq (nth 0 semantic--completion-cache) (current-buffer))
+ (= (nth 1 semantic--completion-cache) start)
+ (save-excursion
+ (goto-char start)
+ (looking-at (nth 3 semantic--completion-cache))))
+ ;; Use cached value.
+ (setq collection (nthcdr 4 semantic--completion-cache))
+ ;; Perform new query.
+ (setq collection (semantic-find-tag-for-completion pattern))
+ (setq semantic--completion-cache
+ (append (list (current-buffer) start 0 pattern)
+ collection))))
+ (if (null collection)
+ (let ((str (if pattern (format " for \"%s\"" pattern) "")))
+ (if (window-minibuffer-p (selected-window))
+ (minibuffer-message (format " [No completions%s]" str))
+ (message "Can't find completion%s" str)))
+ (setq completion (try-completion pattern collection predicate))
+ (if (string= pattern completion)
+ (let ((list (all-completions pattern collection predicate)))
+ (setq list (sort list 'string<))
+ (if (> (length list) 1)
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list list pattern))
+ ;; Bury any out-of-date completions buffer.
+ (let ((win (get-buffer-window "*Completions*" 0)))
+ (if win (with-selected-window win (bury-buffer))))))
+ ;; Exact match
+ (delete-region start (point))
+ (insert completion)
+ ;; Bury any out-of-date completions buffer.
+ (let ((win (get-buffer-window "*Completions*" 0)))
+ (if win (with-selected-window win (bury-buffer))))))))
+
+ (provide 'semantic/util)
+
+ ;;; Minor modes
+ ;;
+ (require 'semantic/util-modes)
+
+ ;;; semantic/util.el ends here
--- /dev/null
-;; X-RCS: $Id: wisent.el,v 1.39 2009/01/10 00:15:49 zappo Exp $
+ ;;; semantic/wisent/wisent.el --- GNU Bison for Emacs - Runtime
+
+ ;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2009
+ ;;; Free Software Foundation, Inc.
+
+ ;; Author: David Ponce <david@dponce.com>
+ ;; Maintainer: David Ponce <david@dponce.com>
+ ;; Created: 30 January 2002
+ ;; Keywords: syntax
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Parser engine and runtime of Wisent.
+ ;;
+ ;; Wisent (the European Bison ;-) is an Elisp implementation of the
+ ;; GNU Compiler Compiler Bison. The Elisp code is a port of the C
+ ;; code of GNU Bison 1.28 & 1.31.
+ ;;
+ ;; For more details on the basic concepts for understanding Wisent,
+ ;; read the Bison manual ;)
+ ;;
+ ;; For more details on Wisent itself read the Wisent manual.
+
+ ;;; History:
+ ;;
+
+ ;;; Code:
+
+ (defgroup wisent nil
+ "
+ /\\_.-^^^-._/\\ The GNU
+ \\_ _/
+ ( `o ` (European ;-) Bison
+ \\ ` /
+ ( D ,¨ for Emacs!
+ ` ~ ,¨
+ `\"\""
+ :group 'semantic)
+
+ \f
+ ;;;; -------------
+ ;;;; Runtime stuff
+ ;;;; -------------
+
+ ;;; Compatibility
+ (eval-and-compile
+ (if (fboundp 'char-valid-p)
+ (defalias 'wisent-char-p 'char-valid-p)
+ (defalias 'wisent-char-p 'char-or-char-int-p)))
+
+ ;;; Printed representation of terminals and nonterminals
+ (defconst wisent-escape-sequence-strings
+ '(
+ (?\a . "'\\a'") ; C-g
+ (?\b . "'\\b'") ; backspace, BS, C-h
+ (?\t . "'\\t'") ; tab, TAB, C-i
+ (?\n . "'\\n'") ; newline, C-j
+ (?\v . "'\\v'") ; vertical tab, C-k
+ (?\f . "'\\f'") ; formfeed character, C-l
+ (?\r . "'\\r'") ; carriage return, RET, C-m
+ (?\e . "'\\e'") ; escape character, ESC, C-[
+ (?\\ . "'\\'") ; backslash character, \
+ (?\d . "'\\d'") ; delete character, DEL
+ )
+ "Printed representation of usual escape sequences.")
+
+ (defsubst wisent-item-to-string (item)
+ "Return a printed representation of ITEM.
+ ITEM can be a nonterminal or terminal symbol, or a character literal."
+ (if (wisent-char-p item)
+ (or (cdr (assq item wisent-escape-sequence-strings))
+ (format "'%c'" item))
+ (symbol-name item)))
+
+ (defsubst wisent-token-to-string (token)
+ "Return a printed representation of lexical token TOKEN."
+ (format "%s%s(%S)" (wisent-item-to-string (car token))
+ (if (nth 2 token) (format "@%s" (nth 2 token)) "")
+ (nth 1 token)))
+
+ ;;; Special symbols
+ (defconst wisent-eoi-term '$EOI
+ "End Of Input token.")
+
+ (defconst wisent-error-term 'error
+ "Error recovery token.")
+
+ (defconst wisent-accept-tag 'accept
+ "Accept result after input successfully parsed.")
+
+ (defconst wisent-error-tag 'error
+ "Process a syntax error.")
+
+ ;;; Special functions
+ (defun wisent-automaton-p (obj)
+ "Return non-nil if OBJ is a LALR automaton.
+ If OBJ is a symbol check its value."
+ (and obj (symbolp obj) (boundp obj)
+ (setq obj (symbol-value obj)))
+ (and (vectorp obj) (= 4 (length obj))
+ (vectorp (aref obj 0)) (vectorp (aref obj 1))
+ (= (length (aref obj 0)) (length (aref obj 1)))
+ (listp (aref obj 2)) (vectorp (aref obj 3))))
+
+ (defsubst wisent-region (&rest positions)
+ "Return the start/end positions of the region including POSITIONS.
+ Each element of POSITIONS is a pair (START-POS . END-POS) or nil. The
+ returned value is the pair (MIN-START-POS . MAX-END-POS) or nil if no
+ POSITIONS are available."
+ (let ((pl (delq nil positions)))
+ (if pl
+ (cons (apply #'min (mapcar #'car pl))
+ (apply #'max (mapcar #'cdr pl))))))
+
+ ;;; Reporting
+ (defvar wisent-parse-verbose-flag nil
+ "*Non-nil means to issue more messages while parsing.")
+
+ (defun wisent-parse-toggle-verbose-flag ()
+ "Toggle whether to issue more messages while parsing."
+ (interactive)
+ (setq wisent-parse-verbose-flag (not wisent-parse-verbose-flag))
+ (when (interactive-p)
+ (message "More messages while parsing %sabled"
+ (if wisent-parse-verbose-flag "en" "dis"))))
+
+ (defsubst wisent-message (string &rest args)
+ "Print a one-line message if `wisent-parse-verbose-flag' is set.
+ Pass STRING and ARGS arguments to `message'."
+ (and wisent-parse-verbose-flag
+ (apply 'message string args)))
+ \f
+ ;;;; --------------------
+ ;;;; The LR parser engine
+ ;;;; --------------------
+
+ (defcustom wisent-parse-max-stack-size 500
+ "The parser stack size."
+ :type 'integer
+ :group 'wisent)
+
+ (defcustom wisent-parse-max-recover 3
+ "Number of tokens to shift before turning off error status."
+ :type 'integer
+ :group 'wisent)
+
+ (defvar wisent-discarding-token-functions nil
+ "List of functions to be called when discarding a lexical token.
+ These functions receive the lexical token discarded.
+ When the parser encounters unexpected tokens, it can discards them,
+ based on what directed by error recovery rules. Either when the
+ parser reads tokens until one is found that can be shifted, or when an
+ semantic action calls the function `wisent-skip-token' or
+ `wisent-skip-block'.
+ For language specific hooks, make sure you define this as a local
+ hook.")
+
+ (defvar wisent-pre-parse-hook nil
+ "Normal hook run just before entering the LR parser engine.")
+
+ (defvar wisent-post-parse-hook nil
+ "Normal hook run just after the LR parser engine terminated.")
+
+ (defvar wisent-loop nil
+ "The current parser action.
+ Stop parsing when set to nil.
+ This variable only has meaning in the scope of `wisent-parse'.")
+
+ (defvar wisent-nerrs nil
+ "The number of parse errors encountered so far.")
+
+ (defvar wisent-lookahead nil
+ "The lookahead lexical token.
+ This value is non-nil if the parser terminated because of an
+ unrecoverable error.")
+
+ ;; Variables and macros that are useful in semantic actions.
+ (defvar wisent-parse-lexer-function nil
+ "The user supplied lexer function.
+ This function don't have arguments.
+ This variable only has meaning in the scope of `wisent-parse'.")
+
+ (defvar wisent-parse-error-function nil
+ "The user supplied error function.
+ This function must accept one argument, a message string.
+ This variable only has meaning in the scope of `wisent-parse'.")
+
+ (defvar wisent-input nil
+ "The last token read.
+ This variable only has meaning in the scope of `wisent-parse'.")
+
+ (defvar wisent-recovering nil
+ "Non-nil means that the parser is recovering.
+ This variable only has meaning in the scope of `wisent-parse'.")
+
+ ;; Variables that only have meaning in the scope of a semantic action.
+ ;; These global definitions avoid byte-compiler warnings.
+ (defvar $region nil)
+ (defvar $nterm nil)
+ (defvar $action nil)
+
+ (defmacro wisent-lexer ()
+ "Obtain the next terminal in input."
+ '(funcall wisent-parse-lexer-function))
+
+ (defmacro wisent-error (msg)
+ "Call the user supplied error reporting function with message MSG."
+ `(funcall wisent-parse-error-function ,msg))
+
+ (defmacro wisent-errok ()
+ "Resume generating error messages immediately for subsequent syntax errors.
+ This is useful primarily in error recovery semantic actions."
+ '(setq wisent-recovering nil))
+
+ (defmacro wisent-clearin ()
+ "Discard the current lookahead token.
+ This will cause a new lexical token to be read.
+ This is useful primarily in error recovery semantic actions."
+ '(setq wisent-input nil))
+
+ (defmacro wisent-abort ()
+ "Abort parsing and save the lookahead token.
+ This is useful primarily in error recovery semantic actions."
+ '(setq wisent-lookahead wisent-input
+ wisent-loop nil))
+
+ (defmacro wisent-set-region (start end)
+ "Change the region of text matched by the current nonterminal.
+ START and END are respectively the beginning and end positions of the
+ region. If START or END values are not a valid positions the region
+ is set to nil."
+ `(setq $region (and (number-or-marker-p ,start)
+ (number-or-marker-p ,end)
+ (cons ,start ,end))))
+
+ (defun wisent-skip-token ()
+ "Skip the lookahead token in order to resume parsing.
+ Return nil.
+ Must be used in error recovery semantic actions."
+ (if (eq (car wisent-input) wisent-eoi-term)
+ ;; Does nothing at EOI to avoid infinite recovery loop.
+ nil
+ (wisent-message "%s: skip %s" $action
+ (wisent-token-to-string wisent-input))
+ (run-hook-with-args
+ 'wisent-discarding-token-functions wisent-input)
+ (wisent-clearin)
+ (wisent-errok)))
+
+ (defun wisent-skip-block (&optional bounds)
+ "Safely skip a parenthesized block in order to resume parsing.
+ Return nil.
+ Must be used in error recovery semantic actions.
+ Optional argument BOUNDS is a pair (START . END) which indicates where
+ the parenthesized block starts. Typically the value of a `$regionN'
+ variable, where `N' is the the Nth element of the current rule
+ components that match the block beginning. It defaults to the value
+ of the `$region' variable."
+ (let ((start (car (or bounds $region)))
+ end input)
+ (if (not (number-or-marker-p start))
+ ;; No nonterminal region available, skip the lookahead token.
+ (wisent-skip-token)
+ ;; Try to skip a block.
+ (if (not (setq end (save-excursion
+ (goto-char start)
+ (and (looking-at "\\s(")
+ (condition-case nil
+ (1- (scan-lists (point) 1 0))
+ (error nil))))))
+ ;; Not actually a block, skip the lookahead token.
+ (wisent-skip-token)
+ ;; OK to safely skip the block, so read input until a matching
+ ;; close paren or EOI is encountered.
+ (setq input wisent-input)
+ (while (and (not (eq (car input) wisent-eoi-term))
+ (< (nth 2 input) end))
+ (run-hook-with-args
+ 'wisent-discarding-token-functions input)
+ (setq input (wisent-lexer)))
+ (wisent-message "%s: in enclosing block, skip from %s to %s"
+ $action
+ (wisent-token-to-string wisent-input)
+ (wisent-token-to-string input))
+ (if (eq (car wisent-input) wisent-eoi-term)
+ ;; Does nothing at EOI to avoid infinite recovery loop.
+ nil
+ (wisent-clearin)
+ (wisent-errok))
+ ;; Set end of $region to end of block.
+ (wisent-set-region (car $region) (1+ end))
+ nil))))
+
+ ;;; Core parser engine
+ (defsubst wisent-production-bounds (stack i j)
+ "Determine the start and end locations of a production value.
+ Return a pair (START . END), where START is the first available start
+ location, and END the last available end location, in components
+ values of the rule currently reduced.
+ Return nil when no component location is available.
+ STACK is the parser stack.
+ I and J are the indices in STACK of respectively the value of the
+ first and last components of the current rule.
+ This function is for internal use by semantic actions' generated
+ lambda-expression."
+ (let ((f (cadr (aref stack i)))
+ (l (cddr (aref stack j))))
+ (while (/= i j)
+ (cond
+ ((not f) (setq f (cadr (aref stack (setq i (+ i 2))))))
+ ((not l) (setq l (cddr (aref stack (setq j (- j 2))))))
+ ((setq i j))))
+ (and f l (cons f l))))
+
+ (defmacro wisent-parse-action (i al)
+ "Return the next parser action.
+ I is a token item number and AL is the list of (item . action)
+ available at current state. The first element of AL contains the
+ default action for this state."
+ `(cdr (or (assq ,i ,al) (car ,al))))
+
+ (defsubst wisent-parse-start (start starts)
+ "Return the first lexical token to shift for START symbol.
+ STARTS is the table of allowed start symbols or nil if the LALR
+ automaton has only one entry point."
+ (if (null starts)
+ ;; Only one entry point, return the first lexical token
+ ;; available in input.
+ (wisent-lexer)
+ ;; Multiple start symbols defined, return the internal lexical
+ ;; token associated to START. By default START is the first
+ ;; nonterminal defined in STARTS.
+ (let ((token (cdr (if start (assq start starts) (car starts)))))
+ (if token
+ (list token (symbol-name token))
+ (error "Invalid start symbol %s" start)))))
+
+ (defun wisent-parse (automaton lexer &optional error start)
+ "Parse input using the automaton specified in AUTOMATON.
+
+ - AUTOMATON is an LALR(1) automaton generated by
+ `wisent-compile-grammar'.
+
+ - LEXER is a function with no argument called by the parser to obtain
+ the next terminal (token) in input.
+
+ - ERROR is an optional reporting function called when a parse error
+ occurs. It receives a message string to report. It defaults to the
+ function `wisent-message'.
+
+ - START specify the start symbol (nonterminal) used by the parser as
+ its goal. It defaults to the start symbol defined in the grammar
+ \(see also `wisent-compile-grammar')."
+ (run-hooks 'wisent-pre-parse-hook)
+ (let* ((actions (aref automaton 0))
+ (gotos (aref automaton 1))
+ (starts (aref automaton 2))
+ (stack (make-vector wisent-parse-max-stack-size nil))
+ (sp 0)
+ (wisent-loop t)
+ (wisent-parse-error-function (or error 'wisent-message))
+ (wisent-parse-lexer-function lexer)
+ (wisent-recovering nil)
+ (wisent-input (wisent-parse-start start starts))
+ state tokid choices choice)
+ (setq wisent-nerrs 0 ;; Reset parse error counter
+ wisent-lookahead nil) ;; and lookahead token
+ (aset stack 0 0) ;; Initial state
+ (while wisent-loop
+ (setq state (aref stack sp)
+ tokid (car wisent-input)
+ wisent-loop (wisent-parse-action tokid (aref actions state)))
+ (cond
+
+ ;; Input successfully parsed
+ ;; -------------------------
+ ((eq wisent-loop wisent-accept-tag)
+ (setq wisent-loop nil))
+
+ ;; Syntax error in input
+ ;; ---------------------
+ ((eq wisent-loop wisent-error-tag)
+ ;; Report this error if not already recovering from an error.
+ (setq choices (aref actions state))
+ (or wisent-recovering
+ (wisent-error
+ (format "Syntax error, unexpected %s, expecting %s"
+ (wisent-token-to-string wisent-input)
+ (mapconcat 'wisent-item-to-string
+ (delq wisent-error-term
+ (mapcar 'car (cdr choices)))
+ ", "))))
+ ;; Increment the error counter
+ (setq wisent-nerrs (1+ wisent-nerrs))
+ ;; If just tried and failed to reuse lookahead token after an
+ ;; error, discard it.
+ (if (eq wisent-recovering wisent-parse-max-recover)
+ (if (eq tokid wisent-eoi-term)
+ (wisent-abort) ;; Terminate if at end of input.
+ (wisent-message "Error recovery: skip %s"
+ (wisent-token-to-string wisent-input))
+ (run-hook-with-args
+ 'wisent-discarding-token-functions wisent-input)
+ (setq wisent-input (wisent-lexer)))
+
+ ;; Else will try to reuse lookahead token after shifting the
+ ;; error token.
+
+ ;; Each real token shifted decrements this.
+ (setq wisent-recovering wisent-parse-max-recover)
+ ;; Pop the value/state stack to see if an action associated
+ ;; to special terminal symbol 'error exists.
+ (while (and (>= sp 0)
+ (not (and (setq state (aref stack sp)
+ choices (aref actions state)
+ choice (assq wisent-error-term choices))
+ (natnump (cdr choice)))))
+ (setq sp (- sp 2)))
+
+ (if (not choice)
+ ;; No 'error terminal was found. Just terminate.
+ (wisent-abort)
+ ;; Try to recover and continue parsing.
+ ;; Shift the error terminal.
+ (setq state (cdr choice) ; new state
+ sp (+ sp 2))
+ (aset stack (1- sp) nil) ; push value
+ (aset stack sp state) ; push new state
+ ;; Adjust input to error recovery state. Unless 'error
+ ;; triggers a reduction, eat the input stream until an
+ ;; expected terminal symbol is found, or EOI is reached.
+ (if (cdr (setq choices (aref actions state)))
+ (while (not (or (eq (car wisent-input) wisent-eoi-term)
+ (assq (car wisent-input) choices)))
+ (wisent-message "Error recovery: skip %s"
+ (wisent-token-to-string wisent-input))
+ (run-hook-with-args
+ 'wisent-discarding-token-functions wisent-input)
+ (setq wisent-input (wisent-lexer)))))))
+
+ ;; Shift current token on top of the stack
+ ;; ---------------------------------------
+ ((natnump wisent-loop)
+ ;; Count tokens shifted since error; after
+ ;; `wisent-parse-max-recover', turn off error status.
+ (setq wisent-recovering (and (natnump wisent-recovering)
+ (> wisent-recovering 1)
+ (1- wisent-recovering)))
+ (setq sp (+ sp 2))
+ (aset stack (1- sp) (cdr wisent-input))
+ (aset stack sp wisent-loop)
+ (setq wisent-input (wisent-lexer)))
+
+ ;; Reduce by rule (call semantic action)
+ ;; -------------------------------------
+ (t
+ (setq sp (funcall wisent-loop stack sp gotos))
+ (or wisent-input (setq wisent-input (wisent-lexer))))))
+ (run-hooks 'wisent-post-parse-hook)
+ (car (aref stack 1))))
+
+ (provide 'semantic/wisent/wisent)
+
+ ;;; semantic/wisent/wisent.el ends here
--- /dev/null
+ ;;; srecode/expandproto.el --- Expanding prototypes.
+
+ ;; Copyright (C) 2007 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Methods for expanding a prototype into an implementation.
+
+ (require 'ring)
+ (require 'semantic)
+ (require 'semantic/analyze)
++(require 'semantic/senator)
+ (require 'srecode/insert)
+ (require 'srecode/dictionary)
+
+ (declare-function semantic-brute-find-tag-by-attribute-value "semantic/find")
+
+ ;;; Code:
+ (defcustom srecode-expandproto-template-file-alist
+ '( ( c++-mode . "srecode-expandproto-cpp.srt" )
+ )
+ ;; @todo - Make this variable auto-generated from the Makefile.
+ "Associate template files for expanding prototypes to a major mode."
+ :group 'srecode
+ :type '(repeat (cons (sexp :tag "Mode")
+ (sexp :tag "Filename"))
+ ))
+
+ ;;;###autoload
+ (defun srecode-insert-prototype-expansion ()
+ "Insert get/set methods for the current class."
+ (interactive)
+
+ (srecode-load-tables-for-mode major-mode)
+ (srecode-load-tables-for-mode major-mode
+ srecode-expandproto-template-file-alist)
+
+ (if (not (srecode-table))
+ (error "No template table found for mode %s" major-mode))
+
+ (let ((proto
+ ;; Step 1: Find the prototype, or prototype list to expand.
+ (srecode-find-prototype-for-expansion)))
+
+ (if (not proto)
+ (error "Could not find prototype to expand"))
+
+ ;; Step 2: Insert implementations of the prototypes.
+
+
+ ))
+
+ (defun srecode-find-prototype-for-expansion ()
+ "Find a prototype to use for expanding into an implementation."
+ ;; We may find a prototype tag in one of several places.
+ ;; Search in order of logical priority.
+ (let ((proto nil)
+ )
+
+ ;; 1) A class full of prototypes under point.
+ (let ((tag (semantic-current-tag)))
+ (when tag
+ (when (not (semantic-tag-of-class-p tag 'type))
+ (setq tag (semantic-current-tag-parent))))
+ (when (and tag (semantic-tag-of-class-p tag 'type))
+ ;; If the current class has prototype members, then
+ ;; we will do the whole class!
+ (require 'semantic/find)
+ (if (semantic-brute-find-tag-by-attribute-value
+ :prototype t
+ (semantic-tag-type-members tag))
+ (setq proto tag)))
+ )
+
+ ;; 2) A prototype under point.
+ (when (not proto)
+ (let ((tag (semantic-current-tag)))
+ (when (and tag
+ (and
+ (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-get-attribute tag :prototype)))
+ (setq proto tag))))
+
+ ;; 3) A tag in the kill ring that is a prototype
+ (when (not proto)
+ (if (ring-empty-p senator-tag-ring)
+ nil ;; Not for us.
+ (let ((tag (ring-ref senator-tag-ring 0))
+ )
+ (when
+ (and tag
+ (or
+ (and
+ (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-get-attribute tag :prototype))
+ (and
+ (semantic-tag-of-class-p tag 'type)
+ (require 'semantic/find)
+ (semantic-brute-find-tag-by-attribute-value
+ :prototype t
+ (semantic-tag-type-members tag))))
+ )
+ (setq proto tag))
+ )))
+
+ proto))
+
+ (provide 'srecode-expandproto)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: srecode/loaddefs
+ ;; generated-autoload-load-name: "srecode/expandproto"
+ ;; End:
+
+ ;;; srecode/expandproto.el ends here
--- /dev/null
-;; (require 'senator)
+ ;;; srecode/mode.el --- Minor mode for managing and using SRecode templates
+
+ ;; Copyright (C) 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Minor mode for working with SRecode template files.
+ ;;
+ ;; Depends on Semantic for minor-mode convenience functions.
+
+ (require 'mode-local)
+ (require 'srecode)
+ (require 'srecode/insert)
+ (require 'srecode/find)
+ (require 'srecode/map)
+ (require 'semantic/decorate)
+ (require 'semantic/wisent)
+
+ (eval-when-compile (require 'semantic/find))
+
+ ;;; Code:
+
+ (defcustom global-srecode-minor-mode nil
+ "Non-nil in buffers with Semantic Recoder macro keybindings."
+ :group 'srecode
+ :type 'boolean
+ :require 'srecode/mode
+ :initialize 'custom-initialize-default
+ :set (lambda (sym val)
+ (global-srecode-minor-mode (if val 1 -1))))
+
+ (defvar srecode-minor-mode nil
+ "Non-nil in buffers with Semantic Recoder macro keybindings.")
+ (make-variable-buffer-local 'srecode-minor-mode)
+
+ (defcustom srecode-minor-mode-hook nil
+ "Hook run at the end of the function `srecode-minor-mode'."
+ :group 'srecode
+ :type 'hook)
+
+ ;; We don't want to waste space. There is a menu after all.
+ ;;(add-to-list 'minor-mode-alist '(srecode-minor-mode ""))
+
+ (defvar srecode-prefix-key [(control ?c) ?/]
+ "The common prefix key in srecode minor mode.")
+
+ (defvar srecode-prefix-map
+ (let ((km (make-sparse-keymap)))
+ ;; Basic template codes
+ (define-key km "/" 'srecode-insert)
+ (define-key km [insert] 'srecode-insert)
+ (define-key km "." 'srecode-insert-again)
+ (define-key km "E" 'srecode-edit)
+ ;; Template indirect binding
+ (let ((k ?a))
+ (while (<= k ?z)
+ (define-key km (format "%c" k) 'srecode-bind-insert)
+ (setq k (1+ k))))
+ km)
+ "Keymap used behind the srecode prefix key in in srecode minor mode.")
+
+ (defvar srecode-menu-bar
+ (list
+ "SRecoder"
+ (semantic-menu-item
+ ["Insert Template"
+ srecode-insert
+ :active t
+ :help "Insert a template by name."
+ ])
+ (semantic-menu-item
+ ["Insert Template Again"
+ srecode-insert-again
+ :active t
+ :help "Run the same template as last time again."
+ ])
+ (semantic-menu-item
+ ["Edit Template"
+ srecode-edit
+ :active t
+ :help "Edit a template for this language by name."
+ ])
+ "---"
+ '( "Insert ..." :filter srecode-minor-mode-templates-menu )
+ `( "Generate ..." :filter srecode-minor-mode-generate-menu )
+ "---"
+ (semantic-menu-item
+ ["Customize..."
+ (customize-group "srecode")
+ :active t
+ :help "Customize SRecode options"
+ ])
+ (list
+ "Debugging Tools..."
+ (semantic-menu-item
+ ["Dump Template MAP"
+ srecode-get-maps
+ :active t
+ :help "Calculate (if needed) and display the current template file map."
+ ])
+ (semantic-menu-item
+ ["Dump Tables"
+ srecode-dump-templates
+ :active t
+ :help "Dump the current template table."
+ ])
+ (semantic-menu-item
+ ["Dump Dictionary"
+ srecode-dictionary-dump
+ :active t
+ :help "Calculate a dump a dictionary for point."
+ ])
+ )
+ )
+ "Menu for srecode minor mode.")
+
+ (defvar srecode-minor-menu nil
+ "Menu keymap build from `srecode-menu-bar'.")
+
+ (defcustom srecode-takeover-INS-key nil
+ "Use the insert key for inserting templates."
+ :group 'srecode
+ :type 'boolean)
+
+ (defvar srecode-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km srecode-prefix-key srecode-prefix-map)
+ (easy-menu-define srecode-minor-menu km "Srecode Minor Mode Menu"
+ srecode-menu-bar)
+ (when srecode-takeover-INS-key
+ (define-key km [insert] srecode-prefix-map))
+ km)
+ "Keymap for srecode minor mode.")
+
+ ;;;###autoload
+ (defun srecode-minor-mode (&optional arg)
+ "Toggle srecode minor mode.
+ 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.
+
+ \\{srecode-mode-map}"
+ (interactive
+ (list (or current-prefix-arg
+ (if srecode-minor-mode 0 1))))
+ ;; Flip the bits.
+ (setq srecode-minor-mode
+ (if arg
+ (>
+ (prefix-numeric-value arg)
+ 0)
+ (not srecode-minor-mode)))
+ ;; If we are turning things on, make sure we have templates for
+ ;; this mode first.
+ (when srecode-minor-mode
+ (when (not (apply
+ 'append
+ (mapcar (lambda (map)
+ (srecode-map-entries-for-mode map major-mode))
+ (srecode-get-maps))))
+ (setq srecode-minor-mode nil))
+ )
+ ;; Run hooks if we are turning this on.
+ (when srecode-minor-mode
+ (run-hooks 'srecode-minor-mode-hook))
+ srecode-minor-mode)
+
+ ;;;###autoload
+ (defun global-srecode-minor-mode (&optional arg)
+ "Toggle global use of srecode minor mode.
+ If ARG is positive, enable, if it is negative, disable.
+ If ARG is nil, then toggle."
+ (interactive "P")
+ (setq global-srecode-minor-mode
+ (semantic-toggle-minor-mode-globally
+ 'srecode-minor-mode arg)))
+
+ ;; Use the semantic minor mode magic stuff.
+ (semantic-add-minor-mode 'srecode-minor-mode "" srecode-mode-map)
+
+ ;;; Menu Filters
+ ;;
+ (defun srecode-minor-mode-templates-menu (menu-def)
+ "Create a menu item of cascading filters active for this mode.
+ MENU-DEF is the menu to bind this into."
+ ;; Doing this SEGVs Emacs on windows.
+ ;;(srecode-load-tables-for-mode major-mode)
+
+ (let* ((modetable (srecode-get-mode-table major-mode))
+ (subtab (when modetable (oref modetable :tables)))
+ (context nil)
+ (active nil)
+ (ltab nil)
+ (temp nil)
+ (alltabs nil)
+ )
+ (if (not subtab)
+ ;; No tables, show a "load the tables" option.
+ (list (vector "Load Mode Tables..."
+ (lambda ()
+ (interactive)
+ (srecode-load-tables-for-mode major-mode))
+ ))
+ ;; Build something
+ (setq context (car-safe (srecode-calculate-context)))
+
+ (while subtab
+ (setq ltab (oref (car subtab) templates))
+ (while ltab
+ (setq temp (car ltab))
+
+ ;; Do something with this template.
+
+ (let* ((ctxt (oref temp context))
+ (ctxtcons (assoc ctxt alltabs))
+ (bind (if (slot-boundp temp 'binding)
+ (oref temp binding)))
+ (name (object-name-string temp)))
+
+ (when (not ctxtcons)
+ (if (string= context ctxt)
+ ;; If this context is not in the current list of contexts
+ ;; is equal to the current context, then manage the
+ ;; active list instead
+ (setq active
+ (setq ctxtcons (or active (cons ctxt nil))))
+ ;; This is not an active context, add it to alltabs.
+ (setq ctxtcons (cons ctxt nil))
+ (setq alltabs (cons ctxtcons alltabs))))
+
+ (let ((new (vector
+ (if bind
+ (concat name " (" bind ")")
+ name)
+ `(lambda () (interactive)
+ (srecode-insert (concat ,ctxt ":" ,name)))
+ t)))
+
+ (setcdr ctxtcons (cons
+ new
+ (cdr ctxtcons)))))
+
+ (setq ltab (cdr ltab)))
+ (setq subtab (cdr subtab)))
+
+ ;; Now create the menu
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Semantic Recoder Filters"
+ (append (cdr active)
+ alltabs)
+ ))
+ )))
+
+ (defvar srecode-minor-mode-generators nil
+ "List of code generators to be displayed in the srecoder menu.")
+
+ (defun srecode-minor-mode-generate-menu (menu-def)
+ "Create a menu item of cascading filters active for this mode.
+ MENU-DEF is the menu to bind this into."
+ ;; Doing this SEGVs Emacs on windows.
+ ;;(srecode-load-tables-for-mode major-mode)
+ (let ((allgeneratorapps nil))
+
+ (dolist (gen srecode-minor-mode-generators)
+ (setq allgeneratorapps
+ (cons (vector (cdr gen) (car gen))
+ allgeneratorapps))
+ (message "Adding %S to srecode menu" (car gen))
+ )
+
+ (easy-menu-filter-return
+ (easy-menu-create-menu
+ "Semantic Recoder Generate Filters"
+ allgeneratorapps)))
+ )
+
+ ;;; Minor Mode commands
+ ;;
+ (defun srecode-bind-insert ()
+ "Bound insert for Srecode macros.
+ This command will insert whichever srecode template has a binding
+ to the current key."
+ (interactive)
+ (let* ((k last-command-event)
+ (ctxt (srecode-calculate-context))
+ ;; Find the template with the binding K
+ (template (srecode-template-get-table-for-binding
+ (srecode-table) k ctxt)))
+ ;; test it.
+ (when (not template)
+ (error "No template bound to %c" k))
+ ;; insert
+ (srecode-insert template)
+ ))
+
+ (defun srecode-edit (template-name)
+ "Switch to the template buffer for TEMPLATE-NAME.
+ Template is chosen based on the mode of the starting buffer."
+ ;; @todo - Get a template stack from the last run template, and show
+ ;; those too!
+ (interactive (list (srecode-read-template-name
+ "Template Name: "
+ (car srecode-read-template-name-history))))
+ (if (not (srecode-table))
+ (error "No template table found for mode %s" major-mode))
+ (let ((temp (srecode-template-get-table (srecode-table) template-name)))
+ (if (not temp)
+ (error "No Template named %s" template-name))
+ ;; We need a template specific table, since tables chain.
+ (let ((tab (oref temp :table))
+ (names nil)
+ )
+ (find-file (oref tab :file))
+ (setq names (semantic-find-tags-by-name (oref temp :object-name)
+ (current-buffer)))
+ (cond ((= (length names) 1)
+ (semantic-go-to-tag (car names))
+ (semantic-momentary-highlight-tag (car names)))
+ ((> (length names) 1)
+ (let* ((ctxt (semantic-find-tags-by-name (oref temp :context)
+ (current-buffer)))
+ (cls (semantic-find-tags-by-class 'context ctxt))
+ )
+ (while (and names
+ (< (semantic-tag-start (car names))
+ (semantic-tag-start (car cls))))
+ (setq names (cdr names)))
+ (if names
+ (progn
+ (semantic-go-to-tag (car names))
+ (semantic-momentary-highlight-tag (car names)))
+ (error "Can't find template %s" template-name))
+ ))
+ (t (error "Can't find template %s" template-name)))
+ )))
+
+ (defun srecode-add-code-generator (function name &optional binding)
+ "Add the srecoder code generator FUNCTION with NAME to the menu.
+ Optional BINDING specifies the keybinding to use in the srecoder map.
+ BINDING should be a capital letter. Lower case letters are reserved
+ for individual templates.
+ Optional MODE specifies a major mode this function applies to.
+ Do not specify a mode if this function could be applied to most
+ programming modes."
+ ;; Update the menu generating part.
+ (let ((remloop nil))
+ (while (setq remloop (assoc function srecode-minor-mode-generators))
+ (setq srecode-minor-mode-generators
+ (remove remloop srecode-minor-mode-generators))))
+
+ (add-to-list 'srecode-minor-mode-generators
+ (cons function name))
+
+ ;; Remove this function from any old bindings.
+ (when binding
+ (let ((oldkey (where-is-internal function
+ (list srecode-prefix-map)
+ t t t)))
+ (if (or (not oldkey)
+ (and (= (length oldkey) 1)
+ (= (length binding) 1)
+ (= (aref oldkey 0) (aref binding 0))))
+ ;; Its the same.
+ nil
+ ;; Remove the old binding
+ (define-key srecode-prefix-map oldkey nil)
+ )))
+
+ ;; Update Keybings
+ (let ((oldbinding (lookup-key srecode-prefix-map binding)))
+
+ ;; During development, allow overrides.
+ (when (and oldbinding
+ (not (eq oldbinding function))
+ (or (eq this-command 'eval-defun) (eq this-command 'checkdoc-eval-defun))
+ (y-or-n-p (format "Override old binding %s? " oldbinding)))
+ (setq oldbinding nil))
+
+ (if (not oldbinding)
+ (define-key srecode-prefix-map binding function)
+ (if (eq function oldbinding)
+ nil
+ ;; Not the same.
+ (message "Conflict binding %S binding to srecode map."
+ binding))))
+ )
+
+ ;; Add default code generators:
+ (srecode-add-code-generator 'srecode-document-insert-comment "Comments" "C")
+ (srecode-add-code-generator 'srecode-insert-getset "Get/Set" "G")
+
+ (provide 'srecode/mode)
+
+ ;; Local variables:
+ ;; generated-autoload-file: "loaddefs.el"
+ ;; generated-autoload-feature: srecode/loaddefs
+ ;; generated-autoload-load-name: "srecode/mode"
+ ;; End:
+
+ ;;; srecode/mode.el ends here
--- /dev/null
-;;(require 'senator)
+ ;;; srecode/semantic.el --- Semantic specific extensions to SRecode.
+
+ ;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; Author: Eric M. Ludlam <eric@siege-engine.com>
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+ ;;
+ ;; Semantic specific extensions to the Semantic Recoder.
+ ;;
+ ;; I realize it is the "Semantic Recoder", but most of srecode
+ ;; is a template library and set of user interfaces unrelated to
+ ;; semantic in the specific.
+ ;;
+ ;; This file defines the following:
+ ;; - :tag argument handling.
+ ;; - <more goes here>
+
+ ;;; Code:
+
+ (require 'srecode/insert)
+ (require 'srecode/dictionary)
+ (require 'semantic/find)
+ (require 'semantic/format)
++(require 'semantic/senator)
+ (require 'ring)
+
+ \f
+ ;;; The SEMANTIC TAG inserter
+ ;;
+ ;; Put a tag into the dictionary that can be used w/ arbitrary
+ ;; lisp expressions.
+
+ (defclass srecode-semantic-tag (srecode-dictionary-compound-value)
+ ((prime :initarg :prime
+ :type semantic-tag
+ :documentation
+ "This is the primary insertion tag.")
+ )
+ "Wrap up a collection of semantic tag information.
+ This class will be used to derive dictionary values.")
+
+ (defmethod srecode-compound-toString((cp srecode-semantic-tag)
+ function
+ dictionary)
+ "Convert the compound dictionary value CP to a string.
+ If FUNCTION is non-nil, then FUNCTION is somehow applied to an
+ aspect of the compound value."
+ (if (not function)
+ ;; Just format it in some handy dandy way.
+ (semantic-format-tag-prototype (oref cp :prime))
+ ;; Otherwise, apply the function to the tag itself.
+ (funcall function (oref cp :prime))
+ ))
+
+ \f
+ ;;; Managing the `current' tag
+ ;;
+
+ (defvar srecode-semantic-selected-tag nil
+ "The tag selected by a :tag template argument.
+ If this is nil, then `senator-tag-ring' is used.")
+
+ (defun srecode-semantic-tag-from-kill-ring ()
+ "Create an `srecode-semantic-tag' from the senator kill ring."
+ (if (ring-empty-p senator-tag-ring)
+ (error "You must use `senator-copy-tag' to provide a tag to this template"))
+ (ring-ref senator-tag-ring 0))
+
+ \f
+ ;;; TAG in a DICTIONARY
+ ;;
+ (defvar srecode-semantic-apply-tag-augment-hook nil
+ "A function called for each tag added to a dictionary.
+ The hook is called with two arguments, the TAG and DICT
+ to be augmented.")
+
+ (define-overload srecode-semantic-apply-tag-to-dict (tagobj dict)
+ "Insert fewatures of TAGOBJ into the dictionary DICT.
+ TAGOBJ is an object of class `srecode-semantic-tag'. This class
+ is a compound inserter value.
+ DICT is a dictionary object.
+ At a minimum, this function will create dictionary macro for NAME.
+ It is also likely to create macros for TYPE (data type), function arguments,
+ variable default values, and other things."
+ )
+
+ (defun srecode-semantic-apply-tag-to-dict-default (tagobj dict)
+ "Insert features of TAGOBJ into dictionary DICT."
+ ;; Store the sst into the dictionary.
+ (srecode-dictionary-set-value dict "TAG" tagobj)
+
+ ;; Pull out the tag for the individual pieces.
+ (let ((tag (oref tagobj :prime)))
+
+ (srecode-dictionary-set-value dict "NAME" (semantic-tag-name tag))
+ (srecode-dictionary-set-value dict "TYPE" (semantic-format-tag-type tag nil))
+
+ (run-hook-with-args 'srecode-semantic-apply-tag-augment-hook tag dict)
+
+ (cond
+ ;;
+ ;; FUNCTION
+ ;;
+ ((eq (semantic-tag-class tag) 'function)
+ ;; FCN ARGS
+ (let ((args (semantic-tag-function-arguments tag)))
+ (while args
+ (let ((larg (car args))
+ (subdict (srecode-dictionary-add-section-dictionary
+ dict "ARGS")))
+ ;; Clean up elements in the arg list.
+ (if (stringp larg)
+ (setq larg (semantic-tag-new-variable
+ larg nil nil)))
+ ;; Apply the sub-argument to the subdictionary.
+ (srecode-semantic-apply-tag-to-dict
+ (srecode-semantic-tag (semantic-tag-name larg)
+ :prime larg)
+ subdict)
+ )
+ ;; Next!
+ (setq args (cdr args))))
+ ;; PARENTS
+ (let ((p (semantic-tag-function-parent tag)))
+ (when p
+ (srecode-dictionary-set-value dict "PARENT" p)
+ ))
+ ;; EXCEPTIONS (java/c++)
+ (let ((exceptions (semantic-tag-get-attribute tag :throws)))
+ (while exceptions
+ (let ((subdict (srecode-dictionary-add-section-dictionary
+ dict "THROWS")))
+ (srecode-dictionary-set-value subdict "NAME" (car exceptions))
+ )
+ (setq exceptions (cdr exceptions)))
+ )
+ )
+ ;;
+ ;; VARIABLE
+ ;;
+ ((eq (semantic-tag-class tag) 'variable)
+ (when (semantic-tag-variable-default tag)
+ (let ((subdict (srecode-dictionary-add-section-dictionary
+ dict "HAVEDEFAULT")))
+ (srecode-dictionary-set-value
+ subdict "VALUE" (semantic-tag-variable-default tag))))
+ )
+ ;;
+ ;; TYPE
+ ;;
+ ((eq (semantic-tag-class tag) 'type)
+ (dolist (p (semantic-tag-type-superclasses tag))
+ (let ((sd (srecode-dictionary-add-section-dictionary
+ dict "PARENTS")))
+ (srecode-dictionary-set-value sd "NAME" p)
+ ))
+ (dolist (i (semantic-tag-type-interfaces tag))
+ (let ((sd (srecode-dictionary-add-section-dictionary
+ dict "INTERFACES")))
+ (srecode-dictionary-set-value sd "NAME" i)
+ ))
+ ; NOTE : The members are too complicated to do via a template.
+ ; do it via the insert-tag solution instead.
+ ;
+ ; (dolist (mem (semantic-tag-type-members tag))
+ ; (let ((subdict (srecode-dictionary-add-section-dictionary
+ ; dict "MEMBERS")))
+ ; (when (stringp mem)
+ ; (setq mem (semantic-tag-new-variable mem nil nil)))
+ ; (srecode-semantic-apply-tag-to-dict
+ ; (srecode-semantic-tag (semantic-tag-name mem)
+ ; :prime mem)
+ ; subdict)))
+ ))))
+
+ \f
+ ;;; ARGUMENT HANDLERS
+
+ ;;; :tag ARGUMENT HANDLING
+ ;;
+ ;; When a :tag argument is required, identify the current :tag,
+ ;; and apply it's parts into the dictionary.
+ (defun srecode-semantic-handle-:tag (dict)
+ "Add macroes into the dictionary DICT based on the current :tag."
+ ;; We have a tag, start adding "stuff" into the dictionary.
+ (let ((tag (or srecode-semantic-selected-tag
+ (srecode-semantic-tag-from-kill-ring))))
+ (when (not tag)
+ "No tag for current template. Use the semantic kill-ring.")
+ (srecode-semantic-apply-tag-to-dict
+ (srecode-semantic-tag (semantic-tag-name tag)
+ :prime tag)
+ dict)))
+
+ ;;; :tagtype ARGUMENT HANDLING
+ ;;
+ ;; When a :tagtype argument is required, identify the current tag, of
+ ;; cf class 'type. Apply those parameters to the dictionary.
+
+ (defun srecode-semantic-handle-:tagtype (dict)
+ "Add macroes into the dictionary DICT based on a tag of class type at point.
+ Assumes the cursor is in a tag of class type. If not, throw an error."
+ (let ((typetag (or srecode-semantic-selected-tag
+ (semantic-current-tag-of-class 'type))))
+ (when (not typetag)
+ (error "Cursor is not in a TAG of class 'type"))
+ (srecode-semantic-apply-tag-to-dict
+ typetag
+ dict)))
+
+ \f
+ ;;; INSERT A TAG API
+ ;;
+ ;; Routines that take a tag, and insert into a buffer.
+ (define-overload srecode-semantic-find-template (class prototype ctxt)
+ "Find a template for a tag of class CLASS based on context.
+ PROTOTYPE is non-nil if we want a prototype template instead."
+ )
+
+ (defun srecode-semantic-find-template-default (class prototype ctxt)
+ "Find a template for tag CLASS based on context.
+ PROTOTYPE is non-nil if we need a prototype.
+ CTXT is the pre-calculated context."
+ (let* ((top (car ctxt))
+ (tname (if (stringp class)
+ class
+ (symbol-name class)))
+ (temp nil)
+ )
+ ;; Try to find a template.
+ (setq temp (or
+ (when prototype
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-tag-prototype")
+ top))
+ (when prototype
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-prototype")
+ top))
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-tag")
+ top)
+ (srecode-template-get-table (srecode-table)
+ tname
+ top)
+ (when (and (not (string= top "declaration"))
+ prototype)
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-prototype")
+ "declaration"))
+ (when (and (not (string= top "declaration"))
+ prototype)
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-tag-prototype")
+ "declaration"))
+ (when (not (string= top "declaration"))
+ (srecode-template-get-table (srecode-table)
+ (concat tname "-tag")
+ "declaration"))
+ (when (not (string= top "declaration"))
+ (srecode-template-get-table (srecode-table)
+ tname
+ "declaration"))
+ ))
+ temp))
+
+ (defun srecode-semantic-insert-tag (tag &optional style-option
+ point-insert-fcn
+ &rest dict-entries)
+ "Insert TAG into a buffer useing srecode templates at point.
+
+ Optional STYLE-OPTION is a list of minor configuration of styles,
+ such as the symbol 'prototype for prototype functions, or
+ 'system for system includes, and 'doxygen, for a doxygen style
+ comment.
+
+ Optional third argument POINT-INSERT-FCN is a hook that is run after
+ TAG is inserted that allows an opportunity to fill in the body of
+ some thing. This hook function is called with one argument, the TAG
+ being inserted.
+
+ The rest of the arguments are DICT-ENTRIES. DICT-ENTRIES
+ is of the form ( NAME1 VALUE1 NAME2 VALUE2 ... NAMEn VALUEn).
+
+ The exact template used is based on the current context.
+ The template used is found within the toplevel context as calculated
+ by `srecode-calculate-context', such as `declaration', `classdecl',
+ or `code'.
+
+ For various conditions, this function looks for a template with
+ the name CLASS-tag, where CLASS is the tag class. If it cannot
+ find that, it will look for that template in the
+ `declaration'context (if the current context was not `declaration').
+
+ If PROTOTYPE is specified, it will first look for templates with
+ the name CLASS-tag-prototype, or CLASS-prototype as above.
+
+ See `srecode-semantic-apply-tag-to-dict' for details on what is in
+ the dictionary when the templates are called.
+
+ This function returns to location in the buffer where the
+ inserted tag ENDS, and will leave point inside the inserted
+ text based on any occurance of a point-inserter. Templates such
+ as `function' will leave point where code might be inserted."
+ (srecode-load-tables-for-mode major-mode)
+ (let* ((ctxt (srecode-calculate-context))
+ (top (car ctxt))
+ (tname (symbol-name (semantic-tag-class tag)))
+ (dict (srecode-create-dictionary))
+ (temp nil)
+ (errtype tname)
+ (prototype (memq 'prototype style-option))
+ )
+ ;; Try some special cases.
+ (cond ((and (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-get-attribute tag :constructor-flag))
+ (setq temp (srecode-semantic-find-template
+ "constructor" prototype ctxt))
+ )
+
+ ((and (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-get-attribute tag :destructor-flag))
+ (setq temp (srecode-semantic-find-template
+ "destructor" prototype ctxt))
+ )
+
+ ((and (semantic-tag-of-class-p tag 'function)
+ (semantic-tag-function-parent tag))
+ (setq temp (srecode-semantic-find-template
+ "method" prototype ctxt))
+ )
+
+ ((and (semantic-tag-of-class-p tag 'variable)
+ (semantic-tag-get-attribute tag :constant-flag))
+ (setq temp (srecode-semantic-find-template
+ "variable-const" prototype ctxt))
+ )
+ )
+
+ (when (not temp)
+ ;; Try the basics
+ (setq temp (srecode-semantic-find-template
+ tname prototype ctxt)))
+
+ ;; Try some backup template names.
+ (when (not temp)
+ (cond
+ ;; Types might split things up based on the type's type.
+ ((and (eq (semantic-tag-class tag) 'type)
+ (semantic-tag-type tag))
+ (setq temp (srecode-semantic-find-template
+ (semantic-tag-type tag) prototype ctxt))
+ (setq errtype (concat errtype " or " (semantic-tag-type tag)))
+ )
+ ;; A function might be an externally declared method.
+ ((and (eq (semantic-tag-class tag) 'function)
+ (semantic-tag-function-parent tag))
+ (setq temp (srecode-semantic-find-template
+ "method" prototype ctxt)))
+ (t
+ nil)
+ ))
+
+ ;; Can't find one? Drat!
+ (when (not temp)
+ (error "Cannot find template %s in %s for inserting tag %S"
+ errtype top (semantic-format-tag-summarize tag)))
+
+ ;; Resolve Arguments
+ (let ((srecode-semantic-selected-tag tag))
+ (srecode-resolve-arguments temp dict))
+
+ ;; Resolve TAG into the dictionary. We may have a :tag arg
+ ;; from the macro such that we don't need to do this.
+ (when (not (srecode-dictionary-lookup-name dict "TAG"))
+ (let ((tagobj (srecode-semantic-tag (semantic-tag-name tag) :prime tag))
+ )
+ (srecode-semantic-apply-tag-to-dict tagobj dict)))
+
+ ;; Insert dict-entries into the dictionary LAST so that previous
+ ;; items can be overriden.
+ (let ((entries dict-entries))
+ (while entries
+ (srecode-dictionary-set-value dict
+ (car entries)
+ (car (cdr entries)))
+ (setq entries (cdr (cdr entries)))))
+
+ ;; Insert the template.
+ (let ((endpt (srecode-insert-fcn temp dict nil t)))
+
+ (run-hook-with-args 'point-insert-fcn tag)
+ ;;(sit-for 1)
+
+ (cond
+ ((semantic-tag-of-class-p tag 'type)
+ ;; Insert all the members at the current insertion point.
+ (dolist (m (semantic-tag-type-members tag))
+
+ (when (stringp m)
+ (setq m (semantic-tag-new-variable m nil nil)))
+
+ ;; We do prototypes w/in the class decl?
+ (let ((me (srecode-semantic-insert-tag m '(prototype))))
+ (goto-char me))
+
+ ))
+ )
+
+ endpt)
+ ))
+
+ (provide 'srecode/semantic)
+
+ ;;; srecode/semantic.el ends here
--- /dev/null
-\f
-;;; MMM-Mode support ??
-;;(condition-case nil
-;; (require 'mmm-mode)
-;; (error (message "SRecoder Template Mode: No multi-mode not support.")))
-;;
-;;(defun srecode-template-add-submode ()
-;; "Add a submode to the current template file using mmm-mode.
-;;If mmm-mode isn't available, then do nothing."
-;; (if (not (featurep 'mmm-mode))
-;; nil ;; Nothing to do.
-;; ;; Else, set up mmm-mode in this buffer.
-;; (let ((submode (semantic-find-tags-by-name "mode")))
-;; (if (not submode)
-;; nil ;; Nothing to do.
-;; ;; Well, we have a mode, lets try turning on mmm-mode.
-;;
-;; ;; (mmm-mode-on)
-;;
-;;
-;;
-;; ))))
-;;
-
+ ;;; srecode/srt-mode.el --- Major mode for writing screcode macros
+
+ ;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc.
+
+ ;; This file is part of GNU Emacs.
+
+ ;; GNU Emacs is free software: you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation, either version 3 of the License, or
+ ;; (at your option) any later version.
+
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ ;; GNU General Public License for more details.
+
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+ ;;; Commentary:
+
+ ;; Originally named srecode-template-mode.el in the CEDET repository.
+
+ (require 'srecode/compile)
+ (require 'srecode/ctxt)
+ (require 'srecode/template)
+
+ (require 'semantic)
+ (require 'semantic/analyze)
+ (require 'semantic/wisent)
+ (eval-when-compile
+ (require 'semantic/find))
+
+ (declare-function srecode-create-dictionary "srecode/dictionary")
+ (declare-function srecode-resolve-argument-list "srecode/insert")
+
+ ;;; Code:
+ (defvar srecode-template-mode-syntax-table
+ (let ((table (make-syntax-table (standard-syntax-table))))
+ (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;;
+ (modify-syntax-entry ?\n ">" table) ;; Comment end
+ (modify-syntax-entry ?$ "." table) ;; Punctuation
+ (modify-syntax-entry ?: "." table) ;; Punctuation
+ (modify-syntax-entry ?< "." table) ;; Punctuation
+ (modify-syntax-entry ?> "." table) ;; Punctuation
+ (modify-syntax-entry ?# "." table) ;; Punctuation
+ (modify-syntax-entry ?! "." table) ;; Punctuation
+ (modify-syntax-entry ?? "." table) ;; Punctuation
+ (modify-syntax-entry ?\" "\"" table) ;; String
+ (modify-syntax-entry ?\- "_" table) ;; Symbol
+ (modify-syntax-entry ?\\ "\\" table) ;; Quote
+ (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote)
+ (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote)
+ (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma)
+
+ table)
+ "Syntax table used in semantic recoder macro buffers.")
+
+ (defface srecode-separator-face
+ '((t (:weight bold :strike-through t)))
+ "Face used for decorating separators in srecode template mode."
+ :group 'srecode)
+
+ (defvar srecode-font-lock-keywords
+ '(
+ ;; Template
+ ("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\|\\)+\\)$"
+ (1 font-lock-keyword-face)
+ (2 font-lock-function-name-face)
+ (3 font-lock-builtin-face ))
+ ("^\\(sectiondictionary\\)\\s-+\""
+ (1 font-lock-keyword-face))
+ ("^\\(bind\\)\\s-+\""
+ (1 font-lock-keyword-face))
+ ;; Variable type setting
+ ("^\\(set\\)\\s-+\\(\\w+\\)\\s-+"
+ (1 font-lock-keyword-face)
+ (2 font-lock-variable-name-face))
+ ("^\\(show\\)\\s-+\\(\\w+\\)\\s-*$"
+ (1 font-lock-keyword-face)
+ (2 font-lock-variable-name-face))
+ ("\\<\\(macro\\)\\s-+\""
+ (1 font-lock-keyword-face))
+ ;; Context type setting
+ ("^\\(context\\)\\s-+\\(\\w+\\)"
+ (1 font-lock-keyword-face)
+ (2 font-lock-builtin-face))
+ ;; Prompting setting
+ ("^\\(prompt\\)\\s-+\\(\\w+\\)"
+ (1 font-lock-keyword-face)
+ (2 font-lock-variable-name-face))
+ ("\\(default\\(macro\\)?\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
+ (1 font-lock-keyword-face)
+ (3 font-lock-type-face))
+ ("\\<\\(default\\(macro\\)?\\)\\>" (1 font-lock-keyword-face))
+ ("\\<\\(read\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)"
+ (1 font-lock-keyword-face)
+ (2 font-lock-type-face))
+
+ ;; Macro separators
+ ("^----\n" 0 'srecode-separator-face)
+
+ ;; Macro Matching
+ (srecode-template-mode-macro-escape-match 1 font-lock-string-face)
+ ((lambda (limit)
+ (srecode-template-mode-font-lock-macro-helper
+ limit "\\(\\??\\w+\\)[^ \t\n{}$#@&*()]*"))
+ 1 font-lock-variable-name-face)
+ ((lambda (limit)
+ (srecode-template-mode-font-lock-macro-helper
+ limit "\\([#/]\\w+\\)[^ \t\n{}$#@&*()]*"))
+ 1 font-lock-keyword-face)
+ ((lambda (limit)
+ (srecode-template-mode-font-lock-macro-helper
+ limit "\\([<>]\\w*\\):\\(\\w+\\):\\(\\w+\\)"))
+ (1 font-lock-keyword-face)
+ (2 font-lock-builtin-face)
+ (3 font-lock-type-face))
+ ((lambda (limit)
+ (srecode-template-mode-font-lock-macro-helper
+ limit "\\([<>?]?\\w*\\):\\(\\w+\\)"))
+ (1 font-lock-keyword-face)
+ (2 font-lock-type-face))
+ ((lambda (limit)
+ (srecode-template-mode-font-lock-macro-helper
+ limit "!\\([^{}$]*\\)"))
+ 1 font-lock-comment-face)
+
+ )
+ "Keywords for use with srecode macros and font-lock.")
+
+ (defun srecode-template-mode-font-lock-macro-helper (limit expression)
+ "Match against escape characters.
+ Don't scan past LIMIT. Match with EXPRESSION."
+ (let* ((done nil)
+ (md nil)
+ (es (regexp-quote (srecode-template-get-escape-start)))
+ (ee (regexp-quote (srecode-template-get-escape-end)))
+ (regex (concat es expression ee))
+ )
+ (while (not done)
+ (save-match-data
+ (if (re-search-forward regex limit t)
+ (when (equal (car (srecode-calculate-context)) "code")
+ (setq md (match-data)
+ done t))
+ (setq done t))))
+ (set-match-data md)
+ ;; (when md (message "Found a match!"))
+ (when md t)))
+
+ (defun srecode-template-mode-macro-escape-match (limit)
+ "Match against escape characters.
+ Don't scan past LIMIT."
+ (let* ((done nil)
+ (md nil)
+ (es (regexp-quote (srecode-template-get-escape-start)))
+ (ee (regexp-quote (srecode-template-get-escape-end)))
+ (regex (concat "\\(" es "\\|" ee "\\)"))
+ )
+ (while (not done)
+ (save-match-data
+ (if (re-search-forward regex limit t)
+ (when (equal (car (srecode-calculate-context)) "code")
+ (setq md (match-data)
+ done t))
+ (setq done t))))
+ (set-match-data md)
+ ;;(when md (message "Found a match!"))
+ (when md t)))
+
+ (defvar srecode-font-lock-macro-keywords nil
+ "Dynamically generated `font-lock' keywords for srecode templates.
+ Once the escape_start, and escape_end sequences are known, then
+ we can tell font lock about them.")
+
+ (defvar srecode-template-mode-map
+ (let ((km (make-sparse-keymap)))
+ (define-key km "\C-c\C-c" 'srecode-compile-templates)
+ (define-key km "\C-c\C-m" 'srecode-macro-help)
+ (define-key km "/" 'srecode-self-insert-complete-end-macro)
+ km)
+ "Keymap used in srecode mode.")
+
+ ;;;###autoload
+ (defun srecode-template-mode ()
+ "Major-mode for writing srecode macros."
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'srecode-template-mode
+ mode-name "SRecoder"
+ comment-start ";;"
+ comment-end "")
+ (set (make-local-variable 'parse-sexp-ignore-comments) t)
+ (set (make-local-variable 'comment-start-skip)
+ "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *")
+ (set-syntax-table srecode-template-mode-syntax-table)
+ (use-local-map srecode-template-mode-map)
+ (set (make-local-variable 'font-lock-defaults)
+ '(srecode-font-lock-keywords
+ nil ;; perform string/comment fontification
+ nil ;; keywords are case sensitive.
+ ;; This puts _ & - as a word constituant,
+ ;; simplifying our keywords significantly
+ ((?_ . "w") (?- . "w"))))
+ (run-hooks 'srecode-template-mode-hook))
+
+ ;;;###autoload
+ (defalias 'srt-mode 'srecode-template-mode)
+
+ ;;; Template Commands
+ ;;
+ (defun srecode-self-insert-complete-end-macro ()
+ "Self insert the current key, then autocomplete the end macro."
+ (interactive)
+ (call-interactively 'self-insert-command)
+ (when (and (semantic-current-tag)
+ (semantic-tag-of-class-p (semantic-current-tag) 'function)
+ )
+ (let* ((es (srecode-template-get-escape-start))
+ (ee (srecode-template-get-escape-end))
+ (name (save-excursion
+ (forward-char (- (length es)))
+ (forward-char -1)
+ (if (looking-at (regexp-quote es))
+ (srecode-up-context-get-name (point) t))))
+ )
+ (when name
+ (insert name)
+ (insert ee))))
+ )
+
+
+ (defun srecode-macro-help ()
+ "Provide help for working with macros in a tempalte."
+ (interactive)
+ (let* ((root 'srecode-template-inserter)
+ (chl (aref (class-v root) class-children))
+ (ess (srecode-template-get-escape-start))
+ (ees (srecode-template-get-escape-end))
+ )
+ (with-output-to-temp-buffer "*SRecode Macros*"
+ (princ "Description of known SRecode Template Macros.")
+ (terpri)
+ (terpri)
+ (while chl
+ (let* ((C (car chl))
+ (name (symbol-name C))
+ (key (when (slot-exists-p C 'key)
+ (oref C key)))
+ (showexample t)
+ )
+ (setq chl (cdr chl))
+ (setq chl (append (aref (class-v C) class-children) chl))
+
+ (catch 'skip
+ (when (eq C 'srecode-template-inserter-section-end)
+ (throw 'skip nil))
+
+ (when (class-abstract-p C)
+ (throw 'skip nil))
+
+ (princ "`")
+ (princ name)
+ (princ "'")
+ (when (slot-exists-p C 'key)
+ (when key
+ (princ " - Character Key: ")
+ (if (stringp key)
+ (progn
+ (setq showexample nil)
+ (cond ((string= key "\n")
+ (princ "\"\\n\"")
+ )
+ (t
+ (prin1 key)
+ )))
+ (prin1 (format "%c" key))
+ )))
+ (terpri)
+ (princ (documentation-property C 'variable-documentation))
+ (terpri)
+ (when showexample
+ (princ "Example:")
+ (terpri)
+ (srecode-inserter-prin-example C ess ees)
+ )
+
+ (terpri)
+
+ ) ;; catch
+ );; let*
+ ))))
+
+ \f
+ ;;; Misc Language Overrides
+ ;;
+ (define-mode-local-override semantic-ia-insert-tag
+ srecode-template-mode (tag)
+ "Insert the SRecode TAG into the current buffer."
+ (insert (semantic-tag-name tag)))
+
+ \f
+ ;;; Local Context Parsing.
+
+ (defun srecode-in-macro-p (&optional point)
+ "Non-nil if POINT is inside a macro bounds.
+ If the ESCAPE_START and END are different sequences,
+ a simple search is used. If ESCAPE_START and END are the same
+ characteres, start at the beginning of the line, and find out
+ how many occur."
+ (let ((tag (semantic-current-tag))
+ (es (regexp-quote (srecode-template-get-escape-start)))
+ (ee (regexp-quote (srecode-template-get-escape-end)))
+ (start (or point (point)))
+ )
+ (when (and tag (semantic-tag-of-class-p tag 'function))
+ (if (string= es ee)
+ (save-excursion
+ (beginning-of-line)
+ (while (re-search-forward es start t 2))
+ (if (re-search-forward es start t)
+ ;; If there is a single, the the answer is yes.
+ t
+ ;; If there wasn't another, then the answer is no.
+ nil)
+ )
+ ;; ES And EE are not the same.
+ (save-excursion
+ (and (re-search-backward es (semantic-tag-start tag) t)
+ (>= (or (re-search-forward ee (semantic-tag-end tag) t)
+ ;; No end match means an incomplete macro.
+ start)
+ start)))
+ ))))
+
+ (defun srecode-up-context-get-name (&optional point find-unmatched)
+ "Move up one context as for `semantic-up-context', and return the name.
+ Moves point to the opening characters of the section macro text.
+ If there is no upper context, return nil.
+ Starts at POINT if provided.
+ If FIND-UNMATCHED is specified as non-nil, then we are looking for an unmatched
+ section."
+ (when point (goto-char (point)))
+ (let* ((tag (semantic-current-tag))
+ (es (regexp-quote (srecode-template-get-escape-start)))
+ (start (concat es "[#<]\\(\\w+\\)"))
+ (orig (point))
+ (name nil)
+ (res nil))
+ (when (semantic-tag-of-class-p tag 'function)
+ (while (and (not res)
+ (re-search-backward start (semantic-tag-start tag) t))
+ (when (save-excursion
+ (setq name (match-string 1))
+ (let ((endr (concat es "/" name)))
+ (if (re-search-forward endr (semantic-tag-end tag) t)
+ (< orig (point))
+ (if (not find-unmatched)
+ (error "Unmatched Section Template")
+ ;; We found what we want.
+ t))))
+ (setq res (point)))
+ )
+ ;; Restore in no result found.
+ (goto-char (or res orig))
+ name)))
+
+ (define-mode-local-override semantic-up-context
+ srecode-template-mode (&optional point)
+ "Move up one context in the current code.
+ Moves out one named section."
+ (not (srecode-up-context-get-name point)))
+
+ (define-mode-local-override semantic-beginning-of-context
+ srecode-template-mode (&optional point)
+ "Move to the beginning of the current context.
+ Moves the the beginning of one named section."
+ (if (semantic-up-context point)
+ t
+ (let ((es (regexp-quote (srecode-template-get-escape-start)))
+ (ee (regexp-quote (srecode-template-get-escape-end))))
+ (re-search-forward es) ;; move over the start chars.
+ (re-search-forward ee) ;; Move after the end chars.
+ nil)))
+
+ (define-mode-local-override semantic-end-of-context
+ srecode-template-mode (&optional point)
+ "Move to the beginning of the current context.
+ Moves the the beginning of one named section."
+ (let ((name (srecode-up-context-get-name point))
+ (tag (semantic-current-tag))
+ (es (regexp-quote (srecode-template-get-escape-start))))
+ (if (not name)
+ t
+ (unless (re-search-forward (concat es "/" name) (semantic-tag-end tag) t)
+ (error "Section %s has no end" name))
+ (goto-char (match-beginning 0))
+ nil)))
+
+ (define-mode-local-override semantic-get-local-variables
+ srecode-template-mode (&optional point)
+ "Get local variables from an SRecode template."
+ (save-excursion
+ (when point (goto-char (point)))
+ (let* ((tag (semantic-current-tag))
+ (name (save-excursion
+ (srecode-up-context-get-name (point))))
+ (subdicts (semantic-tag-get-attribute tag :dictionaries))
+ (global nil)
+ )
+ (dolist (D subdicts)
+ (setq global (cons (semantic-tag-new-variable (car D) nil)
+ global)))
+ (if name
+ ;; Lookup any subdictionaries in TAG.
+ (let ((res nil))
+
+ (while (and (not res) subdicts)
+ ;; Find the subdictionary with the same name. Those variables
+ ;; are now local to this section.
+ (when (string= (car (car subdicts)) name)
+ (setq res (cdr (car subdicts))))
+ (setq subdicts (cdr subdicts)))
+ ;; Pre-pend our global vars.
+ (append global res))
+ ;; If we aren't in a subsection, just do the global variables
+ global
+ ))))
+
+ (define-mode-local-override semantic-get-local-arguments
+ srecode-template-mode (&optional point)
+ "Get local arguments from an SRecode template."
+ (require 'srecode/insert)
+ (save-excursion
+ (when point (goto-char (point)))
+ (let* ((tag (semantic-current-tag))
+ (args (semantic-tag-function-arguments tag))
+ (argsym (mapcar 'intern args))
+ (argvars nil)
+ ;; Create a temporary dictionary in which the
+ ;; arguments can be resolved so we can extract
+ ;; the results.
+ (dict (srecode-create-dictionary t))
+ )
+ ;; Resolve args into our temp dictionary
+ (srecode-resolve-argument-list argsym dict)
+
+ (maphash
+ (lambda (key entry)
+ (setq argvars
+ (cons (semantic-tag-new-variable key nil entry)
+ argvars)))
+ (oref dict namehash))
+
+ argvars)))
+
+ (define-mode-local-override semantic-ctxt-current-symbol
+ srecode-template-mode (&optional point)
+ "Return the current symbol under POINT.
+ Return nil if point is not on/in a template macro."
+ (let ((macro (srecode-parse-this-macro point)))
+ (cdr macro))
+ )
+
+ (defun srecode-parse-this-macro (&optional point)
+ "Return the current symbol under POINT.
+ Return nil if point is not on/in a template macro.
+ The first element is the key for the current macro, such as # for a
+ section or ? for an ask variable."
+ (save-excursion
+ (if point (goto-char point))
+ (let ((tag (semantic-current-tag))
+ (es (regexp-quote (srecode-template-get-escape-start)))
+ (ee (regexp-quote (srecode-template-get-escape-end)))
+ (start (point))
+ (macrostart nil)
+ (raw nil)
+ )
+ (when (and tag (semantic-tag-of-class-p tag 'function)
+ (srecode-in-macro-p point)
+ (re-search-backward es (semantic-tag-start tag) t))
+ (setq macrostart (match-end 0))
+ (goto-char macrostart)
+ ;; We have a match
+ (when (not (re-search-forward ee (semantic-tag-end tag) t))
+ (goto-char start) ;; Pretend we are ok for completion
+ (set-match-data (list start start))
+ )
+
+ (if (> start (point))
+ ;; If our starting point is after the found point, that
+ ;; means we are not inside the macro. Retur nil.
+ nil
+ ;; We are inside the macro, extract the text so far.
+ (let* ((macroend (match-beginning 0))
+ (raw (buffer-substring-no-properties
+ macrostart macroend))
+ (STATE (srecode-compile-state "TMP"))
+ (inserter (condition-case nil
+ (srecode-compile-parse-inserter
+ raw STATE)
+ (error nil)))
+ )
+ (when inserter
+ (let ((base
+ (cons (oref inserter :object-name)
+ (if (and (slot-boundp inserter :secondname)
+ (oref inserter :secondname))
+ (split-string (oref inserter :secondname)
+ ":")
+ nil)))
+ (key (oref inserter key)))
+ (cond ((null key)
+ ;; A plain variable
+ (cons nil base))
+ (t
+ ;; A complex variable thingy.
+ (cons (format "%c" key)
+ base)))))
+ )
+ )))
+ ))
+
+ (define-mode-local-override semantic-analyze-current-context
+ srecode-template-mode (point)
+ "Provide a Semantic analysis in SRecode template mode."
+ (let* ((context-return nil)
+ (prefixandbounds (semantic-ctxt-current-symbol-and-bounds))
+ (prefix (car prefixandbounds))
+ (bounds (nth 2 prefixandbounds))
+ (key (car (srecode-parse-this-macro (point))))
+ (prefixsym nil)
+ (prefix-var nil)
+ (prefix-context nil)
+ (prefix-function nil)
+ (prefixclass (semantic-ctxt-current-class-list))
+ (globalvar (semantic-find-tags-by-class 'variable (current-buffer)))
+ (argtype 'macro)
+ (scope (semantic-calculate-scope point))
+ )
+
+ (oset scope fullscope (append (oref scope localvar) globalvar))
+
+ (when prefix
+ ;; First, try to find the variable for the first
+ ;; entry in the prefix list.
+ (setq prefix-var (semantic-find-first-tag-by-name
+ (car prefix) (oref scope fullscope)))
+
+ (cond
+ ((and (or (not key) (string= key "?"))
+ (> (length prefix) 1))
+ ;; Variables can have lisp function names.
+ (with-mode-local emacs-lisp-mode
+ (let ((fcns (semanticdb-find-tags-by-name (car (last prefix)))))
+ (setq prefix-function (car (semanticdb-find-result-nth fcns 0)))
+ (setq argtype 'elispfcn)))
+ )
+ ((or (string= key "<") (string= key ">"))
+ ;; Includes have second args that is the template name.
+ (if (= (length prefix) 3)
+ (let ((contexts (semantic-find-tags-by-class
+ 'context (current-buffer))))
+ (setq prefix-context
+ (or (semantic-find-first-tag-by-name
+ (nth 1 prefix) contexts)
+ ;; Calculate from location
+ (semantic-tag
+ (symbol-name
+ (srecode-template-current-context))
+ 'context)))
+ (setq argtype 'template))
+ (setq prefix-context
+ ;; Calculate from location
+ (semantic-tag
+ (symbol-name (srecode-template-current-context))
+ 'context))
+ (setq argtype 'template)
+ )
+ ;; The last one?
+ (when (> (length prefix) 1)
+ (let ((toc (srecode-template-find-templates-of-context
+ (read (semantic-tag-name prefix-context))))
+ )
+ (setq prefix-function
+ (or (semantic-find-first-tag-by-name
+ (car (last prefix)) toc)
+ ;; Not in this buffer? Search the master
+ ;; templates list.
+ nil))
+ ))
+ )
+ )
+
+ (setq prefixsym
+ (cond ((= (length prefix) 3)
+ (list (or prefix-var (nth 0 prefix))
+ (or prefix-context (nth 1 prefix))
+ (or prefix-function (nth 2 prefix))))
+ ((= (length prefix) 2)
+ (list (or prefix-var (nth 0 prefix))
+ (or prefix-function (nth 1 prefix))))
+ ((= (length prefix) 1)
+ (list (or prefix-var (nth 0 prefix)))
+ )))
+
+ (setq context-return
+ (semantic-analyze-context-functionarg
+ "context-for-srecode"
+ :buffer (current-buffer)
+ :scope scope
+ :bounds bounds
+ :prefix (or prefixsym
+ prefix)
+ :prefixtypes nil
+ :prefixclass prefixclass
+ :errors nil
+ ;; Use the functionarg analyzer class so we
+ ;; can save the current key, and the index
+ ;; into the macro part we are completing on.
+ :function (list key)
+ :index (length prefix)
+ :argument (list argtype)
+ ))
+
+ context-return)))
+
+ (define-mode-local-override semantic-analyze-possible-completions
+ srecode-template-mode (context)
+ "Return a list of possible completions based on NONTEXT."
+ (save-excursion
+ (set-buffer (oref context buffer))
+ (let* ((prefix (car (last (oref context :prefix))))
+ (prefixstr (cond ((stringp prefix)
+ prefix)
+ ((semantic-tag-p prefix)
+ (semantic-tag-name prefix))))
+ ; (completetext (cond ((semantic-tag-p prefix)
+ ; (semantic-tag-name prefix))
+ ; ((stringp prefix)
+ ; prefix)
+ ; ((stringp (car prefix))
+ ; (car prefix))))
+ (argtype (car (oref context :argument)))
+ (matches nil))
+
+ ;; Depending on what the analyzer is, we have different ways
+ ;; of creating completions.
+ (cond ((eq argtype 'template)
+ (setq matches (semantic-find-tags-for-completion
+ prefixstr (current-buffer)))
+ (setq matches (semantic-find-tags-by-class
+ 'function matches))
+ )
+ ((eq argtype 'elispfcn)
+ (with-mode-local emacs-lisp-mode
+ (setq matches (semanticdb-find-tags-for-completion
+ prefixstr))
+ (setq matches (semantic-find-tags-by-class
+ 'function matches))
+ )
+ )
+ ((eq argtype 'macro)
+ (let ((scope (oref context scope)))
+ (setq matches
+ (semantic-find-tags-for-completion
+ prefixstr (oref scope fullscope))))
+ )
+ )
+
+ matches)))
+
+
+ \f
+ ;;; Utils
+ ;;
+ (defun srecode-template-get-mode ()
+ "Get the supported major mode for this template file."
+ (let ((m (semantic-find-first-tag-by-name "mode" (current-buffer))))
+ (when m (read (semantic-tag-variable-default m)))))
+
+ (defun srecode-template-get-escape-start ()
+ "Get the current escape_start characters."
+ (let ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer)))
+ )
+ (if es (car (semantic-tag-get-attribute es :default-value))
+ "{{")))
+
+ (defun srecode-template-get-escape-end ()
+ "Get the current escape_end characters."
+ (let ((ee (semantic-find-first-tag-by-name "escape_end" (current-buffer)))
+ )
+ (if ee (car (semantic-tag-get-attribute ee :default-value))
+ "}}")))
+
+ (defun srecode-template-current-context (&optional point)
+ "Calculate the context encompassing POINT."
+ (save-excursion
+ (when point (goto-char (point)))
+ (let ((ct (semantic-current-tag)))
+ (when (not ct)
+ (setq ct (semantic-find-tag-by-overlay-prev)))
+
+ ;; Loop till we find the context.
+ (while (and ct (not (semantic-tag-of-class-p ct 'context)))
+ (setq ct (semantic-find-tag-by-overlay-prev
+ (semantic-tag-start ct))))
+
+ (if ct
+ (read (semantic-tag-name ct))
+ 'declaration))))
+
+ (defun srecode-template-find-templates-of-context (context &optional buffer)
+ "Find all the templates belonging to a particular CONTEXT.
+ When optional BUFFER is provided, search that buffer."
+ (save-excursion
+ (when buffer (set-buffer buffer))
+ (let ((tags (semantic-fetch-available-tags))
+ (cc 'declaration)
+ (scan nil)
+ (ans nil))
+
+ (when (eq cc context)
+ (setq scan t))
+
+ (dolist (T tags)
+ ;; Handle contexts
+ (when (semantic-tag-of-class-p T 'context)
+ (setq cc (read (semantic-tag-name T)))
+ (when (eq cc context)
+ (setq scan t)))
+
+ ;; Scan
+ (when (and scan (semantic-tag-of-class-p T 'function))
+ (setq ans (cons T ans)))
+ )
+
+ (nreverse ans))))
+
+ (provide 'srecode/srt-mode)
+
+ ;; The autoloads in this file must go into the global loaddefs.el, not
+ ;; the srecode one, so that srecode-template-mode can be called from
+ ;; auto-mode-alist.
+
+ ;; Local variables:
+ ;; generated-autoload-load-name: "srecode/srt-mode"
+ ;; End:
+
+ ;;; srecode/srt-mode.el ends here