# HG changeset patch # User Chong Yidong # Date 1254150900 0 # Node ID bbd7017a25d90b854aa1774fc7ac3fff2fcfda64 # Parent 5707f7454ab5cd9798b5268147ea919945add6e1# Parent fbd55cc47b77534a01e5083a37c05e2600cc2af2 CEDET (development tools) package merged. * cedet/*.el: * cedet/ede/*.el: * cedet/semantic/*.el: * cedet/srecode/*.el: New files. diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/ChangeLog --- a/lisp/ChangeLog Mon Sep 28 14:27:48 2009 +0000 +++ b/lisp/ChangeLog Mon Sep 28 15:15:00 2009 +0000 @@ -1,3 +1,12 @@ +2009-09-28 Eric Ludlam + + CEDET (development tools) package merged. + + * cedet/*.el: + * cedet/ede/*.el: + * cedet/semantic/*.el: + * cedet/srecode/*.el: New files. + 2009-09-28 Michael Albinus * Makefile.in (ELCFILES): Add net/tramp-imap.elc. diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/cedet.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/cedet.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,145 @@ +;;; cedet.el --- Setup CEDET environment + +;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: David Ponce +;; Maintainer: Eric M. Ludlam +;; Version: 0.2 +;; Keywords: OO, lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: +;; +;; This file depends on the major components of CEDET, so that you can +;; load them all by doing (require 'cedet). This is mostly for +;; compatibility with the upstream, stand-alone CEDET distribution. + +(eval-when-compile + (require 'cl)) + +(declare-function inversion-find-version "inversion") + +(defconst cedet-version "1.0pre7" + "Current version of CEDET.") + +(defconst cedet-packages + `( + ;;PACKAGE MIN-VERSION + (cedet ,cedet-version) + (eieio "1.2") + (semantic "2.0pre7") + (srecode "1.0pre7") + (ede "1.0pre7") + (speedbar "1.0.3")) + "Table of CEDET packages to install.") + +(defvar cedet-menu-map ;(make-sparse-keymap "CEDET menu") + (let ((map (make-sparse-keymap "CEDET menu"))) + (define-key map [semantic-force-refresh] 'undefined) + (define-key map [semantic-edit-menu] 'undefined) + (define-key map [navigate-menu] 'undefined) + (define-key map [semantic-options-separator] 'undefined) + (define-key map [global-semantic-highlight-func-mode] 'undefined) + (define-key map [global-semantic-highlight-func-mode] 'undefined) + (define-key map [global-semantic-decoration-mode] 'undefined) + (define-key map [global-semantic-idle-completions-mode] 'undefined) + (define-key map [global-semantic-idle-summary-mode] 'undefined) + (define-key map [global-semanticdb-minor-mode] 'undefined) + (define-key map [global-semantic-idle-scheduler-mode] 'undefined) + (define-key map [semantic-menu-separator] '("--")) + (define-key map [semantic-mode] + '(menu-item "Enable Parsers (Semantic)" semantic-mode + :help "Enable language parsers (Semantic)" + :visible (not (bound-and-true-p semantic-mode)))) + (define-key map [cedet-menu-separator] 'undefined) + (define-key map [ede-mode] + '(menu-item "Enable Project Support (EDE)" global-ede-mode + :help "Enable the Emacs Development Environment (EDE)" + :visible (not (bound-and-true-p global-ede-mode)))) + (define-key map [ede-menu-separator] '("--")) + (define-key map [ede-find-file] 'undefined) + (define-key map [ede-speedbar] 'undefined) + (define-key map [ede] 'undefined) + (define-key map [ede-new] 'undefined) + (define-key map [ede-target-options] 'undefined) + (define-key map [ede-project-options] 'undefined) + (define-key map [ede-build-forms-menu] 'undefined) + map) + "Menu keymap for the CEDET package. +This is used by `semantic-mode' and `global-ede-mode'.") + +(defun cedet-version () + "Display all active versions of CEDET and Dependant packages. + +The PACKAGE column is the name of a given package from CEDET. + +REQUESTED VERSION is the version requested by the CEDET load script. +See `cedet-packages' for details. + +FILE VERSION is the version number found in the source file +for the specificed PACKAGE. + +LOADED VERSION is the version of PACKAGE current loaded in Emacs +memory and (presumably) running in this Emacs instance. Value is X +if the package has not been loaded." + (interactive) + (require 'inversion) + (with-output-to-temp-buffer "*CEDET*" + (princ "CEDET Version:\t") (princ cedet-version) + (princ "\n \t\t\tRequested\tFile\t\tLoaded") + (princ "\n Package\t\tVersion\t\tVersion\t\tVersion") + (princ "\n ----------------------------------------------------------") + (let ((p cedet-packages)) + (while p + (let ((sym (symbol-name (car (car p))))) + (princ "\n ") + (princ sym) + (princ ":\t") + (if (< (length sym) 5) + (princ "\t")) + (if (< (length sym) 13) + (princ "\t")) + (let ((reqver (nth 1 (car p))) + (filever (car (inversion-find-version sym))) + (loadver (when (featurep (car (car p))) + (symbol-value (intern-soft (concat sym "-version")))))) + (princ reqver) + (if (< (length reqver) 8) (princ "\t")) + (princ "\t") + (if (string= filever reqver) + ;; I tried the words "check" and "match", but that + ;; just looked lame. + (princ "ok\t") + (princ filever) + (if (< (length filever) 8) (princ "\t"))) + (princ "\t") + (if loadver + (if (string= loadver reqver) + (princ "ok") + (princ loadver)) + (princ "Not Loaded")) + )) + (setq p (cdr p)))) + (princ "\n\n\nC-h f cedet-version RET\n for details on output format.") + )) + +(provide 'cedet) + +;;; cedet.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,1986 @@ +;;; 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 +;; 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 . + +;;; 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) + +;;; 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.") + +;;; 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)) + ))) + +;;; 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) + + +;;; 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))) + +;;; 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) + (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)))) + +;;; 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)))))) + + +;;; 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 + ) + + +;;; 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 + ) + + +;;; 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))) + +;;; 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)) + +;;; 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))) + + +;;; 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." + (eval (cons 'or (ede-map-targets this proc)))) + + +;;; 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) + + +;;; 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) + + +;;; 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)) + + +;;; 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) "") + )) + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/.cvsignore --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/.cvsignore Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,1 @@ +loaddefs.el diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/autoconf-edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/autoconf-edit.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,424 @@ +;;; ede/autoconf-edit.el --- Keymap for autoconf + +;;; Copyright (C) 1998, 1999, 2000, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: project + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Autoconf editing and modification support, and compatibility layer +;; for Emacses w/out autoconf mode built in. + +;;; Code: +(require 'autoconf) + +(defvar autoconf-new-automake-string + "dnl Process this file with autoconf to produce a configure script + +AC_INIT(%s) +AM_INIT_AUTOMAKE([%s], 0) +AM_CONFIG_HEADER(config.h) + +dnl End the configure script. +AC_OUTPUT(Makefile, [date > stamp-h] )\n" + "This string is used to initialize a new configure.in. +The default is designed to be used with automake. +The first %s will be filled with the test file. +The second %s will be filled with the program name.") + +(defun autoconf-new-program (rootdir program testfile) + "Initialize a new configure.in in ROOTDIR for PROGRAM using TESTFILE. +ROOTDIR is the root directory of a given autoconf controlled project. +PROGRAM is the program to be configured. +TESTFILE is the file used with AC_INIT. +configure the initial configure script using `autoconf-new-automake-string'" + (interactive "DRoot Dir: \nsProgram: \nsTest File: ") + (if (bufferp rootdir) + (set-buffer rootdir) + (let ((cf1 (expand-file-name "configure.in" rootdir)) + (cf2 (expand-file-name "configure.ac" rootdir))) + (if (and (or (file-exists-p cf1) (file-exists-p cf2)) + (not (y-or-n-p (format "File %s exists. Start Over? " + (if (file-exists-p cf1) + cf1 cf2) + )))) + (error "Quit")) + (find-file cf2))) + ;; Note, we only ask about overwrite if a string/path is specified. + (erase-buffer) + (insert (format autoconf-new-automake-string testfile program))) + +(defvar autoconf-preferred-macro-order + '("AC_INIT" + "AM_INIT_AUTOMAKE" + "AM_CONFIG_HEADER" + ;; Arg parsing + "AC_ARG_ENABLE" + "AC_ARG_WITH" + ;; Programs + "AC_PROG_MAKE_SET" + "AC_PROG_AWK" + "AC_PROG_CC" + "AC_PROG_CC_C_O" + "AC_PROG_CPP" + "AC_PROG_CXX" + "AC_PROG_CXXCPP" + "AC_ISC_POSIX" + "AC_PROG_F77" + "AC_PROG_GCC_TRADITIONAL" + "AC_PROG_INSTALL" + "AC_PROG_LEX" + "AC_PROG_LN_S" + "AC_PROG_RANLIB" + "AC_PROG_YACC" + "AC_CHECK_PROG" + "AC_CHECK_PROGS" + "AC_PROG_LIBTOOL" + ;; Libraries + "AC_CHECK_LIB" + "AC_PATH_XTRA" + ;; Headers + "AC_HEADER_STDC" + "AC_HEADER_SYS_WAIT" + "AC_HEADER_TIME" + "AC_HEADERS" + ;; Typedefs, structures + "AC_TYPE_PID_T" + "AC_TYPE_SIGNAL" + "AC_TYPE_UID_T" + "AC_STRUCT_TM" + ;; Compiler characteristics + "AC_CHECK_SIZEOF" + "AC_C_CONST" + ;; Library functions + "AC_CHECK_FUNCS" + "AC_TRY_LINK" + ;; System Services + ;; Other + "AM_PATH_LISPDIR" + "AM_INIT_GUILE_MODULE" + ;; AC_OUTPUT is always last + "AC_OUTPUT" + ) + "List of macros in the order that they prefer to occur in. +This helps when inserting a macro which doesn't yet exist +by positioning it near other macros which may exist. +From the autoconf manual: + `AC_INIT(FILE)' + checks for programs + checks for libraries + checks for header files + checks for typedefs + checks for structures + checks for compiler characteristics + checks for library functions + checks for system services + `AC_OUTPUT([FILE...])'") + +(defvar autoconf-multiple-macros + '("AC_ARG_ENABLE" + "AC_ARG_WITH" + "AC_CHECK_PROGS" + "AC_CHECK_LIB" + "AC_CHECK_SIZEOF" + "AC_TRY_LINK" + ) + "Macros which appear multiple times.") + +(defvar autoconf-multiple-multiple-macros + '("AC_HEADERS" "AC_CHECK_FUNCS") + "Macros which appear multiple times, and perform multiple queries.") + +(defun autoconf-in-macro (macro) + "Non-nil if point is in a macro of type MACRO." + (save-excursion + (beginning-of-line) + (looking-at (concat "\\(A[CM]_" macro "\\|" macro "\\)")))) + +(defun autoconf-find-last-macro (macro) + "Move to the last occurance of MACRO in FILE, and return that point. +The last macro is usually the one in which we would like to insert more +items such as CHECK_HEADERS." + (let ((op (point))) + (goto-char (point-max)) + (if (re-search-backward (concat "^" (regexp-quote macro) "\\s-*\\((\\|$\\)") nil t) + (progn + (beginning-of-line) + (point)) + (goto-char op) + nil))) + +(defun autoconf-parameter-strip (param) + "Strip the parameter PARAM of whitespace and misc characters." + (when (string-match "^\\s-*\\[?\\s-*" param) + (setq param (substring param (match-end 0)))) + (when (string-match "\\s-*\\]?\\s-*$" param) + (setq param (substring param 0 (match-beginning 0)))) + param) + +(defun autoconf-parameters-for-macro (macro) + "Retrieve the parameters to MACRO. +Returns a list of the arguments passed into MACRO as strings." + (save-excursion + (when (autoconf-find-last-macro macro) + (forward-sexp 1) + (mapcar + #'autoconf-parameter-strip + (when (looking-at "(") + (let* ((start (+ (point) 1)) + (end (save-excursion + (forward-sexp 1) + (- (point) 1))) + (ans (buffer-substring-no-properties start end))) + (split-string ans "," t))))))) + +(defun autoconf-position-for-macro (macro) + "Position the cursor where a new MACRO could be inserted. +This will appear at the BEGINNING of the macro MACRO should appear AFTER. +This is to make it compatible with `autoconf-find-last-macro'. +Assume that MACRO doesn't appear in the buffer yet, so search +the ordering list `autoconf-preferred-macro-order'." + ;; Search this list backwards.. heh heh heh + ;; This lets us do a reverse search easilly. + (let ((ml (member macro (reverse autoconf-preferred-macro-order)))) + (if (not ml) (error "Don't know how to position for %s yet" macro)) + (setq ml (cdr ml)) + (goto-char (point-max)) + (while (and ml (not (autoconf-find-last-macro (car ml)))) + (setq ml (cdr ml))) + (if (not ml) (error "Could not find context for positioning %s" macro)))) + +(defun autoconf-insert-macro-at-point (macro &optional param) + "Add MACRO at the current point with PARAM." + (insert macro) + (if param + (progn + (insert "(" param ")") + (if (< (current-column) 3) (insert " dnl"))))) + +(defun autoconf-insert-new-macro (macro &optional param) + "Add a call to MACRO in the current autoconf file. +Deals with macro order. See `autoconf-preferred-macro-order' and +`autoconf-multi-macros'. +Optional argument PARAM is the parameter to pass to the macro as one string." + (cond ((member macro autoconf-multiple-macros) + ;; This occurs multiple times + (or (autoconf-find-last-macro macro) + (autoconf-position-for-macro macro)) + (forward-sexp 2) + (end-of-line) + (insert "\n") + (autoconf-insert-macro-at-point macro param)) + ((member macro autoconf-multiple-multiple-macros) + (if (not param) + (error "You must have a paramter for %s" macro)) + (if (not (autoconf-find-last-macro macro)) + (progn + ;; Doesn't exist yet.... + (autoconf-position-for-macro macro) + (forward-sexp 2) + (end-of-line) + (insert "\n") + (autoconf-insert-macro-at-point macro param)) + ;; Does exist, can we fit onto the current line? + (forward-sexp 2) + (down-list -1) + (if (> (+ (current-column) (length param)) fill-column) + (insert " " param) + (up-list 1) + (end-of-line) + (insert "\n") + (autoconf-insert-macro-at-point macro param)))) + ((autoconf-find-last-macro macro) + ;; If it isn't one of the multi's, it's a singleton. + ;; If it exists, ignore it. + nil) + (t + (autoconf-position-for-macro macro) + (forward-sexp 1) + (if (looking-at "\\s-*(") + (forward-sexp 1)) + (end-of-line) + (insert "\n") + (autoconf-insert-macro-at-point macro param)))) + +(defun autoconf-find-query-for-header (header) + "Position the cursor where HEADER is queried." + (interactive "sHeader: ") + (let ((op (point)) + (found t)) + (goto-char (point-min)) + (condition-case nil + (while (not + (progn + (re-search-forward + (concat "\\b" (regexp-quote header) "\\b")) + (save-excursion + (beginning-of-line) + (looking-at "AC_CHECK_HEADERS"))))) + ;; We depend on the search failing to exit our loop on failure. + (error (setq found nil))) + (if (not found) (goto-char op)) + found)) + +(defun autoconf-add-query-for-header (header) + "Add in HEADER to be queried for in our autoconf file." + (interactive "sHeader: ") + (or (autoconf-find-query-for-header header) + (autoconf-insert-new-macro "AC_CHECK_HEADERS" header))) + + +(defun autoconf-find-query-for-func (func) + "Position the cursor where FUNC is queried." + (interactive "sFunction: ") + (let ((op (point)) + (found t)) + (goto-char (point-min)) + (condition-case nil + (while (not + (progn + (re-search-forward + (concat "\\b" (regexp-quote func) "\\b")) + (save-excursion + (beginning-of-line) + (looking-at "AC_CHECK_FUNCS"))))) + ;; We depend on the search failing to exit our loop on failure. + (error (setq found nil))) + (if (not found) (goto-char op)) + found)) + +(defun autoconf-add-query-for-func (func) + "Add in FUNC to be queried for in our autoconf file." + (interactive "sFunction: ") + (or (autoconf-find-query-for-func func) + (autoconf-insert-new-macro "AC_CHECK_FUNCS" func))) + +(defvar autoconf-program-builtin + '(("AWK" . "AC_PROG_AWK") + ("CC" . "AC_PROG_CC") + ("CPP" . "AC_PROG_CPP") + ("CXX" . "AC_PROG_CXX") + ("CXXCPP" . "AC_PROG_CXXCPP") + ("F77" . "AC_PROG_F77") + ("GCC_TRADITIONAL" . "AC_PROG_GCC_TRADITIONAL") + ("INSTALL" . "AC_PROG_INSTALL") + ("LEX" . "AC_PROG_LEX") + ("LN_S" . "AC_PROG_LN_S") + ("RANLIB" . "AC_PROG_RANLIB") + ("YACC" . "AC_PROG_YACC") + ) + "Association list of PROGRAM variables and their built-in MACRO.") + +(defun autoconf-find-query-for-program (prog) + "Position the cursor where PROG is queried. +PROG is the VARIABLE to use in autoconf to identify the program. +PROG excludes the _PROG suffix. Thus if PROG were EMACS, then the +variable in configure.in would be EMACS_PROG." + (let ((op (point)) + (found t) + (builtin (assoc prog autoconf-program-builtin))) + (goto-char (point-min)) + (condition-case nil + (re-search-forward + (concat "^" + (or (cdr-safe builtin) + (concat "AC_CHECK_PROG\\s-*(\\s-*" prog "_PROG")) + "\\>")) + (error (setq found nil))) + (if (not found) (goto-char op)) + found)) + +(defun autoconf-add-query-for-program (prog &optional names) + "Add in PROG to be queried for in our autoconf file. +Optional NAMES is for non-built-in programs, and is the list +of possible names." + (interactive "sProgram: ") + (if (autoconf-find-query-for-program prog) + nil + (let ((builtin (assoc prog autoconf-program-builtin))) + (if builtin + (autoconf-insert-new-macro (cdr builtin)) + ;; Not built in, try the params item + (autoconf-insert-new-macro "AC_CHECK_PROGS" (concat prog "," names)) + )))) + +;;; Scrappy little changes +;; +(defvar autoconf-deleted-text nil + "Set to the last bit of text deleted during an edit.") + +(defvar autoconf-inserted-text nil + "Set to the last bit of text inserted during an edit.") + +(defmacro autoconf-edit-cycle (&rest body) + "Start an edit cycle, unsetting the modified flag if there is no change. +Optional argument BODY is the code to execute which edits the autoconf file." + `(let ((autoconf-deleted-text nil) + (autoconf-inserted-text nil) + (mod (buffer-modified-p))) + ,@body + (if (and (not mod) + (string= autoconf-deleted-text autoconf-inserted-text)) + (set-buffer-modified-p nil)))) + +(defun autoconf-delete-parameter (index) + "Delete the INDEXth parameter from the macro starting on the current line. +Leaves the cursor where a new parameter can be inserted. +INDEX starts at 1." + (beginning-of-line) + (down-list 1) + (re-search-forward ", ?" nil nil (1- index)) + (let ((end (save-excursion + (re-search-forward ",\\|)" (save-excursion + (end-of-line) + (point))) + (forward-char -1) + (point)))) + (setq autoconf-deleted-text (buffer-substring (point) end)) + (delete-region (point) end))) + +(defun autoconf-insert (text) + "Insert TEXT." + (setq autoconf-inserted-text text) + (insert text)) + +(defun autoconf-set-version (version) + "Set the version used with automake to VERSION." + (if (not (stringp version)) + (signal 'wrong-type-argument '(stringp version))) + (if (not (autoconf-find-last-macro "AM_INIT_AUTOMAKE")) + (error "Cannot update version") + ;; Move to correct position. + (autoconf-edit-cycle + (autoconf-delete-parameter 2) + (autoconf-insert version)))) + +(defun autoconf-set-output (outputlist) + "Set the files created in AC_OUTPUT to OUTPUTLIST. +OUTPUTLIST is a list of strings representing relative paths +to Makefiles, or other files using Autoconf substitution." + (if (not (autoconf-find-last-macro "AC_OUTPUT")) + (error "Cannot update version") + (autoconf-edit-cycle + (autoconf-delete-parameter 1) + (autoconf-insert (mapconcat (lambda (a) a) outputlist " "))))) + +(provide 'ede/autoconf-edit) + +;;; ede/autoconf-edit.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/cpp-root.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/cpp-root.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,515 @@ +;;; ede/cpp-root.el --- A simple way to wrap a C++ project with a single root + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; NOTE: ede-cpp-root.el has been commented so as to also make it +;; useful for learning how to make similar project types. +;; +;; Not everyone can use automake, or an EDE project type. For +;; pre-existing code, it is often helpful jut to be able to wrap the +;; whole thing up in as simple a way as possible. +;; +;; The cpp-root project type will allow you to create a single object +;; with no save-file in your .emacs file that will be recognized, and +;; provide a way to easilly allow EDE to provide Semantic with the +;; ability to find header files, and other various source files +;; quickly. +;; +;; The cpp-root class knows a few things about C++ projects, such as +;; the prevalence of "include" directories, and typical file-layout +;; stuff. If this isn't sufficient, you can subclass +;; `ede-cpp-root-project' and add your own tweaks in just a few lines. +;; See the end of this file for an example. +;; +;;; EXAMPLE +;; +;; Add this to your .emacs file, modifying apropriate bits as needed. +;; +;; (ede-cpp-root-project "SOMENAME" :file "/dir/to/some/file") +;; +;; Replace SOMENAME with whatever name you want, and the filename to +;; an actual file at the root of your project. It might be a +;; Makefile, a README file. Whatever. It doesn't matter. It's just +;; a key to hang the rest of EDE off of. +;; +;; The most likely reason to create this project, is to help make +;; finding files within the project faster. In conjunction with +;; Semantic completion, having a short include path is key. You can +;; override the include path like this: +;; +;; (ede-cpp-root-project "NAME" :file "FILENAME" +;; :include-path '( "/include" "../include" "/c/include" ) +;; :system-include-path '( "/usr/include/c++/3.2.2/" ) +;; :spp-table '( ("MOOSE" . "") +;; ("CONST" . "const") ) +;; :spp-files '( "include/config.h" ) +;; ) +;; +;; In this case each item in the include path list is searched. If +;; the directory starts with "/", then that expands to the project +;; root directory. If a directory does not start with "/", then it +;; is relative to the default-directory of the current buffer when +;; the file name is expanded. +;; +;; The include path only affects C/C++ header files. Use the slot +;; :header-match-regexp to change it. +;; +;; The :system-include-path allows you to specify full directory +;; names to include directories where system header files can be +;; found. These will be applied to files in this project only. +;; +;; The :spp-table provides a list of project specific #define style +;; macros that are unique to this project, passed in to the compiler +;; on the command line, or are in special headers. +;; +;; The :spp-files option is like :spp-table, except you can provide a +;; file name for a header in your project where most of your CPP +;; macros reside. Doing this can be easier than listing everything in +;; the :spp-table option. The files listed in :spp-files should not +;; start with a /, and are relative to something in :include-path.;; +;; +;; If you want to override the file-finding tool with your own +;; function you can do this: +;; +;; (ede-cpp-root-project "NAME" :file "FILENAME" :locate-fcn 'MYFCN) +;; +;; Where FILENAME is a file in the root directory of the project. +;; Where MYFCN is a symbol for a function. See: +;; +;; M-x describe-class RET ede-cpp-root-project RET +;; +;; for documentation about the locate-fcn extension. +;; +;;; ADVANCED EXAMPLE +;; +;; If the cpp-root project style is right for you, but you want a +;; dynamic loader, instead of hard-coding values in your .emacs, you +;; can do that too, but you will need to write some lisp code. +;; +;; To do that, you need to add an entry to the +;; `ede-project-class-files' list, and also provide two functions to +;; teach EDE how to load your project pattern +;; +;; It would oook like this: +;; +;; (defun MY-FILE-FOR-DIR (&optional dir) +;; "Return a full file name to the project file stored in DIR." +;; +;; ) +;; +;; (defun MY-ROOT-FCN () +;; "Return the root directory for `default-directory'" +;; ;; You might be able to use `ede-cpp-root-project-root'. +;; ) +;; +;; (defun MY-LOAD (dir) +;; "Load a project of type `cpp-root' for the directory DIR. +;; Return nil if there isn't one." +;; (ede-cpp-root-project "NAME" :file (expand-file-name "FILE" dir) +;; :locate-fcn 'MYFCN) +;; ) +;; +;; (add-to-list 'ede-project-class-files +;; (ede-project-autoload "cpp-root" +;; :name "CPP ROOT" +;; :file 'ede-cpp-root +;; :proj-file 'MY-FILE-FOR-DIR +;; :proj-root 'MY-ROOT-FCN +;; :load-type 'MY-LOAD +;; :class-sym 'ede-cpp-root) +;; t) +;; +;;; TODO +;; +;; Need a way to reconfigure a project, and have it affect all open buffers. +;; From Tobias Gerdin: +;; +;; >>3) Is there any way to refresh a ede-cpp-root-project dynamically? I have +;; >>some file open part of the project, fiddle with the include paths and would +;; >>like the open buffer to notice this when I re-evaluate the +;; >>ede-cpp-root-project constructor. +;; > +;; > Another good idea. The easy way is to "revert-buffer" as needed. The +;; > ede "project local variables" does this already, so it should be easy +;; > to adapt something. +;; +;; I actually tried reverting the buffer but Semantic did not seem to pick +;; up the differences (the "include summary" reported the same include paths). + +(require 'ede) + +(defvar semantic-lex-spp-project-macro-symbol-obarray) +(declare-function semantic-lex-make-spp-table "semantic/lex-spp") +(declare-function semanticdb-file-table-object "semantic/db") +(declare-function semanticdb-needs-refresh-p "semantic/db") +(declare-function semanticdb-refresh-table "semantic/db") + +;;; Code: + +;;; PROJECT CACHE: +;; +;; cpp-root projects are created in a .emacs or other config file, but +;; there still needs to be a way for a particular file to be +;; identified against it. The cache is where we look to map a file +;; against a project. +;; +;; Setting up a simple in-memory cache of active projects allows the +;; user to re-load their configuration file several times without +;; messing up the active project set. +;; +(defvar ede-cpp-root-project-list nil + "List of projects created by option `ede-cpp-root-project'.") + +(defun ede-cpp-root-file-existing (dir) + "Find a cpp-root project in the list of cpp-root projects. +DIR is the directory to search from." + (let ((projs ede-cpp-root-project-list) + (ans nil)) + (while (and projs (not ans)) + (let ((root (ede-project-root-directory (car projs)))) + (when (string-match (concat "^" (regexp-quote root)) dir) + (setq ans (car projs)))) + (setq projs (cdr projs))) + ans)) + +;;; PROJECT AUTOLOAD CONFIG +;; +;; Each project type registers itself into the project-class list. +;; This way, each time a file is loaded, EDE can map that file to a +;; project. This project type checks files against the internal cache +;; of projects created by the user. +;; +;; EDE asks two kinds of questions. One is, does this DIR belong to a +;; project. If it does, it then asks, what is the ROOT directory to +;; the project in DIR. This is easy for cpp-root projects, but more +;; complex for multiply nested projects. +;; +;; If EDE finds out that a project exists for DIR, it then loads that +;; project. The LOAD routine can either create a new project object +;; (if it needs to load it off disk) or more likely can return an +;; existing object for the discovered directory. cpp-root always uses +;; the second case. + +(defun ede-cpp-root-project-file-for-dir (&optional dir) + "Return a full file name to the project file stored in DIR." + (let ((proj (ede-cpp-root-file-existing dir))) + (when proj (oref proj :file)))) + +(defvar ede-cpp-root-count 0 + "Count number of hits to the cpp root thing. +This is a debugging variable to test various optimizations in file +lookup in the main EDE logic.") + +;;;###autoload +(defun ede-cpp-root-project-root (&optional dir) + "Get the root directory for DIR." + (let ((projfile (ede-cpp-root-project-file-for-dir + (or dir default-directory)))) + (setq ede-cpp-root-count (1+ ede-cpp-root-count)) + ;(debug) + (when projfile + (file-name-directory projfile)))) + +(defun ede-cpp-root-load (dir &optional rootproj) + "Return a CPP root object if you created one. +Return nil if there isn't one. +Argument DIR is the directory it is created for. +ROOTPROJ is nil, since there is only one project." + ;; Snoop through our master list. + (ede-cpp-root-file-existing dir)) + +;;; CLASSES +;; +;; EDE sets up projects with two kinds of objects. +;; +;; The PROJECT is a class that represents everything under a directory +;; hierarchy. A TARGET represents a subset of files within a project. +;; A project can have multiple targets, and multiple sub-projects. +;; Sub projects should map to sub-directories. +;; +;; The CPP-ROOT project maps any file in C or C++ mode to a target for +;; C files. +;; +;; When creating a custom project the project developer an opportunity +;; to run code to setup various tools whenever an associated buffer is +;; loaded. The CPP-ROOT project spends most of its time setting up C +;; level include paths, and PreProcessor macro tables. + +(defclass ede-cpp-root-target (ede-target) + () + "EDE cpp-root project target. +All directories need at least one target.") + +(defclass ede-cpp-root-project (ede-project eieio-instance-tracker) + ((tracking-symbol :initform 'ede-cpp-root-project-list) + (include-path :initarg :include-path + :initform '( "/include" "../include/" ) + :type list + :documentation + "The default locate function expands filenames within a project. +If a header file (.h, .hh, etc) name is expanded, and +the :locate-fcn slot is nil, then the include path is checked +first, and other directories are ignored. For very large +projects, this optimization can save a lot of time. + +Directory names in the path can be relative to the current +buffer's `default-directory' (not starting with a /). Directories +that are relative to the project's root should start with a /, such +as \"/include\", meaning the directory `include' off the project root +directory.") + (system-include-path :initarg :system-include-path + :initform nil + :type list + :documentation + "The system include path for files in this project. +C files initialized in an ede-cpp-root-project have their semantic +system include path set to this value. If this is nil, then the +semantic path is not modified.") + (spp-table :initarg :spp-table + :initform nil + :type list + :documentation + "C Preprocessor macros for your files. +Preprocessor symbols will be used while parsing your files. +These macros might be passed in through the command line compiler, or +are critical symbols derived from header files. Providing header files +macro values through this slot improves accuracy and performance. +Use `:spp-files' to use these files directly.") + (spp-files :initarg :spp-files + :initform nil + :type list + :documentation + "C header file with Preprocessor macros for your files. +The PreProcessor symbols appearing in these files will be used while +parsing files in this project. +See `semantic-lex-c-preprocessor-symbol-map' for more on how this works.") + (header-match-regexp :initarg :header-match-regexp + :initform + "\\.\\(h\\(h\\|xx\\|pp\\|\\+\\+\\)?\\|H\\)$\\|\\<\\w+$" + :type string + :documentation + "Regexp used to identify C/C++ header files.") + (locate-fcn :initarg :locate-fcn + :initform nil + :type (or null function) + :documentation + "The locate function can be used in place of +`ede-expand-filename' so you can quickly customize your custom target +to use specialized local routines instead of the EDE routines. +The function symbol must take two arguments: + NAME - The name of the file to find. + DIR - The directory root for this cpp-root project. + +It should return the fully qualified file name passed in from NAME. If that file does not +exist, it should return nil." + ) + ) + "EDE cpp-root project class. +Each directory needs a a project file to control it.") + +;;; INIT +;; +;; Most projects use `initialize-instance' to do special setup +;; on the object when it is created. In this case, EDE-CPP-ROOT can +;; find previous copies of this project, and make sure that one of the +;; objects is deleted. + +(defmethod initialize-instance ((this ede-cpp-root-project) + &rest fields) + "Make sure the :file is fully expanded." + ;; Add ourselves to the master list + (call-next-method) + (let ((f (expand-file-name (oref this :file)))) + ;; Remove any previous entries from the main list. + (let ((old (eieio-instance-tracker-find (file-name-directory f) + :directory 'ede-cpp-root-project-list))) + ;; This is safe, because :directory isn't filled in till later. + (when (and old (not (eq old this))) + (delete-instance old))) + ;; Basic initialization. + (when (or (not (file-exists-p f)) + (file-directory-p f)) + (delete-instance this) + (error ":file for ede-cpp-root must be a file.")) + (oset this :file f) + (oset this :directory (file-name-directory f)) + (ede-project-directory-remove-hash (file-name-directory f)) + (ede-add-project-to-global-list this) + (unless (slot-boundp this 'targets) + (oset this :targets nil)) + ;; We need to add ourselves to the master list. + ;;(setq ede-projects (cons this ede-projects)) + )) + +;;; SUBPROJ Management. +;; +;; This is a way to allow a subdirectory to point back to the root +;; project, simplifying authoring new single-point projects. + +(defmethod ede-find-subproject-for-directory ((proj ede-cpp-root-project) + dir) + "Return PROJ, for handling all subdirs below DIR." + proj) + +;;; TARGET MANAGEMENT +;; +;; Creating new targets on a per directory basis is a good way to keep +;; files organized. See ede-emacs for an example with multiple file +;; types. +(defmethod ede-find-target ((proj ede-cpp-root-project) buffer) + "Find an EDE target in PROJ for BUFFER. +If one doesn't exist, create a new one for this directory." + (let* ((targets (oref proj targets)) + (dir default-directory) + (ans (object-assoc dir :path targets)) + ) + (when (not ans) + (setq ans (ede-cpp-root-target dir + :name (file-name-nondirectory + (directory-file-name dir)) + :path dir + :source nil)) + (object-add-to-list proj :targets ans) + ) + ans)) + +;;; FILE NAMES +;; +;; One of the more important jobs of EDE is to find files in a +;; directory structure. cpp-root has tricks it knows about how most C +;; projects are set up with include paths. +;; +;; This tools also uses the ede-locate setup for augmented file name +;; lookup using external tools. +(defmethod ede-expand-filename-impl ((proj ede-cpp-root-project) name) + "Within this project PROJ, find the file NAME. +This knows details about or source tree." + ;; The slow part of the original is looping over subprojects. + ;; This version has no subprojects, so this will handle some + ;; basic cases. + (let ((ans (call-next-method))) + (unless ans + (let* ((lf (oref proj locate-fcn)) + (dir (file-name-directory (oref proj file)))) + (if lf + (setq ans (funcall lf name dir)) + (if (ede-cpp-root-header-file-p proj name) + ;; Else, use our little hack. + (let ((ip (oref proj include-path)) + (tmp nil)) + (while ip + ;; Translate + (setq tmp (ede-cpp-root-translate-file proj (car ip))) + ;; Test this name. + (setq tmp (expand-file-name name tmp)) + (if (file-exists-p tmp) + (setq ans tmp)) + (setq ip (cdr ip)) )) + ;; Else, do the usual. + (setq ans (call-next-method))) + ))) + (or ans (call-next-method)))) + +(defmethod ede-project-root ((this ede-cpp-root-project)) + "Return my root." + this) + +(defmethod ede-project-root-directory ((this ede-cpp-root-project)) + "Return my root." + (file-name-directory (oref this file))) + +;;; C/CPP SPECIFIC CODE +;; +;; The following code is specific to setting up header files, +;; include lists, and Preprocessor symbol tables. + +(defmethod ede-cpp-root-header-file-p ((proj ede-cpp-root-project) name) + "Non nil if in PROJ the filename NAME is a header." + (save-match-data + (string-match (oref proj header-match-regexp) name))) + +(defmethod ede-cpp-root-translate-file ((proj ede-cpp-root-project) filename) + "For PROJ, translate a user specified FILENAME. +This is for project include paths and spp source files." + ;; Step one: Root of this project. + (let ((dir (file-name-directory (oref proj file)))) + + ;; Step two: Analyze first char, and rehost + (if (and (not (string= filename "")) (= (aref filename 0) ?/)) + ;; Check relative to root of project + (setq filename (expand-file-name (substring filename 1) + dir)) + ;; Relative to current directory. + (setq filename (expand-file-name filename))) + + filename)) + +(defmethod ede-set-project-variables ((project ede-cpp-root-project) &optional buffer) + "Set variables local to PROJECT in BUFFER. +Also set up the lexical preprocessor map." + (call-next-method) + (when (and (featurep 'semantic/c) (featurep 'semantic/lex-spp)) + (setq semantic-lex-spp-project-macro-symbol-obarray + (semantic-lex-make-spp-table (oref project spp-table))) + )) + +(defmethod ede-system-include-path ((this ede-cpp-root-project)) + "Get the system include path used by project THIS." + (oref this system-include-path)) + +(defmethod ede-preprocessor-map ((this ede-cpp-root-project)) + "Get the pre-processor map for project THIS." + (require 'semantic/db) + (let ((spp (oref this spp-table)) + (root (ede-project-root this)) + ) + (mapc + (lambda (F) + (let* ((expfile (ede-expand-filename root F)) + (table (when expfile + (semanticdb-file-table-object expfile))) + ) + (when (not table) + (message "Cannot find file %s in project." F)) + (when (and table (semanticdb-needs-refresh-p table)) + (semanticdb-refresh-table table)) + (setq spp (append spp (oref table lexical-table))))) + (oref this spp-files)) + spp)) + +(defmethod ede-system-include-path ((this ede-cpp-root-target)) + "Get the system include path used by project THIS." + (ede-system-include-path (ede-target-parent this))) + +(defmethod ede-preprocessor-map ((this ede-cpp-root-target)) + "Get the pre-processor map for project THIS." + (ede-preprocessor-map (ede-target-parent this))) + +(provide 'ede/cpp-root) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: ede/loaddefs +;; generated-autoload-load-name: "ede/cpp-root" +;; End: + +;;; ede/cpp-root.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/dired.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/dired.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,109 @@ +;;; ede/dired.el --- EDE extensions to dired. + +;;; Copyright (C) 1998, 1999, 2000, 2003 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Version: 0.4 +;; 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 . + +;;; Commentary: +;; +;; This provides a dired interface to EDE, allowing users to modify +;; their project file by adding files (or whatever) directly from a +;; dired buffer. + +(require 'easymenu) +(require 'dired) +(require 'ede) + +;;; Code: +(defvar ede-dired-minor-mode nil + "Non-nil when in ede dired minor mode.") +(make-variable-buffer-local 'ede-dired-minor-mode) + +(defvar ede-dired-keymap nil + "Keymap used for ede dired minor mode.") + +(if ede-dired-keymap + nil + (setq ede-dired-keymap (make-sparse-keymap)) + (define-key ede-dired-keymap ".a" 'ede-dired-add-to-target) + (define-key ede-dired-keymap ".t" 'ede-new-target) + (define-key ede-dired-keymap ".s" 'ede-speedbar) + (define-key ede-dired-keymap ".C" 'ede-compile-project) + (define-key ede-dired-keymap ".d" 'ede-make-dist) + + (easy-menu-define + ede-dired-menu ede-dired-keymap "EDE Dired Minor Mode Menu" + '("Project" + [ "Add files to target" ede-dired-add-to-target (ede-current-project) ] + ( "Build" :filter ede-build-forms-menu) + "-" + [ "Create Project" ede-new (not (ede-current-project)) ] + [ "Create Target" ede-new-target (ede-current-project) ] + "-" + ( "Customize Project" :filter ede-customize-forms-menu ) + [ "View Project Tree" ede-speedbar (ede-current-project) ] + )) + ) + +(defun ede-dired-minor-mode (&optional arg) + "A minor mode that should only be activated in DIRED buffers. +If ARG is nil, toggle, if it is a positive number, force on, if +negative, force off." + (interactive "P") + (if (not (or (eq major-mode 'dired-mode) + (eq major-mode 'vc-dired-mode))) + (error "Not in DIRED mode")) + (setq ede-dired-minor-mode + (not (or (and (null arg) ede-dired-minor-mode) + (<= (prefix-numeric-value arg) 0)))) + (if (and (not (ede-directory-project-p default-directory)) + (not (interactive-p))) + (setq ede-dired-minor-mode nil)) + ) + +(defun ede-dired-add-to-target (target) + "Add a file, or all marked files into a TARGET." + (interactive (list + (let ((ede-object (ede-current-project))) + (ede-invoke-method 'project-interactive-select-target + "Add files to Target: ")))) + (let ((files (dired-get-marked-files t))) + (while files + (project-add-file target (car files)) + ;; Find the buffer for this files, and set it's ede-object + (if (get-file-buffer (car files)) + (save-excursion + (set-buffer (get-file-buffer (car files))) + (setq ede-object nil) + (setq ede-object (ede-buffer-object (current-buffer))))) + ;; Increment. + (setq files (cdr files))))) + +;; Minor mode management. +(add-to-list 'minor-mode-alist '(ede-dired-minor-mode " EDE")) +(let ((a (assoc 'ede-dired-minor-mode minor-mode-map-alist))) + (if a + (setcdr a ede-dired-keymap) + (add-to-list 'minor-mode-map-alist (cons 'ede-dired-minor-mode + ede-dired-keymap)))) + +(provide 'ede/dired) + +;;; ede/dired.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/emacs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/emacs.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,257 @@ +;;; ede/emacs.el --- Special project for Emacs + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Provide a special project type just for Emacs, cause Emacs is special. +;; +;; Identifies an Emacs project automatically. +;; Speedy ede-expand-filename based on extension. +;; Pre-populates the preprocessor map from lisp.h +;; +;; ToDo : +;; * Add "build" options. +;; * Add texinfo lookup options. +;; * Add website + +(require 'ede) +(declare-function semanticdb-file-table-object "semantic/db") +(declare-function semanticdb-needs-refresh-p "semantic/db") +(declare-function semanticdb-refresh-table "semantic/db") + +;;; Code: +(defvar ede-emacs-project-list nil + "List of projects created by option `ede-emacs-project'.") + +(defun ede-emacs-file-existing (dir) + "Find a Emacs project in the list of Emacs projects. +DIR is the directory to search from." + (let ((projs ede-emacs-project-list) + (ans nil)) + (while (and projs (not ans)) + (let ((root (ede-project-root-directory (car projs)))) + (when (string-match (concat "^" (regexp-quote root)) dir) + (setq ans (car projs)))) + (setq projs (cdr projs))) + ans)) + +;;;###autoload +(defun ede-emacs-project-root (&optional dir) + "Get the root directory for DIR." + (when (not dir) (setq dir default-directory)) + (let ((case-fold-search t) + (proj (ede-emacs-file-existing dir))) + (if proj + (ede-up-directory (file-name-directory + (oref proj :file))) + ;; No pre-existing project. Lets take a wild-guess if we have + ;; an Emacs project here. + (when (string-match "emacs[^/]*" dir) + (let ((base (substring dir 0 (match-end 0)))) + (when (file-exists-p (expand-file-name "src/emacs.c" base)) + base)))))) + +(defun ede-emacs-version (dir) + "Find the Emacs version for the Emacs src in DIR." + (let ((buff (get-buffer-create " *emacs-query*"))) + (save-excursion + (set-buffer buff) + (erase-buffer) + (setq default-directory (file-name-as-directory dir)) + (call-process "egrep" nil buff nil "-n" "-e" "^version=" "Makefile") + (goto-char (point-min)) + (re-search-forward "version=\\([0-9.]+\\)") + (prog1 + (match-string 1) + (kill-buffer buff) + )))) + +(defclass ede-emacs-project (ede-project eieio-instance-tracker) + ((tracking-symbol :initform 'ede-emacs-project-list) + ) + "Project Type for the Emacs source code." + :method-invocation-order :depth-first) + +(defun ede-emacs-load (dir &optional rootproj) + "Return an Emacs Project object if there is a match. +Return nil if there isn't one. +Argument DIR is the directory it is created for. +ROOTPROJ is nil, since there is only one project." + (or (ede-emacs-file-existing dir) + ;; Doesn't already exist, so lets make one. + (ede-emacs-project "Emacs" + :name (concat "Emacs" (ede-emacs-version dir)) + :directory dir + :file (expand-file-name "src/emacs.c" + dir)) + (ede-add-project-to-global-list this) + ) + ) + +(defclass ede-emacs-target-c (ede-target) + () + "EDE Emacs Project target for C code. +All directories need at least one target.") + +(defclass ede-emacs-target-el (ede-target) + () + "EDE Emacs Project target for Emacs Lisp code. +All directories need at least one target.") + +(defclass ede-emacs-target-misc (ede-target) + () + "EDE Emacs Project target for Misc files. +All directories need at least one target.") + +(defmethod initialize-instance ((this ede-emacs-project) + &rest fields) + "Make sure the :file is fully expanded." + (call-next-method) + (unless (slot-boundp this 'targets) + (oset this :targets nil))) + +;;; File Stuff +;; +(defmethod ede-project-root-directory ((this ede-emacs-project) + &optional file) + "Return the root for THIS Emacs project with file." + (ede-up-directory (file-name-directory (oref this file)))) + +(defmethod ede-project-root ((this ede-emacs-project)) + "Return my root." + this) + +(defmethod ede-find-subproject-for-directory ((proj ede-emacs-project) + dir) + "Return PROJ, for handling all subdirs below DIR." + proj) + +;;; TARGET MANAGEMENT +;; +(defun ede-emacs-find-matching-target (class dir targets) + "Find a target that is a CLASS and is in DIR in the list of TARGETS." + (let ((match nil)) + (dolist (T targets) + (when (and (object-of-class-p T class) + (string= (oref T :path) dir)) + (setq match T) + )) + match)) + +(defmethod ede-find-target ((proj ede-emacs-project) buffer) + "Find an EDE target in PROJ for BUFFER. +If one doesn't exist, create a new one for this directory." + (let* ((ext (file-name-extension (buffer-file-name buffer))) + (cls (cond ((not ext) + 'ede-emacs-target-misc) + ((string-match "c\\|h" ext) + 'ede-emacs-target-c) + ((string-match "elc?" ext) + 'ede-emacs-target-el) + (t 'ede-emacs-target-misc))) + (targets (oref proj targets)) + (dir default-directory) + (ans (ede-emacs-find-matching-target cls dir targets)) + ) + (when (not ans) + (setq ans (make-instance + cls + :name (file-name-nondirectory + (directory-file-name dir)) + :path dir + :source nil)) + (object-add-to-list proj :targets ans) + ) + ans)) + +;;; UTILITIES SUPPORT. +;; +(defmethod ede-preprocessor-map ((this ede-emacs-target-c)) + "Get the pre-processor map for Emacs C code. +All files need the macros from lisp.h!" + (require 'semantic/db) + (let* ((proj (ede-target-parent this)) + (root (ede-project-root proj)) + (table (semanticdb-file-table-object + (ede-expand-filename root "lisp.h"))) + filemap + ) + (when table + (when (semanticdb-needs-refresh-p table) + (semanticdb-refresh-table table)) + (setq filemap (append filemap (oref table lexical-table))) + ) + filemap + )) + +(defun ede-emacs-find-in-directories (name base dirs) + "Find NAME is BASE directory sublist of DIRS." + (let ((ans nil)) + (while (and dirs (not ans)) + (let* ((D (car dirs)) + (ed (expand-file-name D base)) + (ef (expand-file-name name ed))) + (if (file-exists-p ef) + (setq ans ef) + ;; Not in this dir? How about subdirs? + (let ((dirfile (directory-files ed t)) + (moredirs nil) + ) + ;; Get all the subdirs. + (dolist (DF dirfile) + (when (and (file-directory-p DF) + (not (string-match "\\.$" DF))) + (push DF moredirs))) + ;; Try again. + (setq ans (ede-emacs-find-in-directories name ed moredirs)) + )) + (setq dirs (cdr dirs)))) + ans)) + +(defmethod ede-expand-filename-impl ((proj ede-emacs-project) name) + "Within this project PROJ, find the file NAME. +Knows about how the Emacs source tree is organized." + (let* ((ext (file-name-extension name)) + (root (ede-project-root proj)) + (dir (ede-project-root-directory root)) + (dirs (cond + ((not ext) nil) + ((string-match "h\\|c" ext) + '("src" "lib-src" "lwlib")) + ((string-match "elc?" ext) + '("lisp")) + ((string-match "texi" ext) + '("doc")) + (t nil))) + ) + (if (not dirs) (call-next-method) + (ede-emacs-find-in-directories name dir dirs)) + )) + +(provide 'ede/emacs) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: ede/loaddefs +;; generated-autoload-load-name: "ede/emacs" +;; End: + +;;; ede/emacs.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/files.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/files.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,516 @@ +;;; ede/files.el --- Associate projects with files and directories. + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Directory and File scanning and matching functions. +;; +;; Basic Model: +;; +;; A directory belongs to a project if a ede-project-autoload structure +;; matches your directory. +;; +;; A toplevel project is one where there is no active project above +;; it. Finding the toplevel project involves going up a directory +;; till no ede-project-autoload structure matches. +;; + +(require 'ede) + +(declare-function ede-locate-file-in-hash "ede/locate") +(declare-function ede-locate-add-file-to-hash "ede/locate") +(declare-function ede-locate-file-in-project "ede/locate") + +(defvar ede--disable-inode nil + "Set to 't' to simulate systems w/out inode support.") + +;;; Code: +;;;###autoload +(defun ede-find-file (file) + "Find FILE in project. FILE can be specified without a directory. +There is no completion at the prompt. FILE is searched for within +the current EDE project." + (interactive "sFile: ") + (let ((fname (ede-expand-filename (ede-current-project) file)) + ) + (unless fname + (error "Could not find %s in %s" + file + (ede-project-root-directory (ede-current-project)))) + (find-file fname))) + +;;; Placeholders for ROOT directory scanning on base objects +;; +(defmethod ede-project-root ((this ede-project-placeholder)) + "If a project knows it's root, return it here. +Allows for one-project-object-for-a-tree type systems." + (oref this rootproject)) + +(defmethod ede-project-root-directory ((this ede-project-placeholder) + &optional file) + "If a project knows it's root, return it here. +Allows for one-project-object-for-a-tree type systems. +Optional FILE is the file to test. It is ignored in preference +of the anchor file for the project." + (file-name-directory (expand-file-name (oref this file)))) + + +(defmethod ede-project-root ((this ede-project-autoload)) + "If a project knows it's root, return it here. +Allows for one-project-object-for-a-tree type systems." + nil) + +(defmethod ede-project-root-directory ((this ede-project-autoload) + &optional file) + "If a project knows it's root, return it here. +Allows for one-project-object-for-a-tree type systems. +Optional FILE is the file to test. If there is no FILE, use +the current buffer." + (when (not file) + (setq file default-directory)) + (when (slot-boundp this :proj-root) + (let ((rootfcn (oref this proj-root))) + (when rootfcn + (condition-case nil + (funcall rootfcn file) + (error + (funcall rootfcn))) + )))) + +(defmethod ede--project-inode ((proj ede-project-placeholder)) + "Get the inode of the directory project PROJ is in." + (if (slot-boundp proj 'dirinode) + (oref proj dirinode) + (oset proj dirinode (ede--inode-for-dir (oref proj :directory))))) + +(defmethod ede-find-subproject-for-directory ((proj ede-project-placeholder) + dir) + "Find a subproject of PROJ that corresponds to DIR." + (if ede--disable-inode + (let ((ans nil)) + ;; Try to find the right project w/out inodes. + (ede-map-subprojects + proj + (lambda (SP) + (when (not ans) + (if (string= (file-truename dir) (oref SP :directory)) + (setq ans SP) + (ede-find-subproject-for-directory SP dir))))) + ans) + ;; We can use inodes, so lets try it. + (let ((ans nil) + (inode (ede--inode-for-dir dir))) + (ede-map-subprojects + proj + (lambda (SP) + (when (not ans) + (if (equal (ede--project-inode SP) inode) + (setq ans SP) + (ede-find-subproject-for-directory SP dir))))) + ans))) + +;;; DIRECTORY IN OPEN PROJECT +;; +;; These routines match some directory name to one of the many pre-existing +;; open projects. This should avoid hitting the disk, or asking lots of questions +;; if used throughout the other routines. +(defvar ede-inode-directory-hash (make-hash-table + ;; Note on test. Can we compare inodes or something? + :test 'equal) + "A hash of directory names and inodes.") + +(defun ede--put-inode-dir-hash (dir inode) + "Add to the EDE project hash DIR associated with INODE." + (when (fboundp 'puthash) + (puthash dir inode ede-inode-directory-hash) + inode)) + +(defun ede--get-inode-dir-hash (dir) + "Get the EDE project hash DIR associated with INODE." + (when (fboundp 'gethash) + (gethash dir ede-inode-directory-hash) + )) + +(defun ede--inode-for-dir (dir) + "Return the inode for the directory DIR." + (let ((hashnode (ede--get-inode-dir-hash (expand-file-name dir)))) + (or hashnode + (if ede--disable-inode + (ede--put-inode-dir-hash dir 0) + (let ((fattr (file-attributes dir))) + (ede--put-inode-dir-hash dir (nth 10 fattr)) + ))))) + +(defun ede-directory-get-open-project (dir &optional rootreturn) + "Return an already open project that is managing DIR. +Optional ROOTRETURN specifies a symbol to set to the root project. +If DIR is the root project, then it is the same." + (let* ((inode (ede--inode-for-dir dir)) + (ft (file-name-as-directory (expand-file-name dir))) + (proj (ede--inode-get-toplevel-open-project inode)) + (ans nil)) + ;; Try file based search. + (when (not proj) + (setq proj (ede-directory-get-toplevel-open-project ft))) + ;; Default answer is this project + (setq ans proj) + ;; Save. + (when rootreturn (set rootreturn proj)) + ;; Find subprojects. + (when (and proj (or ede--disable-inode + (not (equal inode (ede--project-inode proj))))) + (setq ans (ede-find-subproject-for-directory proj ft))) + ans)) + +(defun ede--inode-get-toplevel-open-project (inode) + "Return an already open toplevel project that is managing INODE. +Does not check subprojects." + (when (or (and (numberp inode) (/= inode 0)) + (consp inode)) + (let ((all ede-projects) + (found nil) + ) + (while (and all (not found)) + (when (equal inode (ede--project-inode (car all))) + (setq found (car all))) + (setq all (cdr all))) + found))) + +(defun ede-directory-get-toplevel-open-project (dir) + "Return an already open toplevel project that is managing DIR." + (let ((ft (file-name-as-directory (expand-file-name dir))) + (all ede-projects) + (ans nil)) + (while (and all (not ans)) + ;; Do the check. + (let ((pd (oref (car all) :directory)) + ) + (cond + ;; Exact text match. + ((string= pd ft) + (setq ans (car all))) + ;; Some sub-directory + ((string-match (concat "^" (regexp-quote pd)) ft) + (setq ans (car all))) + ;; Exact inode match. Useful with symlinks or complex automounters. + ((let ((pin (ede--project-inode (car all))) + (inode (ede--inode-for-dir dir))) + (and (not (eql pin 0)) (equal pin inode))) + (setq ans (car all))) + ;; Subdir via truename - slower by far, but faster than a traditional lookup. + ((let ((ftn (file-truename ft)) + (ptd (file-truename (oref (car all) :directory)))) + (string-match (concat "^" (regexp-quote ptd)) ftn)) + (setq ans (car all))) + )) + (setq all (cdr all))) + ans)) + +;;; DIRECTORY-PROJECT-P +;; +;; For a fresh buffer, or for a path w/ no open buffer, use this +;; routine to determine if there is a known project type here. +(defvar ede-project-directory-hash (make-hash-table + ;; Note on test. Can we compare inodes or something? + :test 'equal) + "A hash of directory names and associated EDE objects.") + +(defun ede-project-directory-remove-hash (dir) + "Reset the directory hash for DIR. +Do this whenever a new project is created, as opposed to loaded." + ;; TODO - Use maphash, and delete by regexp, not by dir searching! + + (when (fboundp 'remhash) + (remhash (file-name-as-directory dir) ede-project-directory-hash) + ;; Look for all subdirs of D, and remove them. + (let ((match (concat "^" (regexp-quote dir)))) + (maphash (lambda (K O) + (when (string-match match K) + (remhash K ede-project-directory-hash))) + ede-project-directory-hash)) + )) + +(defun ede-directory-project-from-hash (dir) + "If there is an already loaded project for DIR, return it from the hash." + (when (fboundp 'gethash) + (gethash dir ede-project-directory-hash nil))) + +(defun ede-directory-project-add-description-to-hash (dir desc) + "Add to the EDE project hash DIR associated with DESC." + (when (fboundp 'puthash) + (puthash dir desc ede-project-directory-hash) + desc)) + +(defun ede-directory-project-p (dir &optional force) + "Return a project description object if DIR has a project. +Optional argument FORCE means to ignore a hash-hit of 'nomatch. +This depends on an up to date `ede-project-class-files' variable." + (let* ((dirtest (expand-file-name dir)) + (match (ede-directory-project-from-hash dirtest))) + (cond + ((and (eq match 'nomatch) (not force)) + nil) + ((and match (not (eq match 'nomatch))) + match) + (t + (let ((types ede-project-class-files) + (ret nil)) + ;; Loop over all types, loading in the first type that we find. + (while (and types (not ret)) + (if (ede-dir-to-projectfile (car types) dirtest) + (progn + ;; We found one! Require it now since we will need it. + (require (oref (car types) file)) + (setq ret (car types)))) + (setq types (cdr types))) + (ede-directory-project-add-description-to-hash dirtest (or ret 'nomatch)) + ret))))) + +;;; TOPLEVEL +;; +;; These utilities will identify the "toplevel" of a project. +;; +(defun ede-toplevel-project-or-nil (dir) + "Starting with DIR, find the toplevel project directory, or return nil. +nil is returned if the current directory is not a part ofa project." + (let* ((ans (ede-directory-get-toplevel-open-project dir))) + (if ans + (oref ans :directory) + (if (ede-directory-project-p dir) + (ede-toplevel-project dir) + nil)))) + +(defun ede-toplevel-project (dir) + "Starting with DIR, find the toplevel project directory." + (if (and (string= dir default-directory) + ede-object-root-project) + ;; Try the local buffer cache first. + (oref ede-object-root-project :directory) + ;; Otherwise do it the hard way. + (let* ((thisdir (ede-directory-project-p dir)) + (ans (ede-directory-get-toplevel-open-project dir))) + (if (and ans ;; We have an answer + (or (not thisdir) ;; this dir isn't setup + (and (object-of-class-p ;; Same as class for this dir? + ans (oref thisdir :class-sym))) + )) + (oref ans :directory) + (let* ((toppath (expand-file-name dir)) + (newpath toppath) + (proj (ede-directory-project-p dir)) + (ans nil)) + (if proj + ;; If we already have a project, ask it what the root is. + (setq ans (ede-project-root-directory proj))) + + ;; If PROJ didn't know, or there is no PROJ, then + + ;; Loop up to the topmost project, and then load that single + ;; project, and it's sub projects. When we are done, identify the + ;; sub-project object belonging to file. + (while (and (not ans) newpath proj) + (setq toppath newpath + newpath (ede-up-directory toppath)) + (when newpath + (setq proj (ede-directory-project-p newpath))) + + (when proj + ;; We can home someone in the middle knows too. + (setq ans (ede-project-root-directory proj))) + ) + (or ans toppath)))))) + +;;; TOPLEVEL PROJECT +;; +;; The toplevel project is a way to identify the EDE structure that belongs +;; to the top of a project. + +(defun ede-toplevel (&optional subproj) + "Return the ede project which is the root of the current project. +Optional argument SUBPROJ indicates a subproject to start from +instead of the current project." + (or ede-object-root-project + (let* ((cp (or subproj (ede-current-project))) + ) + (or (and cp (ede-project-root cp)) + (progn + (while (ede-parent-project cp) + (setq cp (ede-parent-project cp))) + cp))))) + +;;; DIRECTORY CONVERSION STUFF +;; +(defmethod ede-convert-path ((this ede-project) path) + "Convert path in a standard way for a given project. +Default to making it project relative. +Argument THIS is the project to convert PATH to." + (let ((pp (ede-project-root-directory this)) + (fp (expand-file-name path))) + (if (string-match (regexp-quote pp) fp) + (substring fp (match-end 0)) + (let ((pptf (file-truename pp)) + (fptf (file-truename fp))) + (if (string-match (regexp-quote pptf) fptf) + (substring fptf (match-end 0)) + (error "Cannot convert relativize path %s" fp)))))) + +(defmethod ede-convert-path ((this ede-target) path) + "Convert path in a standard way for a given project. +Default to making it project relative. +Argument THIS is the project to convert PATH to." + (let ((proj (ede-target-parent this))) + (if proj + (let ((p (ede-convert-path proj path)) + (lp (or (oref this path) ""))) + ;; Our target THIS may have path information. + ;; strip this out of the conversion. + (if (string-match (concat "^" (regexp-quote lp)) p) + (substring p (length lp)) + p)) + (error "Parentless target %s" this)))) + +;;; FILENAME EXPANSION +;; +(defun ede-get-locator-object (proj) + "Get the locator object for project PROJ. +Get it from the toplevel project. If it doesn't have one, make one." + ;; Make sure we have a location object available for + ;; caching values, and for locating things more robustly. + (let ((top (ede-toplevel proj))) + (when (not (slot-boundp top 'locate-obj)) + (ede-enable-locate-on-project this)) + (oref top locate-obj) + )) + +(defmethod ede-expand-filename ((this ede-project) filename &optional force) + "Return a fully qualified file name based on project THIS. +FILENAME should be just a filename which occurs in a directory controlled +by this project. +Optional argument FORCE forces the default filename to be provided even if it +doesn't exist. +If FORCE equals 'newfile, then the cache is ignored." + (require 'ede/locate) + (let* ((loc (ede-get-locator-object this)) + (ha (ede-locate-file-in-hash loc filename)) + (ans nil) + ) + ;; NOTE: This function uses a locator object, which keeps a hash + ;; table of files it has found in the past. The hash table is + ;; used to make commonly found file very fast to location. Some + ;; complex routines, such as smart completion asks this question + ;; many times, so doing this speeds things up, especially on NFS + ;; or other remote file systems. + + ;; As such, special care is needed to use the hash, and also obey + ;; the FORCE option, which is needed when trying to identify some + ;; new file that needs to be created, such as a Makefile. + (cond + ;; We have a hash-table match, AND that match wasn't the 'nomatch + ;; flag, we can return it. + ((and ha (not (eq ha 'nomatch))) + (setq ans ha)) + ;; If we had a match, and it WAS no match, then we need to look + ;; at the force-option to see what to do. Since ans is already + ;; nil, then we do nothing. + ((and (eq ha 'nomatch) (not (eq force 'newfile))) + nil) + ;; We had no hash table match, so we have to look up this file + ;; using the usual EDE file expansion rules. + (t + (let ((calc (ede-expand-filename-impl this filename))) + (if calc + (progn + (ede-locate-add-file-to-hash loc filename calc) + (setq ans calc)) + ;; If we failed to calculate something, we + ;; should add it to the hash, but ONLY if we are not + ;; going to FORCE the file into existance. + (when (not force) + (ede-locate-add-file-to-hash loc filename 'nomatch)))) + )) + ;; Now that all options have been queried, if the FORCE option is + ;; true, but ANS is still nil, then we can make up a file name. + + ;; Is it forced? + (when (and force (not ans)) + (let ((dir (ede-project-root-directory this))) + (setq ans (expand-file-name filename dir)))) + + ans)) + +(defmethod ede-expand-filename-impl ((this ede-project) filename &optional force) + "Return a fully qualified file name based on project THIS. +FILENAME should be just a filename which occurs in a directory controlled +by this project. +Optional argument FORCE forces the default filename to be provided even if it +doesn't exist." + (let ((loc (ede-get-locator-object this)) + (path (ede-project-root-directory this)) + (proj (oref this subproj)) + (found nil)) + ;; find it Locally. + (setq found + (cond ((file-exists-p (expand-file-name filename path)) + (expand-file-name filename path)) + ((file-exists-p (expand-file-name (concat "include/" filename) path)) + (expand-file-name (concat "include/" filename) path)) + (t + (while (and (not found) proj) + (setq found (when (car proj) + (ede-expand-filename (car proj) filename)) + proj (cdr proj))) + found))) + ;; Use an external locate tool. + (when (not found) + (require 'ede/locate) + (setq found (car (ede-locate-file-in-project loc filename)))) + ;; Return it + found)) + +(defmethod ede-expand-filename ((this ede-target) filename &optional force) + "Return a fully qualified file name based on target THIS. +FILENAME should a a filename which occurs in a directory in which THIS works. +Optional argument FORCE forces the default filename to be provided even if it +doesn't exist." + (ede-expand-filename (ede-target-parent this) filename force)) + +;;; UTILITIES +;; + +(defun ede-up-directory (dir) + "Return a dir that is up one directory. +Argument DIR is the directory to trim upwards." + (let* ((fad (directory-file-name dir)) + (fnd (file-name-directory fad))) + (if (string= dir fnd) ; This will catch the old string-match against + ; c:/ for DOS like systems. + nil + fnd))) + +(provide 'ede/files) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: ede/loaddefs +;; generated-autoload-load-name: "ede/files" +;; End: + +;;; ede/files.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/linux.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/linux.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,237 @@ +;;; ede/linux.el --- Special project for Linux + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Provide a special project type just for Linux, cause Linux is special. +;; +;; Identifies a Linux project automatically. +;; Speedy ede-expand-filename based on extension. +;; Pre-populates the preprocessor map from lisp.h +;; +;; ToDo : +;; * Add "build" options. +;; * Add texinfo lookup options. +;; * Add website + +(require 'ede) +(declare-function semanticdb-file-table-object "semantic/db") +(declare-function semanticdb-needs-refresh-p "semantic/db") +(declare-function semanticdb-refresh-table "semantic/db") + +;;; Code: +(defvar ede-linux-project-list nil + "List of projects created by option `ede-linux-project'.") + +(defun ede-linux-file-existing (dir) + "Find a Linux project in the list of Linux projects. +DIR is the directory to search from." + (let ((projs ede-linux-project-list) + (ans nil)) + (while (and projs (not ans)) + (let ((root (ede-project-root-directory (car projs)))) + (when (string-match (concat "^" (regexp-quote root)) dir) + (setq ans (car projs)))) + (setq projs (cdr projs))) + ans)) + +;;;###autoload +(defun ede-linux-project-root (&optional dir) + "Get the root directory for DIR." + (when (not dir) (setq dir default-directory)) + (let ((case-fold-search t) + (proj (ede-linux-file-existing dir))) + (if proj + (ede-up-directory (file-name-directory + (oref proj :file))) + ;; No pre-existing project. Lets take a wild-guess if we have + ;; an Linux project here. + (when (string-match "linux[^/]*" dir) + (let ((base (substring dir 0 (match-end 0)))) + (when (file-exists-p (expand-file-name "scripts/ver_linux" base)) + base)))))) + +(defun ede-linux-version (dir) + "Find the Linux version for the Linux src in DIR." + (let ((buff (get-buffer-create " *linux-query*"))) + (save-excursion + (set-buffer buff) + (erase-buffer) + (setq default-directory (file-name-as-directory dir)) + (call-process "head" nil buff nil "-n" "3" "Makefile") + (goto-char (point-min)) + (let (major minor sub) + (re-search-forward "^VERSION *= *\\([0-9.]+\\)") + (setq major (match-string 1)) + (re-search-forward "^PATCHLEVEL *= *\\([0-9.]+\\)") + (setq minor (match-string 1)) + (re-search-forward "^SUBLEVEL *= *\\([0-9.]+\\)") + (setq sub (match-string 1)) + (prog1 + (concat major "." minor "." sub) + (kill-buffer buff) + ))))) + +(defclass ede-linux-project (ede-project eieio-instance-tracker) + ((tracking-symbol :initform 'ede-linux-project-list) + ) + "Project Type for the Linux source code." + :method-invocation-order :depth-first) + +(defun ede-linux-load (dir &optional rootproj) + "Return an Linux Project object if there is a match. +Return nil if there isn't one. +Argument DIR is the directory it is created for. +ROOTPROJ is nil, since there is only one project." + (or (ede-linux-file-existing dir) + ;; Doesn't already exist, so lets make one. + (ede-linux-project "Linux" + :name (concat "Linux" (ede-linux-version dir)) + :directory dir + :file (expand-file-name "scripts/ver_linux" + dir)) + (ede-add-project-to-global-list this) + ) + ) + +(defclass ede-linux-target-c (ede-target) + () + "EDE Linux Project target for C code. +All directories need at least one target.") + +(defclass ede-linux-target-misc (ede-target) + () + "EDE Linux Project target for Misc files. +All directories need at least one target.") + +(defmethod initialize-instance ((this ede-linux-project) + &rest fields) + "Make sure the :file is fully expanded." + (call-next-method) + (unless (slot-boundp this 'targets) + (oset this :targets nil))) + +;;; File Stuff +;; +(defmethod ede-project-root-directory ((this ede-linux-project) + &optional file) + "Return the root for THIS Linux project with file." + (ede-up-directory (file-name-directory (oref this file)))) + +(defmethod ede-project-root ((this ede-linux-project)) + "Return my root." + this) + +(defmethod ede-find-subproject-for-directory ((proj ede-linux-project) + dir) + "Return PROJ, for handling all subdirs below DIR." + proj) + +;;; TARGET MANAGEMENT +;; +(defun ede-linux-find-matching-target (class dir targets) + "Find a target that is a CLASS and is in DIR in the list of TARGETS." + (let ((match nil)) + (dolist (T targets) + (when (and (object-of-class-p T class) + (string= (oref T :path) dir)) + (setq match T) + )) + match)) + +(defmethod ede-find-target ((proj ede-linux-project) buffer) + "Find an EDE target in PROJ for BUFFER. +If one doesn't exist, create a new one for this directory." + (let* ((ext (file-name-extension (buffer-file-name buffer))) + (cls (cond ((not ext) + 'ede-linux-target-misc) + ((string-match "c\\|h" ext) + 'ede-linux-target-c) + (t 'ede-linux-target-misc))) + (targets (oref proj targets)) + (dir default-directory) + (ans (ede-linux-find-matching-target cls dir targets)) + ) + (when (not ans) + (setq ans (make-instance + cls + :name (file-name-nondirectory + (directory-file-name dir)) + :path dir + :source nil)) + (object-add-to-list proj :targets ans) + ) + ans)) + +;;; UTILITIES SUPPORT. +;; +(defmethod ede-preprocessor-map ((this ede-linux-target-c)) + "Get the pre-processor map for Linux C code. +All files need the macros from lisp.h!" + (require 'semantic/db) + (let* ((proj (ede-target-parent this)) + (root (ede-project-root proj)) + (versionfile (ede-expand-filename root "include/linux/version.h")) + (table (when (and versionfile (file-exists-p versionfile)) + (semanticdb-file-table-object versionfile))) + (filemap '( ("__KERNEL__" . "") + )) + ) + (when table + (when (semanticdb-needs-refresh-p table) + (semanticdb-refresh-table table)) + (setq filemap (append filemap (oref table lexical-table))) + ) + filemap + )) + +(defun ede-linux-file-exists-name (name root subdir) + "Return a file name if NAME exists under ROOT with SUBDIR in between." + (let ((F (expand-file-name name (expand-file-name subdir root)))) + (when (file-exists-p F) F))) + +(defmethod ede-expand-filename-impl ((proj ede-linux-project) name) + "Within this project PROJ, find the file NAME. +Knows about how the Linux source tree is organized." + (let* ((ext (file-name-extension name)) + (root (ede-project-root proj)) + (dir (ede-project-root-directory root)) + (F (cond + ((not ext) nil) + ((string-match "h" ext) + (or (ede-linux-file-exists-name name dir "") + (ede-linux-file-exists-name name dir "include")) + ) + ((string-match "txt" ext) + (ede-linux-file-exists-name name dir "Documentation")) + (t nil))) + ) + (or F (call-next-method)))) + +(provide 'ede/linux) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: ede/loaddefs +;; generated-autoload-load-name: "ede/linux" +;; End: + +;;; ede/linux.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/locate.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/locate.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,328 @@ +;;; ede/locate.el --- Locate support + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Support for various LOCATE type functions. +;; +;; A key feature of EDE is `ede-expand-filename', which allows a +;; project to expand a filename reference in one file to some actual +;; filename. +;; +;; In that way, you may #include , and without knowing how to +;; read a Makefile, find it in /include/foo.h. +;; +;; Some projects are regular, such as the Emacs project. Some +;; projects are completely controlled by EDE, such sh the Project.ede +;; based projects. +;; +;; For other projects, haveing a "quick hack" to support these location +;; routines is handy. +;; +;; The baseclass `ede-locate-base' provides the abstract interface to +;; finding files in a project. +;; +;; New location routines will subclass `ede-locate-base'. +;; +;; How to use: +;; +;; Configure `ede-locate-setup-options' to add the types of locate +;; features you have available. EDE will then enable the correct one +;; when it is available. + +(require 'ede) +(eval-when-compile (require 'data-debug) + (require 'eieio-datadebug) + (require 'cedet-global) + (require 'cedet-idutils) + (require 'cedet-cscope)) + +(require 'locate) + +;;; Code: +(defcustom ede-locate-setup-options + '(ede-locate-base) + "List of locate objects to try out by default. +Listed in order of preference. If the first item cannot be used in +a particular project, then the next one is tried. +It is always assumed that `ede-locate-base' is at end of the list." + :group 'ede + :type '(repeat + (choice (const :tag "None" ede-locate-base) + (const :tag "locate" ede-locate-locate) + (const :tag "GNU Global" ede-locate-global) + (const :tag "ID Utils" ede-locate-idutils) + (const :tag "CScope" ede-locate-cscope))) + ) + +;;;###autoload +(defun ede-enable-locate-on-project (&optional project) + "Enable an EDE locate feature on PROJECT. +Attempt to guess which project locate style to use +based on `ede-locate-setup-options'." + (interactive) + (let* ((proj (or project (ede-toplevel))) + (root (ede-project-root-directory proj)) + (opts ede-locate-setup-options) + (ans nil)) + (while (and opts (not ans)) + (when (ede-locate-ok-in-project (car opts) root) + ;; If interactive, check with the user. + (when (or (not (interactive-p)) + (y-or-n-p (format "Set project locator to %s? " (car opts)))) + (setq ans (car opts)))) + (setq opts (cdr opts))) + ;; No match? Always create the baseclass for the hashing tool. + (when (not ans) + (when (interactive-p) + (message "Setting locator to ede-locate-base")) + (setq ans 'ede-locate-base)) + (oset proj locate-obj (make-instance ans "Loc" :root root)) + (when (interactive-p) + (message "Satting locator to %s." ans)) + )) + +;;; LOCATE BASECLASS +;; +;; The baseclass for all location style queries. +(defclass ede-locate-base () + ((root :initarg :root + :documentation + "The root of these locat searches.") + (file :documentation + "The last file search for with EDE locate.") + (lastanswer :documentation + "The last answer provided by the locator.") + (hash :documentation + "Hash table of previously found files.") + ) + "Baseclass for LOCATE feature in EDE.") + +(defmethod initialize-instance ((loc ede-locate-base) &rest fields) + "Make sure we have a hash table." + ;; Basic setup. + (call-next-method) + ;; Make sure we have a hash table. + (oset loc hash (make-hash-table :test 'equal)) + ) + +(defmethod ede-locate-ok-in-project :static ((loc ede-locate-base) + root) + "Is it ok to use this project type under ROOT." + t) + +(defmethod ede-locate-file-in-hash ((loc ede-locate-base) + filestring) + "For LOC, is the file FILESTRING in our hashtable?" + (gethash filestring (oref loc hash))) + +(defmethod ede-locate-add-file-to-hash ((loc ede-locate-base) + filestring fullfilename) + "For LOC, add FILESTR to the hash with FULLFILENAME." + (puthash filestring fullfilename (oref loc hash))) + +(defmethod ede-locate-file-in-project ((loc ede-locate-base) + filesubstring + ) + "Locate with LOC occurances of FILESUBSTRING. +Searches are done under the current root of the EDE project +that crated this ede locat object." + (let ((ans (ede-locate-file-in-project-impl loc filesubstring)) + ) + (oset loc file filesubstring) + (oset loc lastanswer ans) + ans)) + +(defmethod ede-locate-file-in-project-impl ((loc ede-locate-base) + filesubstring + ) + "Locate with LOC occurances of FILESUBSTRING. +Searches are done under the current root of the EDE project +that crated this ede locat object." + nil + ) + +;;; LOCATE +;; +;; Using the standard unix "locate" command. +;; Since locate is system wide, we need to hack the search +;; to restrict it to within just this project. + +(defclass ede-locate-locate (ede-locate-base) + () + "EDE Locator using the locate command. +Configure the Emacs `locate-program' variable to also +configure the use of EDE locate.") + +(defmethod ede-locate-ok-in-project :static ((loc ede-locate-locate) + root) + "Is it ok to use this project type under ROOT." + (or (featurep 'locate) (locate-library "locate")) + ) + +(defmethod ede-locate-file-in-project-impl ((loc ede-locate-locate) + filesubstring) + "Locate with LOC occurances of FILESUBSTRING under PROJECTROOT. +Searches are done under the current root of the EDE project +that crated this ede locat object." + ;; We want something like: + ;; /my/project/root*/filesubstring.c + (let* ((searchstr (concat (directory-file-name (oref loc root)) + "*/" filesubstring)) + (b (get-buffer-create "*LOCATE*")) + (cd default-directory) + ) + (save-excursion + (set-buffer b) + (setq default-directory cd) + (erase-buffer)) + (apply 'call-process locate-command + nil b nil + searchstr nil) + (save-excursion + (set-buffer b) + (split-string (buffer-string) "\n" t)) + ) + ) + +;;; GLOBAL +;; +(defclass ede-locate-global (ede-locate-base) + () + "EDE Locator using GNU Global. +Configure EDE's use of GNU Global through the cedet-global.el +variable `cedet-global-command'.") + +(defmethod initialize-instance ((loc ede-locate-global) + &rest slots) + "Make sure that we can use GNU Global." + (require 'cedet-global) + ;; Get ourselves initialized. + (call-next-method) + ;; Do the checks. + (cedet-gnu-global-version-check) + (let* ((default-directory (oref loc root)) + (root (cedet-gnu-global-root))) + (when (not root) + (error "Cannot use GNU Global in %s" + (oref loc root)))) + ) + +(defmethod ede-locate-ok-in-project :static ((loc ede-locate-global) + root) + "Is it ok to use this project type under ROOT." + (require 'cedet-global) + (cedet-gnu-global-version-check) + (let* ((default-directory root) + (newroot (cedet-gnu-global-root))) + newroot)) + +(defmethod ede-locate-file-in-project-impl ((loc ede-locate-global) + filesubstring) + "Locate with LOC occurances of FILESUBSTRING under PROJECTROOT. +Searches are done under the current root of the EDE project +that crated this ede locat object." + (require 'cedet-global) + (let ((default-directory (oref loc root))) + (cedet-gnu-global-expand-filename filesubstring))) + +;;; IDUTILS +;; +(defclass ede-locate-idutils (ede-locate-base) + () + "EDE Locator using IDUtils. +Configure EDE's use of IDUtils through the cedet-idutils.el +file name searching variable `cedet-idutils-file-command'.") + +(defmethod initialize-instance ((loc ede-locate-idutils) + &rest slots) + "Make sure that we can use IDUtils." + ;; Get ourselves initialized. + (call-next-method) + ;; Do the checks. + (require 'cedet-idutils) + (cedet-idutils-version-check) + (when (not (cedet-idutils-support-for-directory (oref loc root))) + (error "Cannot use IDUtils in %s" + (oref loc root))) + ) + +(defmethod ede-locate-ok-in-project :static ((loc ede-locate-idutils) + root) + "Is it ok to use this project type under ROOT." + (require 'cedet-idutils) + (cedet-idutils-version-check) + (when (cedet-idutils-support-for-directory root) + root)) + +(defmethod ede-locate-file-in-project-impl ((loc ede-locate-idutils) + filesubstring) + "Locate with LOC occurances of FILESUBSTRING under PROJECTROOT. +Searches are done under the current root of the EDE project +that crated this ede locat object." + (require 'cedet-idutils) + (let ((default-directory (oref loc root))) + (cedet-idutils-expand-filename filesubstring))) + +;;; CSCOPE +;; +(defclass ede-locate-cscope (ede-locate-base) + () + "EDE Locator using Cscope. +Configure EDE's use of Cscope through the cedet-cscope.el +file name searching variable `cedet-cscope-file-command'.") + +(defmethod initialize-instance ((loc ede-locate-cscope) + &rest slots) + "Make sure that we can use Cscope." + ;; Get ourselves initialized. + (call-next-method) + ;; Do the checks. + (cedet-cscope-version-check) + (when (not (cedet-cscope-support-for-directory (oref loc root))) + (error "Cannot use Cscope in %s" + (oref loc root))) + ) + +(defmethod ede-locate-ok-in-project :static ((loc ede-locate-cscope) + root) + "Is it ok to use this project type under ROOT." + (cedet-cscope-version-check) + (when (cedet-cscope-support-for-directory root) + root)) + +(defmethod ede-locate-file-in-project-impl ((loc ede-locate-cscope) + filesubstring) + "Locate with LOC occurances of FILESUBSTRING under PROJECTROOT. +Searches are done under the current root of the EDE project +that crated this ede locat object." + (let ((default-directory (oref loc root))) + (cedet-cscope-expand-filename filesubstring))) + +(provide 'ede/locate) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: ede/loaddefs +;; generated-autoload-load-name: "ede/locate" +;; End: + +;;; ede/locate.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/make.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/make.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,110 @@ +;;; ede/make.el --- General information about "make" + +;;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; This file needs to choose the version of "make" it wants to use. +;; Whenever an executable "gmake" is available, we prefer that since +;; it usually means GNU Make. If it doesn't exist, use "make". +;; +;; Run tests on make --version to be sure it is GNU make so that +;; logical error messages can be provided. + +;;; Code: + +(declare-function inversion-check-version "inversion") + +(if (fboundp 'locate-file) + (defsubst ede--find-executable (exec) + "Return an expanded file name for a program EXEC on the exec path." + (locate-file exec exec-path)) + + ;; Else, older version of Emacs. + + (defsubst ede--find-executable (exec) + "Return an expanded file name for a program EXEC on the exec path." + (let ((p exec-path) + (found nil)) + (while (and p (not found)) + (let ((f (expand-file-name exec (car p)))) + (if (file-exists-p f) + (setq found f))) + (setq p (cdr p))) + found)) + ) + +(defvar ede-make-min-version "3.0" + "Minimum version of GNU make required.") + +(defcustom ede-make-command (cond ((ede--find-executable "gmake") + "gmake") + (t "make")) ;; What to do? + "The MAKE command to use for EDE when compiling. +The makefile generated by EDE for C files uses syntax that depends on GNU Make, +so this should be set to something that can execute GNU Make files." + :group 'ede + :type 'string) + +;;;###autoload +(defun ede-make-check-version (&optional noerror) + "Check the version of GNU Make installed. +The check passes if the MAKE version is no high enough, or if it +is not GNU make. +If NOERROR is non-nil, return t for success, nil for failure. +If NOERROR is nil, then throw an error on failure. Return t otherwise." + (interactive) + (let ((b (get-buffer-create "*EDE Make Version*")) + (cd default-directory) + (rev nil) + (ans nil) + ) + (save-excursion + ;; Setup, and execute make. + (set-buffer b) + (setq default-directory cd) + (erase-buffer) + (call-process ede-make-command nil b nil + "--version") + ;; Check the buffer for the string + (goto-char (point-min)) + (when (looking-at "GNU Make\\(?: version\\)? \\([0-9][^,]+\\),") + (setq rev (match-string 1)) + (require 'inversion) + (setq ans (not (inversion-check-version rev nil ede-make-min-version)))) + + ;; Answer reporting. + (when (and (interactive-p) ans) + (message "GNU Make version %s. Good enough for CEDET." rev)) + + (when (and (not noerror) (not ans)) + (error "EDE requires GNU Make version %s or later. Configure `ede-make-command' to fix" + ede-make-min-version)) + ans))) + +(provide 'ede/make) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: ede/loaddefs +;; generated-autoload-load-name: "ede/make" +;; End: + +;;; ede/make.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/makefile-edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/makefile-edit.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,129 @@ +;;; makefile-edit.el --- Makefile editing/scanning commands. + +;;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Utilities for editing a Makefile for EDE Makefile management commands. +;; +;; Derived from project-am.el. +;; +;; Makefile editing and scanning commands +;; +;; Formatting of a makefile +;; +;; 1) Creating an automakefile, stick in a top level comment about +;; being created by emacs +;; 2) Leave order of variable contents alone, except for SOURCE +;; SOURCE always keep in the order of .c, .h, the other stuff. + +;;; Things to do +;; makefile-fill-paragraph -- refill a macro w/ backslashes +;; makefile-insert-macro -- insert "foo = " + + +;;; Code: + +(defun makefile-beginning-of-command () + "Move the the beginning of the current command." + (interactive) + (if (save-excursion + (forward-line -1) + (makefile-line-continued-p)) + (forward-line -1)) + (beginning-of-line) + (if (not (makefile-line-continued-p)) + nil + (while (and (makefile-line-continued-p) + (not (bobp))) + (forward-line -1)) + (forward-line 1))) + +(defun makefile-end-of-command () + "Move the the beginning of the current command." + (interactive) + (end-of-line) + (while (and (makefile-line-continued-p) + (not (eobp))) + (forward-line 1) + (end-of-line))) + +(defun makefile-line-continued-p () + "Return non-nil if the current line ends in continuation." + (save-excursion + (end-of-line) + (= (preceding-char) ?\\))) + +;;; Programatic editing of a Makefile +;; +(defun makefile-move-to-macro (macro &optional next) + "Move to the definition of MACRO. Return t if found. +If NEXT is non-nil, move to the next occurance of MACRO." + (let ((oldpt (point))) + (when (not next) (goto-char (point-min))) + (if (re-search-forward (concat "^\\s-*" macro "\\s-*[+:?]?=") nil t) + t + (goto-char oldpt) + nil))) + +(defun makefile-navigate-macro (stop-before) + "In a list of files, move forward until STOP-BEFORE is reached. +STOP-BEFORE is a regular expression matching a file name." + (save-excursion + (makefile-beginning-of-command) + (let ((e (save-excursion + (makefile-end-of-command) + (point)))) + (if (re-search-forward stop-before nil t) + (goto-char (match-beginning 0)) + (goto-char e))))) + +(defun makefile-macro-file-list (macro) + "Return a list of all files in MACRO." + (save-excursion + (goto-char (point-min)) + (let ((lst nil)) + (while (makefile-move-to-macro macro t) + (let ((e (save-excursion + (makefile-end-of-command) + (point)))) + (while (re-search-forward "\\s-**\\([-a-zA-Z0-9./_@$%(){}]+\\)\\s-*" e t) + (let ((var nil)(varexp nil) + (match (buffer-substring-no-properties + (match-beginning 1) + (match-end 1)))) + (if (not (setq var (makefile-extract-varname-from-text match))) + (setq lst (cons match lst)) + (setq varexp (makefile-macro-file-list var)) + (dolist (V varexp) + (setq lst (cons V lst)))))))) + (nreverse lst)))) + +(defun makefile-extract-varname-from-text (text) + "Extract the variable name from TEXT if it is a variable reference. +Return nil if it isn't a variable." + (save-match-data + (when (string-match "\\$\\s(\\([A-Za-z0-9_]+\\)\\s)" text) + (match-string 1 text)))) + + +(provide 'ede/makefile-edit) + +;;; ede/makefile-edit.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/pconf.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/pconf.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,188 @@ +;;; ede/pconf.el --- configure.ac maintenance for EDE + +;;; Copyright (C) 1998, 1999, 2000, 2005, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: project + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Code generator for autoconf configure.ac, and support files. + +(require 'ede/proj) +(require 'ede/autoconf-edit) +(defvar compilation-in-progress) + +(defvar ede-pconf-create-file-query 'ask + "Controls if queries are made while creating project files. +A value of 'ask means to always ask the user before creating +a file, such as AUTHORS. A value of 'never means don't ask, and +don't do it. A value of nil means to just do it.") + +;;; Code: +(defmethod ede-proj-configure-file ((this ede-proj-project)) + "The configure.ac script used by project THIS." + (ede-expand-filename (ede-toplevel this) "configure.ac" t)) + +(defmethod ede-proj-configure-test-required-file ((this ede-proj-project) file) + "For project THIS, test that the file FILE exists, or create it." + (when (not (ede-expand-filename (ede-toplevel this) file)) + (save-excursion + (find-file (ede-expand-filename (ede-toplevel this) file t)) + (cond ((string= file "AUTHORS") + (insert (user-full-name) " <" (user-login-name) ">")) + ((string= file "NEWS") + (insert "NEWS file for " (ede-name this))) + (t (insert "\n"))) + (save-buffer) + (when + (and (eq ede-pconf-create-file-query 'ask) + (not (eq ede-pconf-create-file-query 'never)) + (not (y-or-n-p + (format "I had to create the %s file for you. Ok? " file))) + (error "Quit")))))) + + +(defmethod ede-proj-configure-synchronize ((this ede-proj-project)) + "Synchronize what we know about project THIS into configure.ac." + (let ((b (find-file-noselect (ede-proj-configure-file this))) + ;;(td (file-name-directory (ede-proj-configure-file this))) + (targs (oref this targets)) + (postcmd "") + (add-missing nil)) + ;; First, make sure we have a file. + (if (not (file-exists-p (ede-proj-configure-file this))) + (autoconf-new-program b (oref this name) "Project.ede")) + (set-buffer b) + ;; Next, verify all targets of all subobjects. + (autoconf-set-version (oref this version)) + (let ((top-level-project-local this)) + (autoconf-set-output + (ede-map-all-subprojects + this + (lambda (sp) + ;; NOTE: don't put in ./Makefile - configure complains. + (let ((dir (file-name-as-directory + (directory-file-name + (ede-subproject-relative-path sp top-level-project-local))))) + (when (string= dir "./") (setq dir "")) + ;; Use concat, because expand-file-name removes the relativeness. + (concat dir "Makefile") ))))) + ;; + ;; NOTE TO SELF. TURN THIS INTO THE OFFICIAL LIST + ;; + (ede-proj-dist-makefile this) + ;; Loop over all targets to clean and then add themselves in. + (ede-map-all-subprojects + this + (lambda (sp) + (ede-map-targets sp 'ede-proj-flush-autoconf))) + (ede-map-all-subprojects + this + (lambda (sp) + (ede-map-targets this 'ede-proj-tweak-autoconf))) + ;; Now save + (save-buffer) + ;; Verify aclocal + (setq postcmd "aclocal;") + ;; Always add missing files as needed. + (setq postcmd (concat postcmd "automake --add-missing;")) + + ;; Always do autoreconf + (setq postcmd (concat postcmd "autoreconf;")) + ;; Verify a bunch of files that are required by automake. + (ede-proj-configure-test-required-file this "AUTHORS") + (ede-proj-configure-test-required-file this "NEWS") + (ede-proj-configure-test-required-file this "README") + (ede-proj-configure-test-required-file this "ChangeLog") + ;; Let specific targets get missing files. + (mapc 'ede-proj-configure-create-missing targs) + ;; Verify that we have a make system. + (if (or (not (ede-expand-filename (ede-toplevel this) "Makefile")) + ;; Now is this one of our old Makefiles? + (save-excursion + (set-buffer (find-file-noselect + (ede-expand-filename (ede-toplevel this) + "Makefile" t) t)) + (goto-char (point-min)) + ;; Here is the unique piece for our makefiles. + (re-search-forward "For use with: make" nil t))) + (setq postcmd (concat postcmd "./configure;"))) + (if (not (string= "" postcmd)) + (progn + (compile postcmd) + + (while compilation-in-progress + (accept-process-output) + (sit-for 1)) + + (save-excursion + (set-buffer "*compilation*") + (goto-char (point-max)) + + (when (not (string= mode-line-process ":exit [0]")) + (error "Configure failed!")) + + ;; The Makefile is now recreated by configure? + (let ((b (get-file-buffer + (ede-expand-filename (ede-toplevel this) + "Makefile" 'newfile)))) + ;; This makes sure that if Makefile was loaded, and old, + ;; that it gets flushed so we don't keep rebuilding + ;; the autoconf system. + (if b (kill-buffer b)))) + + )))) + +(defmethod ede-proj-configure-recreate ((this ede-proj-project)) + "Delete project THISes configure script and start over." + (if (not (ede-proj-configure-file this)) + (error "Could not determine configure.ac for %S" (object-name this))) + (let ((b (get-file-buffer (ede-proj-configure-file this)))) + ;; Destroy all evidence of the old configure.ac + (delete-file (ede-proj-configure-file this)) + (if b (kill-buffer b))) + (ede-proj-configure-synchronize this)) + +(defmethod ede-proj-tweak-autoconf ((this ede-proj-target)) + "Tweak the configure file (current buffer) to accomodate THIS." + ;; Check the compilers belonging to THIS, and call the autoconf + ;; setup for those compilers. + (mapc 'ede-proj-tweak-autoconf (ede-proj-compilers this)) + (mapc 'ede-proj-tweak-autoconf (ede-proj-linkers this)) + ) + +(defmethod ede-proj-flush-autoconf ((this ede-proj-target)) + "Flush the configure file (current buffer) to accomodate THIS. +By flushing, remove any cruft that may be in the file. Subsequent +calls to `ede-proj-tweak-autoconf' can restore items removed by flush." + nil) + +(defmethod ede-proj-configure-add-missing ((this ede-proj-target)) + "Query if any files needed by THIS provided by automake are missing. +Results in --add-missing being passed to automake." + nil) + +(defmethod ede-proj-configure-create-missing ((this ede-proj-target)) + "Add any missing files for THIS by creating them." + nil) + +(provide 'ede/pconf) + +;;; ede/pconf.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/pmake.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/pmake.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,663 @@ +;;; 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 +;; 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 . + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj-archive.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj-archive.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,64 @@ +;;; ede/proj-archive.el --- EDE Generic Project archive support + +;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: project, make + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Handle object code archives in and EDE Project file. + +(require 'ede/pmake) +(require 'ede/proj-obj) + +;;; Code: + +(defclass ede-proj-target-makefile-archive + (ede-proj-target-makefile-objectcode) + ((availablelinkers :initform (ede-archive-linker))) + "This target generates an object code archive.") + +(defvar ede-archive-linker + (ede-linker + "ede-archive-linker" + :name "ar" + :variables '(("AR" . "ar") + ("AR_CMD" . "$(AR) cr")) + :commands '("$(AR_CMD) lib$@.a $^") + :autoconf '(("AC_CHECK_PROGS" . "RANLIB, ranlib")) + :objectextention "") + "Linker object for creating an archive.") + +(defmethod ede-proj-makefile-insert-source-variables :BEFORE + ((this ede-proj-target-makefile-archive) &optional moresource) + "Insert bin_PROGRAMS variables needed by target THIS. +We aren't acutally inserting SOURCE details, but this is used by the +Makefile.am generator, so use it to add this important bin program." + (ede-pmake-insert-variable-shared + (concat "lib" (ede-name this) "_a_LIBRARIES") + (insert (concat "lib" (ede-name this) ".a")))) + +(defmethod ede-proj-makefile-garbage-patterns + ((this ede-proj-target-makefile-archive)) + "Add archive name to the garbage patterns. +This makes sure that the archive is removed with 'make clean'." + (let ((garb (call-next-method))) + (append garb (list (concat "lib" (ede-name this) ".a"))))) + +(provide 'ede/proj-archive) + +;;; ede/proj-archive.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj-aux.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj-aux.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,47 @@ +;;; ede/proj-aux.el --- EDE Generic Project auxilliary file support + +;;; Copyright (C) 1998, 1999, 2000, 2007 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; Commentary: +;; +;; Handle auxiliary files (README, FAQ, etc) in and EDE Project file. + +(require 'ede/proj) +(require 'ede/pmake) + +;;; Code: +(defclass ede-proj-target-aux (ede-proj-target) + ((sourcetype :initform (ede-aux-source))) + "This target consists of aux files such as READMEs and COPYING.") + +(defvar ede-aux-source + (ede-sourcecode "ede-aux-source-txt" + :name "Auxiliary Text" + :sourcepattern "^[A-Z]+$\\|\\.txt$") + "Miscelaneous fields definition.") + +(defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-aux)) + "Return the variable name for THIS's sources." + (concat (ede-pmake-varname this) "_AUX")) + +(provide 'ede/proj-aux) + +;;; ede/proj-aux.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj-comp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj-comp.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,346 @@ +;;; 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 +;; 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 . + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj-elisp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj-elisp.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,395 @@ +;;; 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 +;; 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 . + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj-info.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj-info.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,186 @@ +;;; ede-proj-info.el --- EDE Generic Project texinfo support + +;;; Copyright (C) 1998, 1999, 2000, 2001, 2004, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; Commentary: +;; +;; Handle texinfo in and EDE Project file. + +(require 'ede/pmake) + +;;; Code: +(defclass ede-proj-target-makefile-info (ede-proj-target-makefile) + ((menu :initform nil) + (keybindings :initform nil) + (availablecompilers :initform (ede-makeinfo-compiler + ede-texi2html-compiler)) + (sourcetype :initform (ede-makeinfo-source)) + (mainmenu :initarg :mainmenu + :initform "" + :type string + :custom string + :documentation "The main menu resides in this file. +All other sources should be included independently.")) + "Target for a single info file.") + +(defvar ede-makeinfo-source + (ede-sourcecode "ede-makeinfo-source" + :name "Texinfo" + :sourcepattern "\\.texi?$" + :garbagepattern '("*.info*" "*.html")) + "Texinfo source code definition.") + +(defvar ede-makeinfo-compiler + (ede-compiler + "ede-makeinfo-compiler" + :name "makeinfo" + :variables '(("MAKEINFO" . "makeinfo")) + :commands '("$(MAKEINFO) $<") + :autoconf '(("AC_CHECK_PROG" . "MAKEINFO, makeinfo")) + :sourcetype '(ede-makeinfo-source) + ) + "Compile texinfo files into info files.") + +(defvar ede-texi2html-compiler + (ede-compiler + "ede-texi2html-compiler" + :name "texi2html" + :variables '(("TEXI2HTML" . "makeinfo -html")) + :commands '("makeinfo -o $@ $<") + :sourcetype '(ede-makeinfo-source) + ) + "Compile texinfo files into html files.") + +;;; Makefile generation +;; +(defmethod ede-proj-configure-add-missing + ((this ede-proj-target-makefile-info)) + "Query if any files needed by THIS provided by automake are missing. +Results in --add-missing being passed to automake." + (not (ede-expand-filename (ede-toplevel) "texinfo.tex"))) + +(defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-makefile-info)) + "Return the variable name for THIS's sources." + (concat (ede-pmake-varname this) "_TEXINFOS")) + +(defmethod ede-proj-makefile-insert-source-variables + ((this ede-proj-target-makefile-info) &optional moresource) + "Insert the source variables needed by THIS info target. +Optional argument MORESOURCE is a list of additional sources to add to the +sources variable. +Does the usual for Makefile mode, but splits source into two variables +when working in Automake mode." + (if (not (ede-proj-automake-p)) + (call-next-method) + (let* ((sv (ede-proj-makefile-sourcevar this)) + (src (copy-sequence (oref this source))) + (menu (or (oref this menu) (car src)))) + (setq src (delq menu src)) + ;; the info_TEXINFOS variable is probably shared + (ede-pmake-insert-variable-shared "info_TEXINFOS" + (insert menu)) + ;; Now insert the rest of the source elsewhere + (ede-pmake-insert-variable-shared sv + (insert (mapconcat 'identity src " "))) + (if moresource + (error "Texinfo files should not have moresource"))))) + +(defun ede-makeinfo-find-info-filename (source) + "Find the info filename produced by SOURCE texinfo file." + (let ((opened (get-file-buffer source)) + (buffer (or (get-file-buffer source) + (find-file-noselect source nil t))) + info) + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + (and (re-search-forward "^@setfilename\\s-+\\([^.]+\\).info$" nil t) + (setq info (match-string 1))))) + (unless (eq buffer opened) + (kill-buffer buffer)) + info)) + +(defmethod ede-proj-makefile-target-name ((this ede-proj-target-makefile-info)) + "Return the name of the main target for THIS target." + ;; The target should be the main-menu file name translated to .info. + (let* ((source (if (not (string= (oref this mainmenu) "")) + (oref this mainmenu) + (car (oref this source)))) + (info (ede-makeinfo-find-info-filename source))) + (concat (or info (file-name-sans-extension source)) ".info"))) + +(defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target-makefile-info)) + "Insert any symbols that the DIST rule should depend on. +Texinfo files want to insert generated `.info' 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-makefile-info)) + "Insert any symbols that the DIST rule should depend on. +Texinfo files want to insert generated `.info' 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) "*") + ) + +; (let ((n (ede-name this))) +; (if (string-match "\\.info$" n) +; n +; (concat n ".info")))) + +(defmethod object-write ((this ede-proj-target-makefile-info)) + "Before committing any change to THIS, make sure the mainmenu is first." + (let ((mm (oref this mainmenu)) + (s (oref this source)) + (nl nil)) + (if (or (string= mm "") (not mm) (string= mm (car s))) + nil + ;; Make sure that MM is first in the list of items. + (setq nl (cons mm (delq mm s))) + (oset this source nl))) + (call-next-method)) + +(defmethod ede-documentation ((this ede-proj-target-makefile-info)) + "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* ((src (oref this source)) + (proj (ede-target-parent this)) + (dir (oref proj directory)) + (out nil) + ) + ;; convert src to full file names. + (while src + (setq out (cons + (expand-file-name (car src) dir) + out)) + (setq src (cdr src))) + ;; Return it + out)) + +(provide 'ede/proj-info) + +;;; ede/proj-info.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj-misc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj-misc.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,93 @@ +;;; ede-proj-nusc.el --- EDE Generic Project Emacs Lisp support + +;;; Copyright (C) 1998, 1999, 2000, 2001, 2008 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; Commentary: +;; +;; Handle miscelaneous compilable projects in and EDE Project file. +;; This misc target lets the user link in custom makefiles to an EDE +;; project. + +(require 'ede/pmake) +(require 'ede/proj-comp) + +;;; Code: +(defclass ede-proj-target-makefile-miscelaneous (ede-proj-target-makefile) + ((sourcetype :initform (ede-misc-source)) + (availablecompilers :initform (ede-misc-compile)) + (submakefile :initarg :submakefile + :initform "" + :type string + :custom string + :documentation + "Miscellaneous sources which have a specialized makefile. +The sub-makefile is used to build this target.") + ) + "Miscelaneous target type. +A user-written makefile is used to build this target. +All listed sources are included in the distribution.") + +(defvar ede-misc-source + (ede-sourcecode "ede-misc-source" + :name "Miscelaneous" + :sourcepattern ".*") + "Miscelaneous fiels definition.") + +(defvar ede-misc-compile + (ede-compiler "ede-misc-compile" + :name "Sub Makefile" + :commands + '( + ) + :autoconf nil + :sourcetype '(ede-misc-source) + ) + "Compile code via a sub-makefile.") + +(defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-makefile-miscelaneous)) + "Return the variable name for THIS's sources." + (concat (ede-pmake-varname this) "_MISC")) + +(defmethod ede-proj-makefile-dependency-files + ((this ede-proj-target-makefile-miscelaneous)) + "Return a list of files which THIS target depends on." + (with-slots (submakefile) this + (cond ((string= submakefile "") + nil) + ((not submakefile) + nil) + (t (list submakefile))))) + +(defmethod ede-proj-makefile-insert-rules ((this ede-proj-target-makefile-miscelaneous)) + "Create the make rule needed to create an archive for THIS." + ;; DO NOT call the next method. We will never have any compilers, + ;; or any dependencies, or stuff like this. This rull will lets us + ;; deal with it in a nice way. + (insert (ede-name this) ": ") + (with-slots (submakefile) this + (if (string= submakefile "") + (insert "\n\t@\n\n") + (insert submakefile "\n" "\t$(MAKE) -f " submakefile "\n\n")))) + +(provide 'ede/proj-misc) + +;;; ede/proj-misc.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj-obj.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj-obj.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,281 @@ +;;; ede/proj-obj.el --- EDE Generic Project Object code generation support + +;;; Copyright (C) 1998, 1999, 2000, 2005, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; Commentary: +;; +;; Handles a supperclass of target types which create object code in +;; and EDE Project file. + +(require 'ede/proj) +(declare-function ede-pmake-varname "ede/pmake") + +(defvar ede-proj-objectcode-dodependencies nil + "Flag specifies to do automatic dependencies.") + +;;; Code: +(defclass ede-proj-target-makefile-objectcode (ede-proj-target-makefile) + (;; Give this a new default + (configuration-variables :initform ("debug" . (("CFLAGS" . "-g") + ("LDFLAGS" . "-g")))) + ;; @TODO - add an include path. + (availablecompilers :initform (ede-gcc-compiler + ede-g++-compiler + ede-gfortran-compiler + ede-gfortran-module-compiler + ;; More C and C++ compilers, plus + ;; fortran or pascal can be added here + )) + (availablelinkers :initform (ede-g++-linker + ;; Add more linker thingies here. + ede-ld-linker + ede-gfortran-linker + )) + (sourcetype :initform (ede-source-c + ede-source-c++ + ede-source-f77 + ede-source-f90 + ;; ede-source-other + ;; This object should take everything that + ;; gets compiled into objects like fortran + ;; and pascal. + )) + ) + "Abstract class for Makefile based object code generating targets. +Belonging to this group assumes you could make a .o from an element source +file.") + +(defclass ede-object-compiler (ede-compiler) + ((uselinker :initform t) + (dependencyvar :initarg :dependencyvar + :type list + :custom (cons (string :tag "Variable") + (string :tag "Value")) + :documentation + "A variable dedicated to dependency generation.")) + "Ede compiler class for source which must compiler, and link.") + +;;; C/C++ Compilers and Linkers +;; +(defvar ede-source-c + (ede-sourcecode "ede-source-c" + :name "C" + :sourcepattern "\\.c$" + :auxsourcepattern "\\.h$" + :garbagepattern '("*.o" "*.obj" ".deps/*.P" ".lo")) + "C source code definition.") + +(defvar ede-gcc-compiler + (ede-object-compiler + "ede-c-compiler-gcc" + :name "gcc" + :dependencyvar '("C_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P") + :variables '(("CC" . "gcc") + ("C_COMPILE" . + "$(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)")) + :rules (list (ede-makefile-rule + "c-inference-rule" + :target "%.o" + :dependencies "%.c" + :rules '("@echo '$(C_COMPILE) -c $<'; \\" + "$(C_COMPILE) $(C_DEPENDENCIES) -o $@ -c $<" + ) + )) + :autoconf '("AC_PROG_CC" "AC_PROG_GCC_TRADITIONAL") + :sourcetype '(ede-source-c) + :objectextention ".o" + :makedepends t + :uselinker t) + "Compiler for C sourcecode.") + +(defvar ede-source-c++ + (ede-sourcecode "ede-source-c++" + :name "C++" + :sourcepattern "\\.\\(cpp\\|cc\\|cxx\\)$" + :auxsourcepattern "\\.\\(hpp\\|hh?\\|hxx\\)$" + :garbagepattern '("*.o" "*.obj" ".deps/*.P" ".lo")) + "C++ source code definition.") + +(defvar ede-g++-compiler + (ede-object-compiler + "ede-c-compiler-g++" + :name "g++" + :dependencyvar '("CXX_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P") + :variables '(("CXX" "g++") + ("CXX_COMPILE" . + "$(CXX) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)") + ) + :rules (list (ede-makefile-rule + "c++-inference-rule" + :target "%.o" + :dependencies "%.cpp" + :rules '("@echo '$(CXX_COMPILE) -c $<'; \\" + "$(CXX_COMPILE) $(CXX_DEPENDENCIES) -o $@ -c $<" + ) + )) + :autoconf '("AC_PROG_CXX") + :sourcetype '(ede-source-c++) + :objectextention ".o" + :makedepends t + :uselinker t) + "Compiler for C sourcecode.") + +(defvar ede-g++-linker + (ede-linker + "ede-g++-linker" + :name "g++" + ;; Only use this linker when c++ exists. + :sourcetype '(ede-source-c++) + :variables '(("CXX_LINK" . + "$(CXX) $(CFLAGS) $(LDFLAGS) -L. -o $@") + ) + :commands '("$(CXX_LINK) $^") + :autoconf '("AC_PROG_CXX") + :objectextention "") + "Linker needed for c++ programs.") + +;;; Fortran Compiler/Linker +;; +;; Contributed by David Engster +(defvar ede-source-f90 + (ede-sourcecode "ede-source-f90" + :name "Fortran 90/95" + :sourcepattern "\\.[fF]9[05]$" + :auxsourcepattern "\\.incf$" + :garbagepattern '("*.o" "*.mod" ".deps/*.P")) + "Fortran 90/95 source code definition.") + +(defvar ede-source-f77 + (ede-sourcecode "ede-source-f77" + :name "Fortran 77" + :sourcepattern "\\.\\([fF]\\|for\\)$" + :auxsourcepattern "\\.incf$" + :garbagepattern '("*.o" ".deps/*.P")) + "Fortran 77 source code definition.") + +(defvar ede-gfortran-compiler + (ede-object-compiler + "ede-f90-compiler-gfortran" + :name "gfortran" + :dependencyvar '("F90_DEPENDENCIES" . "-Wp,-MD,.deps/$(*F).P") + :variables '(("F90" . "gfortran") + ("F90_COMPILE" . + "$(F90) $(DEFS) $(INCLUDES) $(F90FLAGS)")) + :rules (list (ede-makefile-rule + "f90-inference-rule" + :target "%.o" + :dependencies "%.f90" + :rules '("@echo '$(F90_COMPILE) -c $<'; \\" + "$(F90_COMPILE) $(F90_DEPENDENCIES) -o $@ -c $<" + ) + )) + :sourcetype '(ede-source-f90 ede-source-f77) + :objectextention ".o" + :makedepends t + :uselinker t) + "Compiler for Fortran sourcecode.") + +(defvar ede-gfortran-module-compiler + (clone ede-gfortran-compiler + "ede-f90-module-compiler-gfortran" + :name "gfortranmod" + :sourcetype '(ede-source-f90) + :commands '("$(F90_COMPILE) -c $^") + :objectextention ".mod" + :uselinker nil) + "Compiler for Fortran 90/95 modules.") + + +(defvar ede-gfortran-linker + (ede-linker + "ede-gfortran-linker" + :name "gfortran" + :sourcetype '(ede-source-f90 ede-source-f77) + :variables '(("F90_LINK" . + "$(F90) $(CFLAGS) $(LDFLAGS) -L. -o $@") + ) + :commands '("$(F90_LINK) $^") + :objectextention "") + "Linker needed for Fortran programs.") + +;;; Generic Linker +;; +(defvar ede-ld-linker + (ede-linker + "ede-ld-linker" + :name "ld" + :variables '(("LD" . "ld") + ("LD_LINK" . + "$(LD) $(LDFLAGS) -L. -o $@") + ) + :commands '("$(LD_LINK) $^") + :objectextention "") + "Linker needed for c++ programs.") + +;;; The EDE object compiler +;; +(defmethod ede-proj-makefile-insert-variables ((this ede-object-compiler)) + "Insert variables needed by the compiler THIS." + (call-next-method) + (if (eieio-instance-inheritor-slot-boundp this 'dependencyvar) + (with-slots (dependencyvar) this + (insert (car dependencyvar) "=") + (let ((cd (cdr dependencyvar))) + (if (listp cd) + (mapc (lambda (c) (insert " " c)) cd) + (insert cd)) + (insert "\n"))))) + +;;; EDE Object target type methods +;; +(defmethod ede-proj-makefile-sourcevar + ((this ede-proj-target-makefile-objectcode)) + "Return the variable name for THIS's sources." + (require 'ede/pmake) + (concat (ede-pmake-varname this) "_SOURCES")) + +(defmethod ede-proj-makefile-dependency-files + ((this ede-proj-target-makefile-objectcode)) + "Return a list of source files to convert to dependencies. +Argument THIS is the target to get sources from." + (append (oref this source) (oref this auxsource))) + +(defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile-objectcode) + &optional moresource) + "Insert variables needed by target THIS. +Optional argument MORESOURCE is not used." + (let ((ede-proj-objectcode-dodependencies + (oref (ede-target-parent this) automatic-dependencies))) + (call-next-method))) + +(defmethod ede-buffer-header-file((this ede-proj-target-makefile-objectcode) + buffer) + "There are no default header files." + (or (call-next-method) + ;; Ok, nothing obvious. Try looking in ourselves. + (let ((h (oref this auxsource))) + ;; Add more logic here when the problem is better understood. + (car-safe h)))) + +(provide 'ede/proj-obj) + +;;; ede/proj-obj.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj-prog.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj-prog.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,113 @@ +;;; ede-proj-prog.el --- EDE Generic Project program support + +;;; Copyright (C) 1998, 1999, 2000, 2001, 2005, 2008 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; Commentary: +;; +;; Handle building programs from object files in and EDE Project file. + +(require 'ede/pmake) +(require 'ede/proj-obj) + +;;; Code: +(defclass ede-proj-target-makefile-program + (ede-proj-target-makefile-objectcode) + ((ldlibs :initarg :ldlibs + :initform nil + :type list + :custom (repeat (string :tag "Library")) + :documentation + "Libraries, such as \"m\" or \"Xt\" which this program depends on. +The linker flag \"-l\" is automatically prepended. Do not include a \"lib\" +prefix, or a \".so\" suffix. + +Note: Currently only used for Automake projects." + ) + (ldflags :initarg :ldflags + :initform nil + :type list + :custom (repeat (string :tag "Link Flag")) + :documentation + "Additional flags to add when linking this target. +Use ldlibs to add addition libraries. Use this to specify specific +options to the linker. + +Note: Not currently used. This bug needs to be fixed.") + ) + "This target is an executable program.") + +(defmethod ede-proj-makefile-insert-automake-pre-variables + ((this ede-proj-target-makefile-program)) + "Insert bin_PROGRAMS variables needed by target THIS." + (ede-pmake-insert-variable-shared "bin_PROGRAMS" + (insert (ede-name this))) + (call-next-method)) + +(defmethod ede-proj-makefile-insert-automake-post-variables + ((this ede-proj-target-makefile-program)) + "Insert bin_PROGRAMS variables needed by target THIS." + (ede-pmake-insert-variable-shared + (concat (ede-name this) "_LDADD") + (mapc (lambda (c) (insert " -l" c)) (oref this ldlibs))) + ;; For other targets THIS depends on + ;; + ;; NOTE: FIX THIS + ;; + ;;(ede-pmake-insert-variable-shared + ;; (concat (ede-name this) "_DEPENDENCIES") + ;; (mapcar (lambda (d) (insert d)) (oref this FOOOOOOOO))) + (call-next-method)) + +(defmethod ede-proj-makefile-insert-rules ((this ede-proj-target-makefile-program)) + "Insert rules needed by THIS target." + (let ((ede-proj-compiler-object-linkflags + (mapconcat 'identity (oref this ldflags) " "))) + (with-slots (ldlibs) this + (if ldlibs + (setq ede-proj-compiler-object-linkflags + (concat ede-proj-compiler-object-linkflags + " -l" + (mapconcat 'identity ldlibs " -l"))))) + (call-next-method))) + +(defmethod project-debug-target ((obj ede-proj-target-makefile-program)) + "Debug a program target OBJ." + (let ((tb (get-buffer-create " *padt*")) + (dd (if (not (string= (oref obj path) "")) + (oref obj path) + default-directory)) + (cmd nil)) + (unwind-protect + (progn + (set-buffer tb) + (setq default-directory dd) + (setq cmd (read-from-minibuffer + "Run (like this): " + (concat (symbol-name ede-debug-program-function) + " " (ede-target-name obj)))) + (funcall ede-debug-program-function cmd)) + (kill-buffer tb)))) + + +(provide 'ede/proj-prog) + +;;; ede/proj-prog.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj-scheme.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj-scheme.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,49 @@ +;;; ede/proj-scheme.el --- EDE Generic Project scheme (guile) support + +;;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: project, make, scheme + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Handle scheme (Guile) in and EDE Project file. +;; This is a specialized do nothing class. + +(require 'ede/proj) +(require 'ede/autoconf-edit) + +;;; Code: +(defclass ede-proj-target-scheme (ede-proj-target) + ((menu :initform nil) + (keybindings :initform nil) + (interpreter :initarg :interpreter + :initform "guile" + :type string + :custom string + :documentation "The preferred interpreter for this code.") + ) + "This target consists of scheme files.") + +(defmethod ede-proj-tweak-autoconf ((this ede-proj-target-scheme)) + "Tweak the configure file (current buffer) to accomodate THIS." + (autoconf-insert-new-macro "AM_INIT_GUILE_MODULE")) + +(provide 'ede/proj-scheme) + +;;; ede/proj-scheme.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj-shared.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj-shared.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,164 @@ +;;; ede-proj-shared.el --- EDE Generic Project shared library support + +;;; Copyright (C) 1998, 1999, 2000, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; Commentary: +;; +;; Handle shared object libraries in and EDE Project file. +;; Tries to deal with libtool and non-libtool situations. + +(require 'ede/pmake) +(require 'ede/proj-prog) + +;;; THIS NEEDS WORK. SEE ede-proj-obj. + +;;; Code: +(defclass ede-proj-target-makefile-shared-object + (ede-proj-target-makefile-program) + ((availablecompilers :initform (ede-gcc-shared-compiler + ede-gcc-libtool-shared-compiler + ede-g++-shared-compiler + ede-g++-libtool-shared-compiler + )) + (ldflags :custom (repeat (string :tag "Libtool flag")) + :documentation + "Additional flags to add when linking this shared library. +Use ldlibs to add addition libraries.") + ) + "This target generates a shared library.") + +(defvar ede-gcc-shared-compiler + (clone ede-gcc-compiler + "ede-c-shared-compiler" + :name "gcc -shared" + :variables '(("CC_SHARED" . "gcc") + ("C_SHARED_COMPILE" . + "$(CC_SHARED) -shared $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)")) +; :linkvariables '(("C_SHARED_LINK" . +; "$(CC_SHARED) -shared $(CFLAGS) $(LDFLAGS) -L. -o $@ $^") +; ) +; :commands '("$(C_SHARED_LINK) %s") + ;; @TODO - addative modification of autoconf. + :autoconf '("AC_PROG_LIBTOOL") + ) + "Compiler for C sourcecode.") + +(defvar ede-gcc-libtool-shared-compiler + (clone ede-gcc-shared-compiler + "ede-c-shared-compiler-libtool" + :name "libtool" + :variables '(("LIBTOOL" . "$(SHELL) libtool") + ("LTCOMPILE" . "$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)") + ("LTLINK" . "$(LIBTOOL) --mode=link $(CC) $(CFLAGS) $(LDFLAGS) -L. -o $@") + ) + :commands '("$(LTLINK) $^" + ) + :autoconf '("AC_PROG_LIBTOOL") + ) + "Compiler for C sourcecode.") + +(defvar ede-g++-shared-compiler + (clone ede-g++-compiler + "ede-c++-shared-compiler" + :name "gcc -shared" + :variables '(("CXX_SHARED" . "g++") + ("CXX_SHARED_COMPILE" . + "$(CXX_SHARED) -shared $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)")) + ;; @TODO - addative modification of autoconf. + :autoconf '("AC_PROG_LIBTOOL") + ) + "Compiler for C sourcecode.") + +(defvar ede-g++-libtool-shared-compiler + (clone ede-g++-shared-compiler + "ede-c++-shared-compiler-libtool" + :name "libtool" + :variables '(("CXX" "g++") + ("LIBTOOL" . "$(SHELL) libtool") + ("LTCOMPILE" . "$(LIBTOOL) --mode=compile $(CXX) $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS)") + ("LTLINK" . "$(LIBTOOL) --mode=link $(CXX) $(CFLAGS) $(LDFLAGS) -L. -o $@") + ) + :commands '("$(LTLINK) $^" + ) + :autoconf '("AC_PROG_LIBTOOL") + ) + "Compiler for C sourcecode.") + +;;; @TODO - C++ versions of the above. + +(when nil + + + (insert;; These C to O rules create dependencies + "%.o: %.c\n" + "\t@echo '$(COMPILE) -c $<'; \\\n" + "\t$(COMPILE)" + (if (oref this automatic-dependencies) + " -Wp,-MD,.deps/$(*F).P" + "") + " -c $<\n\n") + (if have-libtool + (insert;; These C to shared o rules create pic code. + "%.lo: %.c\n" + "\t@echo '$(LTCOMPILE) -c $<'; \\\n" + "\t$(LTCOMPILE) -Wp,-MD,.deps/$(*F).p -c $<\n" + "\t@-sed -e 's/^\([^:]*\)\.o:/\1.lo \1.o:/' \\\n" + "\t < .deps/$(*F).p > .deps/$(*F).P\n" + "\t@-rm -f .deps/$(*F).p\n\n")) + ) + +(defmethod ede-proj-configure-add-missing + ((this ede-proj-target-makefile-shared-object)) + "Query if any files needed by THIS provided by automake are missing. +Results in --add-missing being passed to automake." + (not (and (ede-expand-filename (ede-toplevel) "ltconfig") + (ede-expand-filename (ede-toplevel) "ltmain.sh")))) + +(defmethod ede-proj-makefile-insert-automake-pre-variables + ((this ede-proj-target-makefile-shared-object)) + "Insert bin_PROGRAMS variables needed by target THIS. +We aren't acutally inserting SOURCE details, but this is used by the +Makefile.am generator, so use it to add this important bin program." + (ede-pmake-insert-variable-shared "lib_LTLIBRARIES" + (insert (concat "lib" (ede-name this) ".la")))) + +(defmethod ede-proj-makefile-insert-automake-post-variables + ((this ede-proj-target-makefile-shared-object)) + "Insert bin_PROGRAMS variables needed by target THIS. +We need to override -program which has an LDADD element." + nil) + +(defmethod ede-proj-makefile-target-name ((this ede-proj-target-makefile-shared-object)) + "Return the name of the main target for THIS target." + ;; We need some platform gunk to make the .so change to .sl, or .a, + ;; depending on the platform we are going to compile against. + (concat "lib" (ede-name this) ".so")) + +(defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-makefile-shared-object)) + "Return the variable name for THIS's sources." + (if (eq (oref (ede-target-parent this) makefile-type) 'Makefile.am) + (concat "lib" (oref this name) "_la_SOURCES") + (call-next-method))) + + +(provide 'ede/proj-shared) + +;;; ede/proj-shared.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/proj.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/proj.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,675 @@ +;;; 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 +;; 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 . + +;;; 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)))) + + +;;; 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)) + +;;; 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))) + + +;;; 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. + ) + ) + + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/project-am.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/project-am.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,994 @@ +;;; project-am.el --- A project management scheme based on automake files. + +;;; Copyright (C) 1998, 1999, 2000, 2003, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Version: 0.0.3 +;; 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 . + +;;; Commentary: +;; +;; The GNU Automake tool is the first step towards having a really +;; good project management system. It provides a simple and concise +;; look at what is actually in a project, and records it in a simple +;; fashion. +;; +;; project-am uses the structure defined in all good GNU projects with +;; the Automake file as it's base template, and then maintains that +;; information during edits, automatically updating the automake file +;; where appropriate. + + +;; (eval-and-compile +;; ;; Compatibility for makefile mode. +;; (condition-case nil +;; (require 'makefile "make-mode") +;; (error (require 'make-mode "make-mode"))) + +;; ;; Requiring the .el files prevents incomplete builds. +;; (require 'eieio "eieio.el") +;; (require 'ede "ede.el")) + +(require 'make-mode) +(require 'ede) +(require 'ede/make) +(require 'ede/makefile-edit) + +(declare-function autoconf-parameters-for-macro "ede/autoconf-edit") +(eval-when-compile (require 'compile)) + +;;; Code: +(defgroup project-am nil + "File and tag browser frame." + :group 'tools + :group 'ede + ) + +(defcustom project-am-compile-project-command nil + "*Default command used to compile a project." + :group 'project-am + :type 'string) + +(defcustom project-am-compile-target-command (concat ede-make-command " -k %s") + "*Default command used to compile a project." + :group 'project-am + :type 'string) + +(defcustom project-am-debug-target-function 'gdb + "*Default Emacs command used to debug a target." + :group 'project-am + :type 'sexp) ; make this be a list some day + +(defconst project-am-type-alist + '(("bin" project-am-program "bin_PROGRAMS" t) + ("sbin" project-am-program "sbin_PROGRAMS" t) + ("noinstbin" project-am-program "noinst_PROGRAMS" t) + ("checkbin" project-am-program "check_PROGRAMS" t) + ("lib" project-am-lib "lib_LIBS" t) + ("libraries" project-am-lib "lib_LIBRARIES" t) + ("librariesnoinst" project-am-lib "noinst_LIBRARIES" t) + ("pkglibraries" project-am-lib "pkglib_LIBRARIES" t) + ("checklibs" project-am-lib "check_LIBRARIES" t) + ("ltlibraries" project-am-lib "lib_LTLIBRARIES" t) + ("ltlibrariesnoinst" project-am-lib "noinst_LTLIBRARIES" t) + ("pkgltlibraries" project-am-lib "pkglib_LTLIBRARIES" t) + ("checkltlibs" project-am-lib "check_LTLIBRARIES" t) + ("headernoinst" project-am-header-noinst "noinst_HEADERS") + ("headerinst" project-am-header-inst "include_HEADERS") + ("headerpkg" project-am-header-pkg "pkginclude_HEADERS") + ("headerpkg" project-am-header-chk "check_HEADERS") + ("texinfo" project-am-texinfo "info_TEXINFOS" t) + ("man" project-am-man "man_MANS") + ("lisp" project-am-lisp "lisp_LISP") + ;; for other global files track EXTRA_ + ("extrabin" project-am-program "EXTRA_PROGRAMS" t) + ("builtsrcs" project-am-built-src "BUILT_SOURCES") + ("extradist" project-am-extra-dist "EXTRA_DIST") + ;; Custom libraries targets? + ;; ("ltlibcustom" project-am-lib ".*?_LTLIBRARIES" t) + ) + "Alist of type names and the type of object to create for them. +Each entry is of th form: + (EMACSNAME CLASS AUToMAKEVAR INDIRECT) +where EMACSNAME is a name for Emacs to use. +CLASS is the EDE target class to represent the target. +AUTOMAKEVAR is the Automake variable to identify. This cannot be a + regular expression. +INDIRECT is optional. If it is non-nil, then the variable in +question lists other variables that need to be looked up.") + +(defclass project-am-target (ede-target) + nil + "Base target class for everything in project-am.") + +(defclass project-am-objectcode (project-am-target) + ((source :initarg :source :documentation "List of source files.")) + "A target which creates object code, like a C program or library.") + +(defclass project-am-program (project-am-objectcode) + ((ldadd :initarg :ldadd :documentation "Additional LD args." + :initform nil)) + "A top level program to build") + +(defclass project-am-header (project-am-target) + () + "A group of misc source files, such as headers.") + +(defclass project-am-header-noinst (project-am-header) + () + "A group of header files that are not installed.") + +(defclass project-am-header-inst (project-am-header) + () + "A group of header files that are not installed.") + +(defclass project-am-header-pkg (project-am-header) + () + "A group of header files that are not installed.") + +(defclass project-am-header-chk (project-am-header) + () + "A group of header files that are not installed.") + +(defclass project-am-lib (project-am-objectcode) + nil + "A top level library to build") + +(defclass project-am-lisp (project-am-target) + () + "A group of Emacs Lisp programs to byte compile.") + +(defclass project-am-texinfo (project-am-target) + ((include :initarg :include + :initform nil + :documentation "Additional texinfo included in this one.")) + "A top level texinfo file to build.") + +(defclass project-am-man (project-am-target) + nil + "A top level man file to build.") + +;; For generic files tracker like EXTRA_DIST +(defclass project-am-built-src (project-am-target) + () + "A group of Emacs Lisp programs to byte compile.") + +(defclass project-am-extra-dist (project-am-target) + () + "A group of Emacs Lisp programs to byte compile.") + +(defclass project-am-makefile (ede-project) + ((targets :initarg :targets + :initform nil + :documentation "Top level targets in this makefile.") + (configureoutputfiles + :initform nil + :documentation + "List of files output from configure system.") + ) + "Encode one makefile.") + +;;; Code: +(defmethod project-add-file ((ot project-am-target)) + "Add the current buffer into a project. +OT is the object target. DIR is the directory to start in." + (let* ((target (if ede-object (error "Already assocated w/ a target") + (let ((amf (project-am-load default-directory))) + (if (not amf) (error "No project file")) + (completing-read "Target: " + (object-assoc-list 'name + (oref amf targets)) + nil t)))) + ;; The input target might be new. See if we can find it. + (amf (ede-load-project-file (oref ot path))) + (ot (object-assoc target 'name (oref amf targets))) + (ofn (file-name-nondirectory (buffer-file-name)))) + (if (not ot) + (setq ot + (project-new-target + target (project-am-preferred-target-type (buffer-file-name))))) + (ede-with-projectfile ot + (makefile-move-to-macro (project-am-macro ot)) + (ede-maybe-checkout) + (makefile-end-of-command) + (insert " " ofn) + (makefile-fill-paragraph nil) + (project-rescan ot) + (save-buffer)) + (setq ede-object ot))) + +(defmethod project-remove-file ((ot project-am-target) fnnd) + "Remove the current buffer from any project targets." + (ede-with-projectfile ot + (makefile-move-to-macro (project-am-macro ot)) + (if (and buffer-read-only vc-mode + (y-or-n-p "Checkout Makefile.am from VC? ")) + (vc-toggle-read-only t)) + (ede-maybe-checkout) + (makefile-navigate-macro (concat " *" (regexp-quote (ede-name fnnd)))) + (replace-match "" t t nil 0) + (makefile-fill-paragraph nil) + (project-rescan ot) + (save-buffer)) + (setq ede-object nil)) + +(defmethod project-edit-file-target ((obj project-am-target)) + "Edit the target associated w/ this file." + (find-file (concat (oref obj path) "Makefile.am")) + (goto-char (point-min)) + (makefile-move-to-macro (project-am-macro obj)) + (if (= (point-min) (point)) + (re-search-forward (ede-target-name obj)))) + +(defmethod project-new-target ((proj project-am-makefile) + &optional name type) + "Create a new target named NAME. +Argument TYPE is the type of target to insert. This is a string +matching something in `project-am-type-alist' or type class symbol. +Despite the fact that this is a method, it depends on the current +buffer being in order to provide a smart default target type." + (let* ((name (or name (read-string "Name: " ""))) + (type (or type + (completing-read "Type: " + project-am-type-alist + nil t + (cond ((eq major-mode 'texinfo-mode) + "texinfo") + ((eq major-mode 'nroff-mode) + "man") + ((eq major-mode 'emacs-lisp-mode) + "lisp") + (t "bin"))))) + (ntype (assoc type project-am-type-alist)) + (ot nil)) + (setq ot (apply (car (cdr ntype)) name :name name + :path (expand-file-name default-directory) nil)) + (if (not ot) (error "Error creating target object %S" ntype)) + (ede-with-projectfile ot + (goto-char (point-min)) + (ede-maybe-checkout) + (makefile-next-dependency) + (if (= (point) (point-min)) + (goto-char (point-max)) + (beginning-of-line) + (insert "\n") + (forward-char -1)) + ;; Add the new target sources macro (if needed) + (if (project-am-macro ot) + (makefile-insert-macro (project-am-macro ot))) + ;; Add to the list of objects. + (goto-char (point-min)) + (makefile-move-to-macro (car (cdr (cdr ntype)))) + (if (= (point) (point-min)) + (progn + (if (re-search-forward makefile-macroassign-regex nil t) + (progn (forward-line -1) + (end-of-line) + (insert "\n")) + ;; If the above search fails, thats ok. We'd just want to be at + ;; point-min anyway. + ) + (makefile-insert-macro (car (cdr (cdr ntype)))))) + (makefile-end-of-command) + (insert " " (ede-target-name ot)) + (save-buffer) + ;; Rescan the object in this makefile. + (project-rescan ede-object)))) + +;(defun project-am-rescan-toplevel () +; "Rescan all projects in which the current buffer resides." +; (interactive) +; (let* ((tlof (project-am-find-topmost-level default-directory)) +; (tlo (project-am-load tlof)) +; (ede-deep-rescan t)) ; scan deep in this case. +; ;; tlo is the top level object for whatever file we are in +; ;; or nil. If we have an object, call the rescan method. +; (if tlo (project-am-rescan tlo)))) + +;; +;; NOTE TO SELF +;; +;; This should be handled at the EDE level, calling a method of the +;; top most project. +;; +(defmethod project-compile-project ((obj project-am-target) &optional command) + "Compile the entire current project. +Argument COMMAND is the command to use when compiling." + (require 'compile) + (if (not command) + (setq + command + ;; This interactive statement was taken from compile, and I'll + ;; use the same command history too. + (progn + (if (not project-am-compile-project-command) + (setq project-am-compile-project-command compile-command)) + (if (or compilation-read-command current-prefix-arg) + (read-from-minibuffer "Project compile command: " + ;; hardcode make -k + ;; This is compile project after all. + project-am-compile-project-command + nil nil '(compile-history . 1)) + project-am-compile-project-command)))) + ;; When compile a project, we might be in a subdirectory, + ;; so we have to make sure we move all the way to the top. + (let* ((default-directory (project-am-find-topmost-level default-directory))) + (compile command))) + +(defmethod project-compile-project ((obj project-am-makefile) + &optional command) + "Compile the entire current project. +Argument COMMAND is the command to use when compiling." + (require 'compile) + (if (not command) + (setq + command + ;; This interactive statement was taken from compile, and I'll + ;; use the same command history too. + (progn + (if (not project-am-compile-project-command) + (setq project-am-compile-project-command compile-command)) + (if (or compilation-read-command current-prefix-arg) + (read-from-minibuffer "Project compile command: " + ;; hardcode make -k + ;; This is compile project after all. + project-am-compile-project-command + nil nil '(compile-history . 1)) + project-am-compile-project-command)))) + ;; When compile a project, we might be in a subdirectory, + ;; so we have to make sure we move all the way to the top. + (let* ((default-directory (project-am-find-topmost-level default-directory))) + (compile command))) + +(defmethod project-compile-target ((obj project-am-target) &optional command) + "Compile the current target. +Argument COMMAND is the command to use for compiling the target." + (require 'compile) + (if (not project-am-compile-project-command) + (setq project-am-compile-project-command compile-command)) + (if (not command) + (setq + command + (if compilation-read-command + (read-from-minibuffer "Project compile command: " + ;; hardcode make -k + ;; This is compile project after all. + (if ede-object + (format + project-am-compile-target-command + (project-compile-target-command + ede-object)) + project-am-compile-target-command) + nil nil + '(compile-history . 1)) + (if ede-object + project-am-compile-project-command + (format + project-am-compile-target-command + (project-compile-target-command ede-object)))))) + ;; We better be in the right place when compiling a specific target. + (compile command)) + +(defmethod project-debug-target ((obj project-am-objectcode)) + "Run the current project target in a debugger." + (let ((tb (get-buffer-create " *padt*")) + (dd (oref obj path)) + (cmd nil)) + (unwind-protect + (progn + (set-buffer tb) + (setq default-directory dd) + (setq cmd (read-from-minibuffer + "Run (like this): " + (concat (symbol-name project-am-debug-target-function) + " " (ede-target-name obj)))) + (funcall project-am-debug-target-function cmd)) + (kill-buffer tb)))) + +(defmethod project-make-dist ((this project-am-target)) + "Run the current project in the debugger." + (require 'compile) + (if (not project-am-compile-project-command) + (setq project-am-compile-project-command compile-command)) + (project-compile-project this (concat project-am-compile-project-command + " dist"))) + +;;; Project loading and saving +;; +(defun project-am-load (project &optional rootproj) + "Read an automakefile PROJECT into our data structure. +Make sure that the tree down to our makefile is complete so that there +is cohesion in the project. Return the project file (or sub-project). +If a given set of projects has already been loaded, then do nothing +but return the project for the directory given. +Optional ROOTPROJ is the root EDE project." + ;; @TODO - rationalize this to the newer EDE way of doing things. + (setq project (expand-file-name project)) + (let* ((ede-constructing t) + (fn (project-am-find-topmost-level (file-name-as-directory project))) + (amo nil) + (trimmed (if (string-match (regexp-quote fn) + project) + (replace-match "" t t project) + "")) + (subdir nil)) + (setq amo (object-assoc (expand-file-name "Makefile.am" fn) + 'file ede-projects)) + (if amo + (error "Synchronous error in ede/project-am objects") + (let ((project-am-constructing t)) + (setq amo (project-am-load-makefile fn)))) + (if (not amo) + nil + ;; Now scan down from amo, and find the current directory + ;; from the PROJECT file. + (while (< 0 (length trimmed)) + (if (string-match "\\([a-zA-Z0-9.-]+\\)/" trimmed) + (setq subdir (match-string 0 trimmed) + trimmed (replace-match "" t t trimmed)) + (error "Error scanning down path for project")) + (setq amo (project-am-subtree + amo + (expand-file-name "Makefile.am" + (expand-file-name subdir fn))) + fn (expand-file-name subdir fn))) + amo) + )) + +(defun project-am-find-topmost-level (dir) + "Find the topmost automakefile starting with DIR." + (let ((newdir dir)) + (while (or (file-exists-p (concat newdir "Makefile.am")) + (file-exists-p (concat newdir "configure.ac")) + (file-exists-p (concat newdir "configure.in")) + ) + (setq dir newdir newdir + (file-name-directory (directory-file-name newdir)))) + (expand-file-name dir))) + +(defmacro project-am-with-makefile-current (dir &rest forms) + "Set the Makefile.am in DIR to be the current buffer. +Run FORMS while the makefile is current. +Kill the makefile if it was not loaded before the load." + `(let* ((fn (expand-file-name "Makefile.am" ,dir)) + (fb nil) + (kb (get-file-buffer fn))) + (if (not (file-exists-p fn)) + nil + (save-excursion + (if kb (setq fb kb) + ;; We need to find-file this thing, but don't use + ;; any semantic features. + (let ((semantic-init-hook nil)) + (setq fb (find-file-noselect fn))) + ) + (set-buffer fb) + (prog1 ,@forms + (if (not kb) (kill-buffer (current-buffer)))))))) +(put 'project-am-with-makefile-current 'lisp-indent-function 1) + +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec project-am-with-makefile-current + (form def-body)))) + + +(defun project-am-load-makefile (path) + "Convert PATH into a project Makefile, and return its project object. +It does not check for existing project objects. Use `project-am-load'." + (project-am-with-makefile-current path + (if (and ede-object (project-am-makefile-p ede-object)) + ede-object + (let* ((pi (project-am-package-info path)) + (pn (or (nth 0 pi) (project-am-last-dir fn))) + (ver (or (nth 1 pi) "0.0")) + (bug (nth 2 pi)) + (cof (nth 3 pi)) + (ampf (project-am-makefile + pn :name pn + :version ver + :mailinglist (or bug "") + :file fn))) + (oset ampf :directory (file-name-directory fn)) + (oset ampf configureoutputfiles cof) + (make-local-variable 'ede-object) + (setq ede-object ampf) + ;; Move the rescan after we set ede-object to prevent recursion + (project-rescan ampf) + ampf)))) + +;;; Methods: +(defmethod ede-find-target ((amf project-am-makefile) buffer) + "Fetch the target belonging to BUFFER." + (or (call-next-method) + (let ((targ (oref amf targets)) + (sobj (oref amf subproj)) + (obj nil)) + (while (and targ (not obj)) + (if (ede-buffer-mine (car targ) buffer) + (setq obj (car targ))) + (setq targ (cdr targ))) + (while (and sobj (not obj)) + (setq obj (project-am-buffer-object (car sobj) buffer) + sobj (cdr sobj))) + obj))) + +(defmethod project-targets-for-file ((proj project-am-makefile)) + "Return a list of targets the project PROJ." + (oref proj targets)) + +(defun project-am-scan-for-targets (currproj dir) + "Scan the current Makefile.am for targets. +CURRPROJ is the current project being scanned. +DIR is the directory to apply to new targets." + (let* ((otargets (oref currproj targets)) + (ntargets nil) + (tmp nil) + ) + (mapc + ;; Map all the different types + (lambda (typecar) + (let ((macro (nth 2 typecar)) + (class (nth 1 typecar)) + (indirect (nth 3 typecar)) + ;(name (car typecar)) + ) + (if indirect + ;; Map all the found objects + (mapc (lambda (lstcar) + (setq tmp (object-assoc lstcar 'name otargets)) + (when (not tmp) + (setq tmp (apply class lstcar :name lstcar + :path dir nil))) + (project-rescan tmp) + (setq ntargets (cons tmp ntargets))) + (makefile-macro-file-list macro)) + ;; Non-indirect will have a target whos sources + ;; are actual files, not names of other targets. + (let ((files (makefile-macro-file-list macro))) + (when files + (setq tmp (object-assoc macro 'name otargets)) + (when (not tmp) + (setq tmp (apply class macro :name macro + :path dir nil))) + (project-rescan tmp) + (setq ntargets (cons tmp ntargets)) + )) + ) + )) + project-am-type-alist) + ntargets)) + +(defmethod project-rescan ((this project-am-makefile)) + "Rescan the makefile for all targets and sub targets." + (project-am-with-makefile-current (file-name-directory (oref this file)) + ;;(message "Scanning %s..." (oref this file)) + (let* ((pi (project-am-package-info (oref this directory))) + (pn (nth 0 pi)) + (pv (nth 1 pi)) + (bug (nth 2 pi)) + (cof (nth 3 pi)) + (osubproj (oref this subproj)) + (csubproj (or + ;; If DIST_SUBDIRS doesn't exist, then go for the + ;; static list of SUBDIRS. The DIST version should + ;; contain SUBDIRS plus extra stuff. + (makefile-macro-file-list "DIST_SUBDIRS") + (makefile-macro-file-list "SUBDIRS"))) + (csubprojexpanded nil) + (nsubproj nil) + ;; Targets are excluded here because they require + ;; special attention. + (dir (expand-file-name default-directory)) + (tmp nil) + (ntargets (project-am-scan-for-targets this dir)) + ) + + (and pn (string= (directory-file-name + (oref this directory)) + (directory-file-name + (project-am-find-topmost-level + (oref this directory)))) + (oset this name pn) + (and pv (oset this version pv)) + (and bug (oset this mailinglist bug)) + (oset this configureoutputfiles cof)) + +; ;; LISP is different. Here there is only one kind of lisp (that I know of +; ;; anyway) so it doesn't get mapped when it is found. +; (if (makefile-move-to-macro "lisp_LISP") +; (let ((tmp (project-am-lisp "lisp" +; :name "lisp" +; :path dir))) +; (project-rescan tmp) +; (setq ntargets (cons tmp ntargets)))) +; + ;; Now that we have this new list, chuck the old targets + ;; and replace it with the new list of targets I just created. + (oset this targets (nreverse ntargets)) + ;; We still have a list of targets. For all buffers, make sure + ;; their object still exists! + + ;; FIGURE THIS OUT + + (mapc (lambda (sp) + (let ((var (makefile-extract-varname-from-text sp)) + ) + (if (not var) + (setq csubprojexpanded (cons sp csubprojexpanded)) + ;; If it is a variable, expand that variable, and keep going. + (let ((varexp (makefile-macro-file-list var))) + (dolist (V varexp) + (setq csubprojexpanded (cons V csubprojexpanded))))) + )) + csubproj) + + ;; Ok, now lets look at all our sub-projects. + (mapc (lambda (sp) + (let* ((subdir (file-name-as-directory + (expand-file-name + sp (file-name-directory (oref this :file))))) + (submake (expand-file-name + "Makefile.am" + subdir))) + (if (string= submake (oref this :file)) + nil ;; don't recurse.. please! + + ;; For each project id found, see if we need to recycle, + ;; and if we do not, then make a new one. Check the deep + ;; rescan value for behavior patterns. + (setq tmp (object-assoc + submake + 'file osubproj)) + (if (not tmp) + (setq tmp + (condition-case nil + ;; In case of problem, ignore it. + (project-am-load-makefile subdir) + (error nil))) + ;; If we have tmp, then rescan it only if deep mode. + (if ede-deep-rescan + (project-rescan tmp))) + ;; Tac tmp onto our list of things to keep, but only + ;; if tmp was found. + (when tmp + ;;(message "Adding %S" (object-print tmp)) + (setq nsubproj (cons tmp nsubproj))))) + ) + (nreverse csubprojexpanded)) + (oset this subproj nsubproj) + ;; All elements should be updated now. + ))) + + +(defmethod project-rescan ((this project-am-program)) + "Rescan object THIS." + (oset this :source (makefile-macro-file-list (project-am-macro this))) + (oset this :ldadd (makefile-macro-file-list + (concat (oref this :name) "_LDADD")))) + +(defmethod project-rescan ((this project-am-lib)) + "Rescan object THIS." + (oset this :source (makefile-macro-file-list (project-am-macro this)))) + +(defmethod project-rescan ((this project-am-texinfo)) + "Rescan object THIS." + (oset this :include (makefile-macro-file-list (project-am-macro this)))) + +(defmethod project-rescan ((this project-am-man)) + "Rescan object THIS." + (oset this :source (makefile-macro-file-list (project-am-macro this)))) + +(defmethod project-rescan ((this project-am-lisp)) + "Rescan the lisp sources." + (oset this :source (makefile-macro-file-list (project-am-macro this)))) + +(defmethod project-rescan ((this project-am-header)) + "Rescan the Header sources for object THIS." + (oset this :source (makefile-macro-file-list (project-am-macro this)))) + +(defmethod project-rescan ((this project-am-built-src)) + "Rescan built sources for object THIS." + (oset this :source (makefile-macro-file-list "BUILT_SOURCES"))) + +(defmethod project-rescan ((this project-am-extra-dist)) + "Rescan object THIS." + (oset this :source (makefile-macro-file-list "EXTRA_DIST"))) + ;; NOTE: The below calls 'file' then checks that it is some sort of + ;; text file. The file command may not be available on all platforms + ;; and some files may not exist yet. (ie - auto-generated) + + ;;(mapc + ;; (lambda (f) + ;; ;; prevent garbage to be parsed, could we use :aux ? + ;; (if (and (not (member f (oref this :source))) + ;; (string-match-p "ASCII\\|text" + ;; (shell-command-to-string + ;; (concat "file " f)))) + ;; (oset this :source (cons f (oref this :source))))) + ;; (makefile-macro-file-list "EXTRA_DIST"))) + +(defmethod project-am-macro ((this project-am-objectcode)) + "Return the default macro to 'edit' for this object type." + (concat (subst-char-in-string ?- ?_ (oref this :name)) "_SOURCES")) + +(defmethod project-am-macro ((this project-am-header-noinst)) + "Return the default macro to 'edit' for this object." + "noinst_HEADERS") + +(defmethod project-am-macro ((this project-am-header-inst)) + "Return the default macro to 'edit' for this object." + "include_HEADERS") + +(defmethod project-am-macro ((this project-am-header-pkg)) + "Return the default macro to 'edit' for this object." + "pkginclude_HEADERS") + +(defmethod project-am-macro ((this project-am-header-chk)) + "Return the default macro to 'edit' for this object." + "check_HEADERS") + +(defmethod project-am-macro ((this project-am-texinfo)) + "Return the default macro to 'edit' for this object type." + (concat (file-name-sans-extension (oref this :name)) "_TEXINFOS")) + +(defmethod project-am-macro ((this project-am-man)) + "Return the default macro to 'edit' for this object type." + (oref this :name)) + +(defmethod project-am-macro ((this project-am-lisp)) + "Return the default macro to 'edit' for this object." + "lisp_LISP") + +(defun project-am-buffer-object (amf buffer) + "Return an object starting with AMF associated with BUFFER. +nil means that this buffer belongs to no-one." + (if (not amf) + nil + (if (ede-buffer-mine amf buffer) + amf + (let ((targ (oref amf targets)) + (sobj (oref amf subproj)) + (obj nil)) + (while (and targ (not obj)) + (if (ede-buffer-mine (car targ) buffer) + (setq obj (car targ))) + (setq targ (cdr targ))) + (while (and sobj (not obj)) + (setq obj (project-am-buffer-object (car sobj) buffer) + sobj (cdr sobj))) + obj)))) + +(defmethod ede-buffer-mine ((this project-am-makefile) buffer) + "Return t if object THIS lays claim to the file in BUFFER." + (let ((efn (expand-file-name (buffer-file-name buffer)))) + (or (string= (oref this :file) efn) + (string-match "/configure\\.ac$" efn) + (string-match "/configure\\.in$" efn) + (string-match "/configure$" efn) + ;; Search output files. + (let ((ans nil)) + (dolist (f (oref this configureoutputfiles)) + (when (string-match (concat (regexp-quote f) "$") efn) + (setq ans t))) + ans) + ))) + +(defmethod ede-buffer-mine ((this project-am-objectcode) buffer) + "Return t if object THIS lays claim to the file in BUFFER." + (member (file-name-nondirectory (buffer-file-name buffer)) + (oref this :source))) + +(defmethod ede-buffer-mine ((this project-am-texinfo) buffer) + "Return t if object THIS lays claim to the file in BUFFER." + (let ((bfn (buffer-file-name buffer))) + (or (string= (oref this :name) (file-name-nondirectory bfn)) + (member (file-name-nondirectory bfn) (oref this :include))))) + +(defmethod ede-buffer-mine ((this project-am-man) buffer) + "Return t if object THIS lays claim to the file in BUFFER." + (string= (oref this :name) (buffer-file-name buffer))) + +(defmethod ede-buffer-mine ((this project-am-lisp) buffer) + "Return t if object THIS lays claim to the file in BUFFER." + (member (file-name-nondirectory (buffer-file-name buffer)) + (oref this :source))) + +(defmethod project-am-subtree ((ampf project-am-makefile) subdir) + "Return the sub project in AMPF specified by SUBDIR." + (object-assoc (expand-file-name subdir) 'file (oref ampf subproj))) + +(defmethod project-compile-target-command ((this project-am-target)) + "Default target to use when compiling a given target." + ;; This is a pretty good default for most. + "") + +(defmethod project-compile-target-command ((this project-am-objectcode)) + "Default target to use when compiling an object code target." + (oref this :name)) + +(defmethod project-compile-target-command ((this project-am-texinfo)) + "Default target t- use when compling a texinfo file." + (let ((n (oref this :name))) + (if (string-match "\\.texi?\\(nfo\\)?" n) + (setq n (replace-match ".info" t t n))) + n)) + + +;;; Generic useful functions + +(defun project-am-last-dir (file) + "Return the last part of a directory name. +Argument FILE is the file to extract the end directory name from." + (let* ((s (file-name-directory file)) + (d (directory-file-name s)) + ) + (file-name-nondirectory d)) + ) + +(defun project-am-preferred-target-type (file) + "For FILE, return the preferred type for that file." + (cond ((string-match "\\.texi?\\(nfo\\)$" file) + project-am-texinfo) + ((string-match "\\.[0-9]$" file) + project-am-man) + ((string-match "\\.el$" file) + project-am-lisp) + (t + project-am-program))) + +(defmethod ede-buffer-header-file((this project-am-objectcode) buffer) + "There are no default header files." + (or (call-next-method) + (let ((s (oref this source)) + (found nil)) + (while (and s (not found)) + ;; Add more logic here if applicable. + (if (string-match "\\.\\(h\\|H\\|hh\\|hpp\\)" (car s)) + (setq found (car s))) + (setq s (cdr s))) + found))) + +(defmethod ede-documentation ((this project-am-texinfo)) + "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* ((src (append (oref this source) + (oref this include))) + (proj (ede-target-parent this)) + (dir (oref proj directory)) + (out nil)) + ;; Loop over all entries and expand + (while src + (setq out (cons + (expand-file-name (car src) dir) + out)) + (setq src (cdr src))) + ;; return it + out)) + + +;;; Configure.in queries. +;; +(defvar project-am-autoconf-file-options + '("configure.in" "configure.ac") + "List of possible configure files to look in for project info.") + +(defun project-am-autoconf-file (dir) + "Return the name of the autoconf file to use in DIR." + (let ((ans nil)) + (dolist (L project-am-autoconf-file-options) + (when (file-exists-p (expand-file-name L dir)) + (setq ans (expand-file-name L dir)))) + ans)) + +(defmacro project-am-with-config-current (file &rest forms) + "Set the Configure FILE in the top most directory above DIR as current. +Run FORMS in the configure file. +Kill the Configure buffer if it was not already in a buffer." + `(save-excursion + (let ((fb (generate-new-buffer ,file))) + (set-buffer fb) + (erase-buffer) + (insert-file-contents ,file) + (prog1 ,@forms + (kill-buffer fb))))) + +(put 'project-am-with-config-current 'lisp-indent-function 1) + +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec project-am-with-config-current + (form def-body)))) + +(defmacro project-am-extract-shell-variable (var) + "Extract the value of the shell variable VAR from a shell script." + (save-excursion + (goto-char (point-min)) + (when (re-search-forward (concat "^" (regexp-quote var) "\\s-*=\\s-*") + nil t) + (buffer-substring-no-properties (point) (point-at-eol))))) + +(defun project-am-extract-package-info (dir) + "Extract the package information for directory DIR." + (let ((conf-in (project-am-autoconf-file dir)) + (conf-sh (expand-file-name "configure" dir)) + (name (file-name-nondirectory + (directory-file-name dir))) + (ver "1.0") + (bugrep nil) + (configfiles nil) + ) + (cond + ;; Try configure.in or configure.ac + (conf-in + (require 'ede/autoconf-edit) + (project-am-with-config-current conf-in + (let ((aci (autoconf-parameters-for-macro "AC_INIT")) + (aia (autoconf-parameters-for-macro "AM_INIT_AUTOMAKE")) + (acf (autoconf-parameters-for-macro "AC_CONFIG_FILES")) + (aco (autoconf-parameters-for-macro "AC_OUTPUT")) + ) + (cond + ;; AC init has more than 1 parameter + ((> (length aci) 1) + (setq name (nth 0 aci) + ver (nth 1 aci) + bugrep (nth 2 aci))) + ;; The init automake has more than 1 parameter + ((> (length aia) 1) + (setq name (nth 0 aia) + ver (nth 1 aia) + bugrep (nth 2 aia))) + ) + ;; AC_CONFIG_FILES, or AC_OUTPUT lists everything that + ;; should be detected as part of this PROJECT, but not in a + ;; particular TARGET. + (let ((outfiles (cond (aco (list (car aco))) + (t acf)))) + (if (> (length outfiles) 1) + (setq configfiles outfiles) + (setq configfiles (split-string (car outfiles) " " t))) + ) + )) + ) + ;; Else, try the script + ((file-exists-p conf-sh) + (project-am-with-config-current conf-sh + (setq name (project-am-extract-shell-variable "PACKAGE_NAME") + ver (project-am-extract-shell-variable "PACKAGE_VERSION") + ) + )) + ;; Don't know what else.... + (t + nil)) + ;; Return stuff + (list name ver bugrep configfiles) + )) + +(defun project-am-package-info (dir) + "Get the package information for directory topmost project dir over DIR. +Calcultes the info with `project-am-extract-package-info'." + (let ((top (ede-toplevel))) + (when top (setq dir (oref top :directory))) + (project-am-extract-package-info dir))) + +(provide 'ede/project-am) + +;;; ede/project-am.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/simple.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/simple.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,108 @@ +;;; ede/simple.el --- Overlay an EDE structure on an existing project + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; A vast majority of projects use non-EDE project techniques, such +;; as hand written Makefiles, or other IDE's. +;; +;; The EDE-SIMPLE project type allows EDE to wrap an existing mechanism +;; with minimal configuration, and then provides project-root +;; information to Semantic or other tools, and also provides structure +;; information for in-project include header discovery, or speedbar +;; support. +;; +;; It will also support a the minimal EDE UI for compilation and +;; configuration. + +;; @todo - Add support for cpp-root as an ede-simple project. +;; @todo - Allow ede-simple to store locally. + +(require 'ede) +(require 'cedet-files) + +;;; Code: + +(defcustom ede-simple-save-directory "~/.ede" + "*Directory where simple EDE project overlays are saved." + :group 'ede + :type 'directory) + +(defcustom ede-simple-save-file-name "ProjSimple.ede" + "*File name used for simple project wrappers." + :group 'ede + :type 'string) + +(defun ede-simple-projectfile-for-dir (&optional dir) + "Return a full file name to the project file stored in the current directory. +The directory has three parts: + //ProjSimple.ede" + (let ((d (or dir default-directory))) + (concat + ;; Storage root + (file-name-as-directory (expand-file-name ede-simple-save-directory)) + ;; Convert directory to filename + (cedet-directory-name-to-file-name d) + ;; Filename + ede-simple-save-file-name) + )) + +(defun ede-simple-load (dir &optional rootproj) + "Load a project of type `Simple' for the directory DIR. +Return nil if there isn't one. +ROOTPROJ is nil, since we will only create a single EDE project here." + (let ((pf (ede-simple-projectfile-for-dir dir)) + (obj nil)) + (when pf + (setq obj (eieio-persistent-read pf)) + (oset obj :directory dir) + ) + obj)) + +(defclass ede-simple-target (ede-target) + () + "EDE Simple project target. +All directories need at least one target.") + +(defclass ede-simple-project (ede-project eieio-persistent) + ((extension :initform ".ede") + (file-header-line :initform ";; EDE Simple Project") + ) + "EDE Simple project class. +Each directory needs a a project file to control it.") + +(defmethod ede-commit-project ((proj ede-simple-project)) + "Commit any change to PROJ to its file." + (when (not (file-exists-p ede-simple-save-directory)) + (if (y-or-n-p (concat ede-simple-save-directory + " doesn't exist. Create? ")) + (make-directory ede-simple-save-directory) + (error "No save directory for new project"))) + (eieio-persistent-save proj)) + +(defmethod ede-find-subproject-for-directory ((proj ede-simple-project) + dir) + "Return PROJ, for handling all subdirs below DIR." + proj) + +(provide 'ede/simple) + +;;; ede/simple.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/source.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/source.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,170 @@ +;; ede/source.el --- EDE source code object + +;;; Copyright (C) 2000, 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; Commentary: + +;; Manage different types of source code. A master list of source code types +;; will be maintained, and used to track target objects, what they accept, +;; and what compilers can be used. + +(require 'eieio-base) + +;;; Code: +(defclass ede-sourcecode (eieio-instance-inheritor) + ((name :initarg :name + :type string + :documentation + "The name of this type of source code. +Such as \"C\" or \"Emacs Lisp\"") + (sourcepattern :initarg :sourcepattern + :initform ".*" + :type string + :documentation + "Emacs regexp matching sourcecode this target accepts.") + (auxsourcepattern :initarg :auxsourcepattern + :initform nil + :type (or null string) + :documentation + "Emacs regexp matching auxiliary source code this target accepts. +Aux source are source code files needed for compilation, which are not compiled +themselves.") + (enable-subdirectories :initarg :enable-subdirectories + :initform nil + :type boolean + :documentation + "Non nil if this sourcecode type uses subdirectories. +If sourcecode always lives near the target creating it, this should be nil. +If sourcecode can, or typically lives in a subdirectory of the owning +target, set this to t.") + (garbagepattern :initarg :garbagepattern + :initform nil + :type list + :documentation + "Shell file regexp matching files considered as garbage. +This is a list of items added to an `rm' command when executing a `clean' +type directive.") + ) + "Description of some type of source code. +Objects will use sourcecode objects to define the types of source +that they are willing to use.") + +(defvar ede-sourcecode-list nil + "The master list of all EDE compilers.") + +;;; Methods +;; +(defmethod initialize-instance :AFTER ((this ede-sourcecode) &rest fields) + "Make sure that all ede compiler objects are cached in +`ede-compiler-list'." + (let ((lst ede-sourcecode-list)) + ;; Find an object of the same name. + (while (and lst (not (string= (oref this name) (oref (car lst) name)))) + (setq lst (cdr lst))) + (if lst + ;; Replace old definition + (setcar lst this) + ;; Add to the beginning of the list. + (setq ede-sourcecode-list (cons this ede-sourcecode-list))))) + +(defmethod ede-want-file-p ((this ede-sourcecode) filename) + "Return non-nil if sourcecode definition THIS will take FILENAME." + (or (ede-want-file-source-p this filename) + (ede-want-file-auxiliary-p this filename))) + +(defmethod ede-want-file-source-p ((this ede-sourcecode) filename) + "Return non-nil if THIS will take FILENAME as an auxiliary ." + (let ((case-fold-search nil)) + (string-match (oref this sourcepattern) filename))) + +(defmethod ede-want-file-auxiliary-p ((this ede-sourcecode) filename) + "Return non-nil if THIS will take FILENAME as an auxiliary ." + (let ((case-fold-search nil)) + (and (slot-boundp this 'auxsourcepattern) + (oref this auxsourcepattern) + (string-match (oref this auxsourcepattern) filename)))) + +(defmethod ede-want-any-source-files-p ((this ede-sourcecode) filenames) + "Return non-nil if THIS will accept any source files in FILENAMES." + (let (found) + (while (and (not found) filenames) + (setq found (ede-want-file-source-p this (pop filenames)))))) + +(defmethod ede-want-any-auxiliary-files-p ((this ede-sourcecode) filenames) + "Return non-nil if THIS will accept any aux files in FILENAMES." + (let (found) + (while (and (not found) filenames) + (setq found (ede-want-file-auxiliary-p this (pop filenames)))))) + +(defmethod ede-want-any-files-p ((this ede-sourcecode) filenames) + "Return non-nil if THIS will accept any files in FILENAMES." + (let (found) + (while (and (not found) filenames) + (setq found (ede-want-file-p this (pop filenames)))))) + +(defmethod ede-buffer-header-file ((this ede-sourcecode) filename) + "Return a list of file names of header files for THIS with FILENAME. +Used to guess header files, but uses the auxsource regular expression." + (let ((dn (file-name-directory filename)) + (ts (file-name-sans-extension (file-name-nondirectory filename))) + (ae (oref this auxsourcepattern))) + (if (not ae) + nil + (directory-files dn t (concat (regexp-quote ts) ae))))) + +;;; Utility functions +;; +(when nil + ;; not used at the moment. +(defun ede-source-find (name) + "Find the sourcecode object based on NAME." + (object-assoc name :name ede-sourcecode-list)) + +(defun ede-source-match (file) + "Find the list of soucecode objects which matches FILE." + (let ((lst ede-sourcecode-list) + (match nil)) + (while lst + ;; ede-file-mine doesn't exist yet + (if (ede-file-mine (car lst) file) + (setq match (cons (car lst) match))) + (setq lst (cdr lst))) + match)) +) +;;; Master list of source code types +;; +;; This must appear at the end so that the init method will work. +(defvar ede-source-scheme + (ede-sourcecode "ede-source-scheme" + :name "Scheme" + :sourcepattern "\\.scm$") + "Scheme source code definition.") + +;;(defvar ede-source- +;; (ede-sourcecode "ede-source-" +;; :name "" +;; :sourcepattern "\\.$" +;; :garbagepattern '("*.")) +;; " source code definition.") + +(provide 'ede/source) + +;;; ede/source.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/speedbar.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/speedbar.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,360 @@ +;;; ede/speedbar.el --- Speedbar viewing of EDE projects + +;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: project, make, tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Display a project's hierarchy in speedbar. +;; + +;;; Code: +(require 'speedbar) +(require 'eieio-speedbar) +(require 'ede) + +;;; Speedbar support mode +;; +(defvar ede-speedbar-key-map nil + "A Generic object based speedbar display keymap.") + +(defun ede-speedbar-make-map () + "Make the generic object based speedbar keymap." + (setq ede-speedbar-key-map (speedbar-make-specialized-keymap)) + + ;; General viewing things + (define-key ede-speedbar-key-map "\C-m" 'speedbar-edit-line) + (define-key ede-speedbar-key-map "+" 'speedbar-expand-line) + (define-key ede-speedbar-key-map "=" 'speedbar-expand-line) + (define-key ede-speedbar-key-map "-" 'speedbar-contract-line) + (define-key ede-speedbar-key-map " " 'speedbar-toggle-line-expansion) + + ;; Some object based things + (define-key ede-speedbar-key-map "C" 'eieio-speedbar-customize-line) + + ;; Some project based things + (define-key ede-speedbar-key-map "R" 'ede-speedbar-remove-file-from-target) + (define-key ede-speedbar-key-map "b" 'ede-speedbar-compile-line) + (define-key ede-speedbar-key-map "B" 'ede-speedbar-compile-project) + (define-key ede-speedbar-key-map "D" 'ede-speedbar-make-distribution) + (define-key ede-speedbar-key-map "E" 'ede-speedbar-edit-projectfile) + ) + +(defvar ede-speedbar-menu + '([ "Compile" ede-speedbar-compile-line t] + [ "Compile Project" ede-speedbar-compile-project + (ede-project-child-p (speedbar-line-token)) ] + "---" + [ "Edit File/Tag" speedbar-edit-line + (not (eieio-object-p (speedbar-line-token)))] + [ "Expand" speedbar-expand-line + (save-excursion (beginning-of-line) + (looking-at "[0-9]+: *.\\+. "))] + [ "Contract" speedbar-contract-line + (save-excursion (beginning-of-line) + (looking-at "[0-9]+: *.-. "))] + "---" + [ "Remove File from Target" ede-speedbar-remove-file-from-target + (stringp (speedbar-line-token)) ] + [ "Customize Project/Target" eieio-speedbar-customize-line + (eieio-object-p (speedbar-line-token)) ] + [ "Edit Project File" ede-speedbar-edit-projectfile t] + [ "Make Distribution" ede-speedbar-make-distribution + (ede-project-child-p (speedbar-line-token)) ] + ) + "Menu part in easymenu format used in speedbar while browsing objects.") + +(eieio-speedbar-create 'ede-speedbar-make-map + 'ede-speedbar-key-map + 'ede-speedbar-menu + "Project" + 'ede-speedbar-toplevel-buttons) + + +(defun ede-speedbar () + "EDE development environment project browser for speedbar." + (interactive) + (speedbar-frame-mode 1) + (speedbar-change-initial-expansion-list "Project") + (speedbar-get-focus) + ) + +(defun ede-speedbar-toplevel-buttons (dir) + "Return a list of objects to display in speedbar. +Argument DIR is the directory from which to derive the list of objects." + ede-projects + ) + +;;; Some special commands useful in EDE +;; +(defun ede-speedbar-remove-file-from-target () + "Remove the file at point from it's target." + (interactive) + (if (stringp (speedbar-line-token)) + (progn + (speedbar-edit-line) + (ede-remove-file)))) + +(defun ede-speedbar-compile-line () + "Compile/Build the project or target on this line." + (interactive) + (let ((obj (eieio-speedbar-find-nearest-object))) + (if (not (eieio-object-p obj)) + nil + (cond ((obj-of-class-p obj ede-project) + (project-compile-project obj)) + ((obj-of-class-p obj ede-target) + (project-compile-target obj)) + (t (error "Error in speedbar structure")))))) + +(defun ede-speedbar-get-top-project-for-line () + "Return a project object for this line." + (interactive) + (let ((obj (eieio-speedbar-find-nearest-object))) + (if (not (eieio-object-p obj)) + (error "Error in speedbar or ede structure") + (if (obj-of-class-p obj ede-target) + (setq obj (ede-target-parent obj))) + (if (obj-of-class-p obj ede-project) + obj + (error "Error in speedbar or ede structure"))))) + +(defun ede-speedbar-compile-project () + "Compile/Build the project which owns this line." + (interactive) + (project-compile-project (ede-speedbar-get-top-project-for-line))) + +(defun ede-speedbar-compile-file-project () + "Compile/Build the target which the current file belongs to." + (interactive) + (let* ((file (speedbar-line-file)) + (buf (find-file-noselect file)) + (bwin (get-buffer-window buf 0))) + (if bwin + (progn + (select-window bwin) + (raise-frame (window-frame bwin))) + (dframe-select-attached-frame speedbar-frame) + (set-buffer buf) + (ede-compile-target)))) + +(defun ede-speedbar-make-distribution () + "Edit the project file based on this line." + (interactive) + (project-make-dist (ede-speedbar-get-top-project-for-line))) + +(defun ede-speedbar-edit-projectfile () + "Edit the project file based on this line." + (interactive) + (project-edit-file-target (ede-speedbar-get-top-project-for-line))) + +;;; Speedbar Project Methods +;; +(defun ede-find-nearest-file-line () + "Go backwards until we find a file." + (save-excursion + (beginning-of-line) + (looking-at "^\\([0-9]+\\):") + (let ((depth (string-to-number (match-string 1)))) + (while (not (re-search-forward "[]] [^ ]" + (save-excursion (end-of-line) + (point)) + t)) + (re-search-backward (format "^%d:" (1- depth))) + (setq depth (1- depth))) + (speedbar-line-token)))) + +(defmethod eieio-speedbar-derive-line-path ((obj ede-project) &optional depth) + "Return the path to OBJ. +Optional DEPTH is the depth we start at." + (file-name-directory (oref obj file)) + ) + +(defmethod eieio-speedbar-derive-line-path ((obj ede-target) &optional depth) + "Return the path to OBJ. +Optional DEPTH is the depth we start at." + (let ((proj (ede-target-parent obj))) + ;; Check the type of line we are currently on. + ;; If we are on a child, we need a file name too. + (save-excursion + (let ((lt (speedbar-line-token))) + (if (or (eieio-object-p lt) (stringp lt)) + (eieio-speedbar-derive-line-path proj) + ;; a child element is a token. Do some work to get a filename too. + (concat (eieio-speedbar-derive-line-path proj) + (ede-find-nearest-file-line))))))) + +(defmethod eieio-speedbar-description ((obj ede-project)) + "Provide a speedbar description for OBJ." + (ede-description obj)) + +(defmethod eieio-speedbar-description ((obj ede-target)) + "Provide a speedbar description for OBJ." + (ede-description obj)) + +(defmethod eieio-speedbar-child-description ((obj ede-target)) + "Provide a speedbar description for a plain-child of OBJ. +A plain child is a child element which is not an EIEIO object." + (or (speedbar-item-info-file-helper) + (speedbar-item-info-tag-helper))) + +(defmethod eieio-speedbar-object-buttonname ((object ede-project)) + "Return a string to use as a speedbar button for OBJECT." + (if (ede-parent-project object) + (ede-name object) + (concat (ede-name object) " " (oref object version)))) + +(defmethod eieio-speedbar-object-buttonname ((object ede-target)) + "Return a string to use as a speedbar button for OBJECT." + (ede-name object)) + +(defmethod eieio-speedbar-object-children ((this ede-project)) + "Return the list of speedbar display children for THIS." + (condition-case nil + (with-slots (subproj targets) this + (append subproj targets)) + (error nil))) + +(defmethod eieio-speedbar-object-children ((this ede-target)) + "Return the list of speedbar display children for THIS." + (oref this source)) + +(defmethod eieio-speedbar-child-make-tag-lines ((this ede-target) depth) + "Create a speedbar tag line for a child of THIS. +It has depth DEPTH." + (with-slots (source) this + (mapcar (lambda (car) + (speedbar-make-tag-line 'bracket ?+ + 'speedbar-tag-file + car + car + 'ede-file-find + car + 'speedbar-file-face depth)) + source))) + +;;; Generic file management for TARGETS +;; +(defun ede-file-find (text token indent) + "Find the file TEXT at path TOKEN. +INDENT is the current indentation level." + (speedbar-find-file-in-frame + (expand-file-name token (speedbar-line-directory indent))) + (speedbar-maybee-jump-to-attached-frame)) + +(defun ede-create-tag-buttons (filename indent) + "Create the tag buttons associated with FILENAME at INDENT." + (let* ((lst (speedbar-fetch-dynamic-tags filename))) + ;; if no list, then remove expando button + (if (not lst) + (speedbar-change-expand-button-char ??) + (speedbar-with-writable + ;; We must do 1- because indent was already incremented. + (speedbar-insert-generic-list (1- indent) + lst + 'ede-tag-expand + 'ede-tag-find))))) + +(defun ede-tag-expand (text token indent) + "Expand a tag sublist. Imenu will return sub-lists of specialized tag types. +Etags does not support this feature. TEXT will be the button +string. TOKEN will be the list, and INDENT is the current indentation +level." + (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) + (speedbar-insert-generic-list indent token + 'ede-tag-expand + 'ede-tag-find)))) + ((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 ede-tag-find (text token indent) + "For the tag TEXT in a file TOKEN, goto that position. +INDENT is the current indentation level." + (let ((file (ede-find-nearest-file-line))) + (speedbar-find-file-in-frame file) + (save-excursion (speedbar-stealthy-updates)) + ;; 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 speedbar-update-speed) + (goto-char token) + (run-hooks 'speedbar-visiting-tag-hook) + ;;(recenter) + (speedbar-maybee-jump-to-attached-frame) + )) + +;;; EDE and the speedbar FILE display +;; +;; This will add a couple keybindings and menu items into the +;; FILE display for speedbar. + +(defvar ede-speedbar-file-menu-additions + '("----" + ["Create EDE Target" ede-new-target (ede-current-project) ] + ["Add to project" ede-speedbar-file-add-to-project (ede-current-project) ] + ["Compile project" ede-speedbar-compile-project (ede-current-project) ] + ["Compile file target" ede-speedbar-compile-file-target (ede-current-project) ] + ["Make distribution" ede-make-dist (ede-current-project) ] + ) + "Set of menu items to splice into the speedbar menu.") + +(defvar ede-speedbar-file-keymap + (let ((km (make-sparse-keymap))) + (define-key km "a" 'ede-speedbar-file-add-to-project) + (define-key km "t" 'ede-new-target) + (define-key km "s" 'ede-speedbar) + (define-key km "C" 'ede-speedbar-compile-project) + (define-key km "c" 'ede-speedbar-compile-file-target) + (define-key km "d" 'ede-make-dist) + km) + "Keymap spliced into the speedbar keymap.") + +;;;###autoload +(defun ede-speedbar-file-setup () + "Setup some keybindings in the Speedbar File display." + (setq speedbar-easymenu-definition-special + (append speedbar-easymenu-definition-special + ede-speedbar-file-menu-additions + )) + (define-key speedbar-file-key-map "." ede-speedbar-file-keymap) + ;; Finally, if the FILES mode is loaded, force a refresh + ;; of the menus and such. + (when (and (string= speedbar-initial-expansion-list-name "files") + (buffer-live-p speedbar-buffer) + ) + (speedbar-change-initial-expansion-list "files"))) + +(provide 'ede/speedbar) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: ede/loaddefs +;; generated-autoload-load-name: "ede/speedbar" +;; End: + +;;; ede/speedbar.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/srecode.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/srecode.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,106 @@ +;;; ede-srecode.el --- EDE utilities on top of SRecoder + +;; Copyright (C) 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; EDE utilities for using SRecode to generate project files, such as +;; Makefiles. + +(require 'srecode) + +(declare-function srecode-create-dictionary "srecode/dictionary") +(declare-function srecode-dictionary-set-value "srecode/dictionary") +(declare-function srecode-load-tables-for-mode "srecode/find") +(declare-function srecode-table "srecode/find") +(declare-function srecode-template-get-table "srecode/find") +(declare-function srecode-insert-fcn "srecode/insert") +(declare-function srecode-resolve-arguments "srecode/map") +(declare-function srecode-map-update-map "srecode/map") + +;;; Code: +(defun ede-srecode-setup () + "Update various paths to get SRecode to identify our macros." + (let* ((lib (locate-library "ede.el" t)) + (ededir (file-name-directory lib)) + (tmpdir (file-name-as-directory + (expand-file-name "templates" ededir)))) + (when (not tmpdir) + (error "Unable to location EDE Templates directory")) + + ;; Rig up the map. + (require 'srecode/map) + (require 'srecode/find) + (add-to-list 'srecode-map-load-path tmpdir) + (srecode-map-update-map t) + + ;; We don't call this unless we need it. Load in the templates. + (srecode-load-tables-for-mode 'makefile-mode) + (srecode-load-tables-for-mode 'makefile-mode 'ede) + + ;; @todo - autoconf files. + + )) + +(defmacro ede-srecode-insert-with-dictionary (template &rest forms) + "Insert TEMPLATE after executing FORMS with a dictionary. +TEMPLATE should specify a context by using a string format of: + context:templatename +Locally binds the variable DICT to a dictionary which can be +updated in FORMS." + `(let* ((dict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) + ,template + nil + 'ede)) + ) + (when (not temp) + (error "EDE template %s for %s not found!" + ,template major-mode)) + (srecode-resolve-arguments temp dict) + + ;; Now execute forms for updating DICT. + (progn ,@forms) + + (srecode-insert-fcn temp dict) + )) + +(defun ede-srecode-insert (template &rest dictionary-entries) + "Insert at the current point TEMPLATE. +TEMPLATE should specify a context by using a string format of: + context:templatename +Add DICTIONARY-ENTRIES into the dictionary before insertion. +Note: Just like `srecode-insert', but templates found in 'ede app." + (require 'srecode/insert) + (ede-srecode-insert-with-dictionary template + + ;; Add in optional dictionary entries. + (while dictionary-entries + (srecode-dictionary-set-value dict + (car dictionary-entries) + (car (cdr dictionary-entries))) + (setq dictionary-entries + (cdr (cdr dictionary-entries)))) + + )) + +(provide 'ede-srecode) + +;;; ede-srecode.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/system.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/system.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,147 @@ +;;; ede-system.el --- EDE working with the system (VC, FTP, ETC) + +;;; Copyright (C) 2001, 2002, 2003 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: project, make, vc + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; EDE system contains some routines to work with EDE projects saved in +;; CVS repositories, and services such as sourceforge which lets you +;; perform releases via FTP. + +(require 'ede) + +;;; Code: + +;;; Web/FTP site node. + +;;;###autoload +(defun ede-web-browse-home () + "Browse the home page of the current project." + (interactive) + (if (not (ede-toplevel)) + (error "No project")) + (let ((home (oref (ede-toplevel) web-site-url))) + (if (string= "" home) + (error "Now URL is stored in this project")) + (require 'browse-url) + (browse-url home) + )) + +;;;###autoload +(defun ede-edit-web-page () + "Edit the web site for this project." + (interactive) + (let* ((toplevel (ede-toplevel)) + (dir (oref toplevel web-site-directory)) + (file (oref toplevel web-site-file)) + (endfile (concat (file-name-as-directory dir) file))) + (if (string-match "^/r[:@]" endfile) + (require 'tramp)) + (when (not (file-exists-p endfile)) + (setq endfile file) + (if (string-match "^/r[:@]" endfile) + (require 'tramp)) + (if (not (file-exists-p endfile)) + (error "No project file found"))) + (find-file endfile))) + +;;;###autoload +(defun ede-upload-distribution () + "Upload the current distribution to the correct location. +Use /user@ftp.site.com: file names for FTP sites. +Download tramp, and use /r:machine: for names on remote sites w/out FTP access." + (interactive) + (let* ((files (project-dist-files (ede-toplevel))) + (upload (if (string= (oref (ede-toplevel) ftp-upload-site) "") + (oref (ede-toplevel) ftp-site) + (oref (ede-toplevel) ftp-upload-site)))) + (when (or (string= upload "") + (not (file-exists-p upload))) + (error "Upload directory %S does not exist" upload)) + (while files + (let ((localfile (concat (file-name-directory (oref (ede-toplevel) file)) + (car files)))) + (if (not (file-exists-p localfile)) + (progn + (message "File %s does not exist yet. Building a distribution" + localfile) + (ede-make-dist) + (error "File %s does not exist yet. Building a distribution" + localfile) + )) + (setq upload + (concat (directory-file-name upload) + "/" + (file-name-nondirectory localfile))) + (copy-file localfile upload) + (setq files (cdr files))))) + (message "Done uploading files...") + ) + +;;;###autoload +(defun ede-upload-html-documentation () + "Upload the current distributions documentation as HTML. +Use /user@ftp.site.com: file names for FTP sites. +Download tramp, and use /r:machine: for names on remote sites w/out FTP access." + (interactive) + (let* ((files nil) ;(ede-html-doc-files (ede-toplevel))) + (upload (if (string= (oref (ede-toplevel) ftp-upload-site) "") + (oref (ede-toplevel) ftp-site) + (oref (ede-toplevel) ftp-upload-site)))) + (when (or (string= upload "") + (not (file-exists-p upload))) + (error "Upload directory %S does not exist" upload)) + (while files + (let ((localfile (concat (file-name-directory (oref (ede-toplevel) file)) + (car files)))) + (if (not (file-exists-p localfile)) + (progn + (message "File %s does not exist yet. Building a distribution" + localfile) + ;;(project-compile-target ... ) + (error "File %s does not exist yet. Building a distribution" + localfile) + )) + (copy-file localfile upload) + (setq files (cdr files))))) + (message "Done uploading files...") + ) + +;;; Version Control +;; +;; Do a few nice things with Version control systems. + +;;;###autoload +(defun ede-vc-project-directory () + "Run `vc-dir' on the current project." + (interactive) + (let ((top (ede-toplevel-project-or-nil default-directory))) + (vc-dir top nil))) + +(provide 'ede/system) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: ede/loaddefs +;; generated-autoload-load-name: "ede/system" +;; End: + +;;; ede/system.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/ede/util.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/ede/util.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,106 @@ +;;; ede/util.el --- EDE utilities + +;;; Copyright (C) 2000, 2005 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; Commentary: +;; +;; Utilities that may not require project specific help, and oporate +;; on generic EDE structures. Provide user level commands for activities +;; not directly related to source code organization or makefile generation. + +(require 'ede) + +;;; Code: + +;;; Updating the version of a project. +;;;###autoload +(defun ede-update-version (newversion) + "Update the current projects main version number. +Argument NEWVERSION is the version number to use in the current project." + (interactive (list (let* ((o (ede-toplevel)) + (v (oref o version))) + (read-string (format "Update Version (was %s): " v) + v nil v)))) + (let ((ede-object (ede-toplevel))) + ;; Don't update anything if there was no change. + (unless (string= (oref ede-object :version) newversion) + (oset ede-object :version newversion) + (project-update-version ede-object) + (ede-update-version-in-source ede-object newversion)))) + +(defmethod project-update-version ((ot ede-project)) + "The :version of the project OT has been updated. +Handle saving, or other detail." + (error "project-update-version not supported by %s" (object-name ot))) + +(defmethod ede-update-version-in-source ((this ede-project) version) + "Change occurrences of a version string in sources. +In project THIS, cycle over all targets to give them a chance to set +their sources to VERSION." + (ede-map-targets this (lambda (targ) + (ede-update-version-in-source targ version)))) + +(defmethod ede-update-version-in-source ((this ede-target) version) + "In sources for THIS, change version numbers to VERSION." + (if (and (slot-boundp this 'versionsource) + (oref this versionsource)) + (let ((vs (oref this versionsource))) + (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-*\\([^ \t\n]+\\)" nil t) + (progn + (save-match-data + (ede-make-buffer-writable)) + (delete-region (match-beginning 1) + (match-end 1)) + (goto-char (match-beginning 1)) + (insert version))))) + (setq vs (cdr vs)))))) + +;;; Writable files +;; +;; Utils for EDE when it needs to write a file that could be covered by a +;; version control system. +(defun ede-make-buffer-writable (&optional buffer) + "Make sure that BUFFER is writable. +If BUFFER isn't specified, use the current buffer." + (save-excursion + (if buffer (set-buffer buffer)) + (if buffer-read-only + (if (and vc-mode + (y-or-n-p (format "Check out %s? " (buffer-file-name)))) + (vc-toggle-read-only) + (if (not vc-mode) + (toggle-read-only -1)))))) + +(provide 'ede/util) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: ede/loaddefs +;; generated-autoload-load-name: "ede/util" +;; End: + +;;; ede/util.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,1115 @@ +;;; 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 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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) + +;;; 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) + +;;; Parsing Commands +;; +(eval-when-compile + (condition-case nil (require 'pp) (error nil))) + +(defvar semantic-edebug nil + "When non-nil, activate the interactive parsing debugger. +Do not set this yourself. Call `semantic-debug'.") + +(defun semantic-elapsed-time (start end) + "Copied from elp.el. Was elp-elapsed-time. +Argument START and END bound the time being calculated." + (+ (* (- (car end) (car start)) 65536.0) + (- (car (cdr end)) (car (cdr start))) + (/ (- (car (cdr (cdr end))) (car (cdr (cdr start)))) 1000000.0))) + +(defun bovinate (&optional clear) + "Parse the current buffer. Show output in a temp buffer. +Optional argument CLEAR will clear the cache before parsing. +If CLEAR is negative, it will do a full reparse, and also not display +the output buffer." + (interactive "P") + (if clear (semantic-clear-toplevel-cache)) + (if (eq clear '-) (setq clear -1)) + (let* ((start (current-time)) + (out (semantic-fetch-tags)) + (end (current-time))) + (message "Retrieving tags took %.2f seconds." + (semantic-elapsed-time start end)) + (when (or (null clear) (not (listp clear))) + (pop-to-buffer "*Parser Output*") + (require 'pp) + (erase-buffer) + (insert (pp-to-string out)) + (goto-char (point-min))))) + +;;; Functions of the parser plug-in API +;; +;; Overload these functions to create new types of parsers. +;; +(define-overloadable-function semantic-parse-stream (stream nonterminal) + "Parse STREAM, starting at the first NONTERMINAL rule. +For bovine and wisent based parsers, STREAM is from the output of +`semantic-lex', and NONTERMINAL is a rule in the apropriate language +specific rules file. +The default parser table used for bovine or wisent based parsers is +`semantic--parse-table'. + +Must return a list: (STREAM TAGS) where STREAM is the unused elements +from STREAM, and TAGS is the list of semantic tags found, usually only +one tag is returned with the exception of compound statements") + +(define-overloadable-function semantic-parse-changes () + "Reparse changes in the current buffer. +The list of changes are tracked as a series of overlays in the buffer. +When overloading this function, use `semantic-changes-in-region' to +analyze.") + +(define-overloadable-function semantic-parse-region + (start end &optional nonterminal depth returnonerror) + "Parse the area between START and END, and return any tags found. +If END needs to be extended due to a lexical token being too large, it +will be silently ignored. + +Optional arguments: +NONTERMINAL is the rule to start parsing at. +DEPTH specifies the lexical depth to decend for parser that use +lexical analysis as their first step. +RETURNONERROR specifies that parsing should stop on the first +unmatched syntax encountered. When nil, parsing skips the syntax, +adding it to the unmatched syntax cache. + +Must return a list of semantic tags wich have been cooked +\(repositioned properly) but which DO NOT HAVE OVERLAYS associated +with them. When overloading this function, use `semantic--tag-expand' +to cook raw tags.") + +(defun semantic-parse-region-default + (start end &optional nonterminal depth returnonerror) + "Parse the area between START and END, and return any tags found. +If END needs to be extended due to a lexical token being too large, it +will be silently ignored. +Optional arguments: +NONTERMINAL is the rule to start parsing at if it is known. +DEPTH specifies the lexical depth to scan. +RETURNONERROR specifies that parsing should end when encountering +unterminated syntax." + (when (or (null semantic--parse-table) (eq semantic--parse-table t)) + ;; If there is no table, or it was set to t, then we are here by + ;; some other mistake. Do not throw an error deep in the parser. + (error "No support found to parse buffer %S" (buffer-name))) + (save-restriction + (widen) + (when (or (< end start) (> end (point-max))) + (error "Invalid parse region bounds %S, %S" start end)) + (nreverse + (semantic-repeat-parse-whole-stream + (or (cdr (assq start semantic-lex-block-streams)) + (semantic-lex start end depth)) + nonterminal returnonerror)))) + +;;; Parsing functions +;; +(defun semantic-set-unmatched-syntax-cache (unmatched-syntax) + "Set the unmatched syntax cache. +Argument UNMATCHED-SYNTAX is the syntax to set into the cache." + ;; This function is not actually called by the main parse loop. + ;; This is intended for use by semanticdb. + (setq semantic-unmatched-syntax-cache unmatched-syntax + semantic-unmatched-syntax-cache-check nil) + ;; Refresh the display of unmatched syntax tokens if enabled + (run-hook-with-args 'semantic-unmatched-syntax-hook + semantic-unmatched-syntax-cache)) + +(defun semantic-clear-unmatched-syntax-cache () + "Clear the cache of unmatched syntax tokens." + (setq semantic-unmatched-syntax-cache nil + semantic-unmatched-syntax-cache-check t)) + +(defun semantic-unmatched-syntax-tokens () + "Return the list of unmatched syntax tokens." + ;; If the cache need refresh then do a full re-parse. + (if (semantic--umatched-syntax-needs-refresh-p) + ;; To avoid a recursive call, temporarily disable + ;; `semantic-unmatched-syntax-hook'. + (let (semantic-unmatched-syntax-hook) + (condition-case nil + (progn + (semantic-clear-toplevel-cache) + (semantic-fetch-tags)) + (quit + (message "semantic-unmatched-syntax-tokens:\ + parsing of buffer canceled")) + ))) + semantic-unmatched-syntax-cache) + +(defun semantic-clear-toplevel-cache () + "Clear the toplevel tag cache for the current buffer. +Clearing the cache will force a complete reparse next time a tag list +is requested." + (interactive) + (run-hooks 'semantic-before-toplevel-cache-flush-hook) + (setq semantic--buffer-cache nil) + (semantic-clear-unmatched-syntax-cache) + (semantic-clear-parser-warnings) + ;; Nuke all semantic overlays. This is faster than deleting based + ;; on our data structure. + (let ((l (semantic-overlay-lists))) + (mapc 'semantic-delete-overlay-maybe (car l)) + (mapc 'semantic-delete-overlay-maybe (cdr l)) + ) + (semantic-parse-tree-set-needs-rebuild) + ;; Remove this hook which tracks if a buffer is up to date or not. + (remove-hook 'after-change-functions 'semantic-change-function t) + ;; Old model. Delete someday. + ;;(run-hooks 'semantic-after-toplevel-bovinate-hook) + + (run-hook-with-args 'semantic-after-toplevel-cache-change-hook + semantic--buffer-cache) + + (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)) + "...")) + +;;; 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) + +;;; 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)) + +;;; Parsing Warnings: +;; +;; Parsing a buffer may result in non-critical things that we should +;; alert the user to without interrupting the normal flow. +;; +;; Any parser can use this API to provide a list of warnings during a +;; parse which a user may want to investigate. +(defvar semantic-parser-warnings nil + "A list of parser warnings since the last full reparse.") +(make-variable-buffer-local 'semantic-parser-warnings) + +(defun semantic-clear-parser-warnings () + "Clear the current list of parser warnings for this buffer." + (setq semantic-parser-warnings nil)) + +(defun semantic-push-parser-warning (warning start end) + "Add a parser WARNING that covers text from START to END." + (setq semantic-parser-warnings + (cons (cons warning (cons start end)) + semantic-parser-warnings))) + +(defun semantic-dump-parser-warnings () + "Dump any parser warnings." + (interactive) + (if semantic-parser-warnings + (let ((pw semantic-parser-warnings)) + (pop-to-buffer "*Parser Warnings*") + (require 'pp) + (erase-buffer) + (insert (pp-to-string pw)) + (goto-char (point-min))) + (message "No parser warnings."))) + + + +;;; Compatibility: +;; +;; Semantic 1.x parser action helper functions, used by some parsers. +;; Please move away from these functions, and try using semantic 2.x +;; interfaces instead. +;; +(defsubst semantic-bovinate-region-until-error + (start end nonterm &optional depth) + "NOTE: Use `semantic-parse-region' instead. + +Bovinate between START and END starting with NONTERM. +Optional DEPTH specifies how many levels of parenthesis to enter. +This command will parse until an error is encountered, and return +the list of everything found until that moment. +This is meant for finding variable definitions at the beginning of +code blocks in methods. If `bovine-inner-scope' can also support +commands, use `semantic-bovinate-from-nonterminal-full'." + (semantic-parse-region start end nonterm depth t)) +(make-obsolete 'semantic-bovinate-region-until-error + 'semantic-parse-region) + +(defsubst semantic-bovinate-from-nonterminal + (start end nonterm &optional depth length) + "Bovinate from within a nonterminal lambda from START to END. +Argument NONTERM is the nonterminal symbol to start with. +Optional argument DEPTH is the depth of lists to dive into. When used +in a `lambda' of a MATCH-LIST, there is no need to include a START and +END part. +Optional argument LENGTH specifies we are only interested in LENGTH +tokens." + (car-safe (cdr (semantic-parse-stream + (semantic-lex start end (or depth 1) length) + nonterm)))) + +(defsubst semantic-bovinate-from-nonterminal-full + (start end nonterm &optional depth) + "NOTE: Use `semantic-parse-region' instead. + +Bovinate from within a nonterminal lambda from START to END. +Iterates until all the space between START and END is exhausted. +Argument NONTERM is the nonterminal symbol to start with. +If NONTERM is nil, use `bovine-block-toplevel'. +Optional argument DEPTH is the depth of lists to dive into. +When used in a `lambda' of a MATCH-LIST, there is no need to include +a START and END part." + (semantic-parse-region start end nonterm (or depth 1))) +(make-obsolete 'semantic-bovinate-from-nonterminal-full + 'semantic-parse-region) + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/.cvsignore --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/.cvsignore Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,1 @@ +loaddefs.el diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/analyze.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,798 @@ +;;; 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 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Semantic, 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) +(require 'semantic/format) +(require 'semantic/ctxt) +(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)) + + +(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."))))) + + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/analyze/complete.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze/complete.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,263 @@ +;;; semantic/analyze/complete.el --- Smart Completions + +;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/analyze/debug.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze/debug.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,624 @@ +;;; semantic/analyze/debug.el --- Debug the analyzer + +;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Provide a top-order debugging tool for figuring out what's going on with +;; smart completion and analyzer mode. + +(require 'semantic) +(require 'semantic/analyze) +(require 'semantic/analyze/complete) +(require 'semantic/db-typecache) + +;; For semantic-find-tags-by-class: +(eval-when-compile (require 'semantic/find)) + +(declare-function ede-get-locator-object "ede/files") + +;;; Code: + +(defun semantic-analyze-debug-assist () + "Debug semantic analysis at the current point." + (interactive) + (let ((actualfcn (fetch-overload 'semantic-analyze-current-context)) + (ctxt (semantic-analyze-current-context)) + ) + ;; What to show. + (if actualfcn + (message "Mode %s does not use the default analyzer." + major-mode) + ;; Debug our context. + ) + (or (semantic-analyzer-debug-test-local-context) + (and ctxt (semantic-analyzer-debug-found-prefix ctxt)) + ) + + )) + +(defun semantic-analyzer-debug-found-prefix (ctxt) + "Debug the prefix found by the analyzer output CTXT." + (let* ((pf (oref ctxt prefix)) + (pft (oref ctxt prefixtypes)) + (idx 0) + (stop nil) + (comp (condition-case nil + (semantic-analyze-possible-completions ctxt) + (error nil))) + ) + (while (and (nth idx pf) (not stop)) + (let ((pentry (nth idx pf)) + (ptentry (nth idx pft))) + (if (or (stringp pentry) (not ptentry)) + ;; Found someting ok. stop + (setq stop t) + (setq idx (1+ idx))))) + ;; We found the first non-tag entry. What is the situation? + (cond + ((and (eq idx 0) (stringp (car pf))) + ;; First part, we couldn't find it. + (semantic-analyzer-debug-global-symbol ctxt (car pf) comp)) + ((not (nth (1- idx) pft)) ;; idx can't be 0 here. + ;; The previous entry failed to have an identifiable data + ;; type, which is a global search. + (semantic-analyzer-debug-missing-datatype ctxt idx comp)) + ((and (nth (1- idx) pft) (stringp (nth idx pf))) + ;; Non-first search, didn't find string in known data type. + (semantic-analyzer-debug-missing-innertype ctxt idx comp)) + (t + ;; Things are ok? + (message "Things look ok.")) + ))) + +(defun semantic-analyzer-debug-global-symbol (ctxt prefix comp) + "Debug why we can't find the first entry in the CTXT PREFIX. +Argument COMP are possible completions here." + (let ((tab semanticdb-current-table) + (finderr nil) + (origbuf (current-buffer)) + ) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (princ "Unable to find prefix ") + (princ prefix) + (princ ".\n\n") + + ;; NOTE: This line is copied from semantic-analyze-current-context. + ;; You will need to update both places. + (condition-case err + (save-excursion + (set-buffer origbuf) + (let* ((position (or (cdr-safe (oref ctxt bounds)) (point))) + (prefixtypes nil) ; Used as type return + (scope (semantic-calculate-scope position)) + ) + (semantic-analyze-find-tag-sequence + (list prefix "") scope 'prefixtypes) + ) + ) + (error (setq finderr err))) + + (if finderr + (progn + (princ "The prefix lookup code threw the following error:\n ") + (prin1 finderr) + (princ "\n\nTo debug this error you can do this: + M-x toggle-debug-on-error RET +and then re-run the debug analyzer.\n") + ) + ;; No find error, just not found + (princ "The prefix ") + (princ prefix) + (princ " could not be found in the local scope, +nor in any search tables.\n") + ) + (princ "\n") + + ;; Describe local scope, and why we might not be able to + ;; find it. + (semantic-analyzer-debug-describe-scope ctxt) + + (semantic-analyzer-debug-show-completions comp) + + (princ "When Semantic cannot find a symbol, it could be because the include +path was setup incorrectly.\n") + + (semantic-analyzer-debug-insert-include-summary tab) + + )) + (semantic-analyzer-debug-add-buttons) + )) + +(defun semantic-analyzer-debug-missing-datatype (ctxt idx comp) + "Debug why we can't find a datatype entry for CTXT prefix at IDX. +Argument COMP are possible completions here." + (let* ((prefixitem (nth idx (oref ctxt prefix))) + (dt (nth (1- idx) (oref ctxt prefixtypes))) + (tt (semantic-tag-type prefixitem)) + (tab semanticdb-current-table) + ) + (when dt (error "Missing Datatype debugger is confused")) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (princ "Unable to find datatype for: \"") + (princ (semantic-format-tag-prototype prefixitem)) + (princ "\". +Declared type is: ") + (when (semantic-tag-p tt) + (semantic-analyzer-debug-insert-tag tt) + (princ "\nRaw data type is: ")) + (princ (format "%S" tt)) + (princ " + +Semantic could not find this data type in any of its global tables. + +Semantic locates datatypes through either the local scope, or the global +typecache. +") + + ;; Describe local scope, and why we might not be able to + ;; find it. + (semantic-analyzer-debug-describe-scope ctxt '(type)) + + ;; Describe the typecache. + (princ "\nSemantic creates and maintains a type cache for each buffer. +If the type is a global type, then it should appear in they typecache. +To examine the typecache, type: + + M-x semanticdb-typecache-dump RET + +Current typecache Statistics:\n") + (princ (format " %4d types global in this file\n %4d types from includes.\n" + (length (semanticdb-typecache-file-tags tab)) + (length (semanticdb-typecache-include-tags tab)))) + + (princ "\nIf the datatype is not in the typecache, then your include +path may be incorrect. ") + + (semantic-analyzer-debug-insert-include-summary tab) + + ;; End with-buffer + )) + (semantic-analyzer-debug-add-buttons) + )) + +(defun semantic-analyzer-debug-missing-innertype (ctxt idx comp) + "Debug why we can't find an entry for CTXT prefix at IDX for known type. +We need to see if we have possible completions against the entry before +being too vocal about it. +Argument COMP are possible completions here." + (let* ((prefixitem (nth idx (oref ctxt prefix))) + (prevprefix (nth (1- idx) (oref ctxt prefix))) + (dt (nth (1- idx) (oref ctxt prefixtypes))) + (desired-type (semantic-analyze-type-constraint ctxt)) + (orig-buffer (current-buffer)) + (ots (semantic-analyze-tag-type prevprefix + (oref ctxt scope) + t ; Don't deref + )) + ) + (when (not dt) (error "Missing Innertype debugger is confused")) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (princ "Cannot find prefix \"") + (princ prefixitem) + (princ "\" in datatype: + ") + (semantic-analyzer-debug-insert-tag dt) + (princ "\n") + + (cond + ;; Any language with a namespace. + ((string= (semantic-tag-type dt) "namespace") + (princ "Semantic may not have found all possible namespaces with +the name ") + (princ (semantic-tag-name dt)) + (princ ". You can debug the entire typecache, including merged namespaces +with the command: + + M-x semanticdb-typecache-dump RET") + ) + + ;; @todo - external declarations?? + (nil + nil) + + ;; A generic explanation + (t + (princ "\nSemantic has found the datatype ") + (semantic-analyzer-debug-insert-tag dt) + (if (or (not (semantic-equivalent-tag-p ots dt)) + (not (save-excursion + (set-buffer orig-buffer) + (car (semantic-analyze-dereference-metatype + ots (oref ctxt scope)))))) + (let ((lasttype ots) + (nexttype (save-excursion + (set-buffer orig-buffer) + (car (semantic-analyze-dereference-metatype + ots (oref ctxt scope)))))) + (if (eq nexttype lasttype) + (princ "\n [ Debugger error trying to help with metatypes ]") + + (if (eq ots dt) + (princ "\nwhich is a metatype") + (princ "\nwhich is derived from metatype ") + (semantic-analyzer-debug-insert-tag lasttype))) + + (princ ".\nThe Metatype stack is:\n") + (princ " ") + (semantic-analyzer-debug-insert-tag lasttype) + (princ "\n") + (while (and nexttype + (not (eq nexttype lasttype))) + (princ " ") + (semantic-analyzer-debug-insert-tag nexttype) + (princ "\n") + (setq lasttype nexttype + nexttype + (save-excursion + (set-buffer orig-buffer) + (car (semantic-analyze-dereference-metatype + nexttype (oref ctxt scope))))) + ) + (when (not nexttype) + (princ " nil\n\n") + (princ + "Last metatype is nil. This means that semantic cannot derive +the list of members because the type referred to cannot be found.\n") + ) + ) + (princ "\nand its list of members.") + + (if (not comp) + (progn + (princ " Semantic does not know what +possible completions there are for \"") + (princ prefixitem) + (princ "\". Examine the known +members below for more.")) + (princ " Semantic knows of some +possible completions for \"") + (princ prefixitem) + (princ "\"."))) + ) + ;; end cond + ) + + (princ "\n") + (semantic-analyzer-debug-show-completions comp) + + (princ "\nKnown members of ") + (princ (semantic-tag-name dt)) + (princ ":\n") + (dolist (M (semantic-tag-type-members dt)) + (princ " ") + ;;(princ (semantic-format-tag-prototype M)) + (semantic-analyzer-debug-insert-tag M) + (princ "\n")) + + ;; This doesn't refer to in-type completions. + ;;(semantic-analyzer-debug-global-miss-text prefixitem) + + ;; More explanation + (when desired-type + (princ "\nWhen there are known members that would make good completion +candidates that are not in the completion list, then the most likely +cause is a type constraint. Semantic has determined that there is a +type constraint looking for the type ") + (if (semantic-tag-p desired-type) + (semantic-analyzer-debug-insert-tag desired-type) + (princ (format "%S" desired-type))) + (princ ".")) + )) + (semantic-analyzer-debug-add-buttons) + + )) + + +(defun semantic-analyzer-debug-test-local-context () + "Test the local context parsed from the file." + (let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point))) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + ) + (when (and (or (not prefixandbounds) + (not prefix) + (not bounds)) + ) + (with-output-to-temp-buffer (help-buffer) + (with-current-buffer standard-output + (princ "Local Context Parser Failed. + +If this is unexpected, then there is likely a bug in the Semantic +local context parser. + +Consider debugging the function ") + (let ((lcf (fetch-overload 'semantic-ctxt-current-symbol-and-bounds))) + (if lcf + (princ (symbol-name lcf)) + (princ "semantic-ctxt-current-symbol-and-bounds, +or implementing a version specific to ") + (princ (symbol-name major-mode)) + ) + (princ ".\n")) + (semantic-analyzer-debug-add-buttons) + t))) + )) + +;;; General Inserters with help +;; +(defun semantic-analyzer-debug-show-completions (comp) + "Show the completion list COMP." + (if (not comp) + (princ "\nNo known possible completions.\n") + + (princ "\nPossible completions are:\n") + (dolist (C comp) + (princ " ") + (cond ((stringp C) + (princ C) + ) + ((semantic-tag-p C) + (semantic-analyzer-debug-insert-tag C))) + (princ "\n")) + (princ "\n"))) + +(defvar semantic-dependency-system-include-path) + +(defun semantic-analyzer-debug-insert-include-summary (table) + "Display a summary of includes for the semanticdb TABLE." + (require 'semantic/dep) + (semantic-fetch-tags) + (let ((inc (semantic-find-tags-by-class 'include table)) + ;;(path (semanticdb-find-test-translate-path-no-loading)) + (unk + (save-excursion + (set-buffer (semanticdb-get-buffer table)) + semanticdb-find-lost-includes)) + (ip + (save-excursion + (set-buffer (semanticdb-get-buffer table)) + semantic-dependency-system-include-path)) + (edeobj + (save-excursion + (set-buffer (semanticdb-get-buffer table)) + (and (boundp 'ede-object) + ede-object))) + (edeproj + (save-excursion + (set-buffer (semanticdb-get-buffer table)) + (and (boundp 'ede-object-project) + ede-object-project)))) + + (princ "\n\nInclude Path Summary:") + (when edeobj + (princ "\n\nThis file's project include search is handled by the EDE object:\n") + (princ " Buffer Target: ") + (princ (object-print edeobj)) + (princ "\n") + (when (not (eq edeobj edeproj)) + (princ " Buffer Project: ") + (princ (object-print edeproj)) + (princ "\n")) + (when edeproj + (let ((loc (ede-get-locator-object edeproj))) + (princ " Backup Locator: ") + (princ (object-print loc)) + (princ "\n"))) + ) + + (princ "\n\nThe system include path is:\n") + (dolist (dir ip) + (princ " ") + (princ dir) + (princ "\n")) + + (princ "\n\nInclude Summary: ") + (princ (semanticdb-full-filename table)) + (princ "\n\n") + (princ (format "%s contains %d includes.\n" + (file-name-nondirectory + (semanticdb-full-filename table)) + (length inc))) + (let ((ok 0) + (unknown 0) + (unparsed 0) + (all 0)) + (dolist (i inc) + (let* ((fileinner (semantic-dependency-tag-file i)) + (tableinner (when fileinner + (semanticdb-file-table-object fileinner t)))) + (cond ((not fileinner) + (setq unknown (1+ unknown))) + ((number-or-marker-p (oref tableinner pointmax)) + (setq ok (1+ ok))) + (t + (setq unparsed (1+ unparsed)))))) + (setq all (+ ok unknown unparsed)) + (when (not (= 0 all)) + (princ (format " Unknown Includes: %d\n" unknown)) + (princ (format " Unparsed Includes: %d\n" unparsed)) + (princ (format " Parsed Includes: %d\n" ok))) + ) + + ;; Unknowns... + (if unk + (progn + (princ "\nA likely cause of an unfound tag is missing include files.") + (semantic-analyzer-debug-insert-tag-list + "The following includes were not found" unk) + + (princ "\nYou can fix the include path for ") + (princ (symbol-name (oref table major-mode))) + (princ " by using this function: + +M-x semantic-customize-system-include-path RET + +which customizes the mode specific variable for the mode-local +variable `semantic-dependency-system-include-path'.") + ) + + (princ "\n No unknown includes.\n")) + )) + +(defun semantic-analyzer-debug-describe-scope (ctxt &optional classconstraint) + "Describe the scope in CTXT for finding a global symbol. +Optional argument CLASSCONSTRAINT says to output to tags of that class." + (let* ((scope (oref ctxt :scope)) + (parents (oref scope parents)) + (cc (or classconstraint (oref ctxt prefixclass))) + ) + (princ "\nLocal Scope Information:") + (princ "\n * Tag Class Constraint against SCOPE: ") + (princ (format "%S" classconstraint)) + + (if parents + (semantic-analyzer-debug-insert-tag-list + " >> Known parent types with possible in scope symbols" + parents) + (princ "\n * No known parents in current scope.")) + + (let ((si (semantic-analyze-tags-of-class-list + (oref scope scope) cc)) + (lv (semantic-analyze-tags-of-class-list + (oref scope localvar) cc)) + ) + (if si + (semantic-analyzer-debug-insert-tag-list + " >> Known symbols within the current scope" + si) + (princ "\n * No known symbols currently in scope.")) + + (if lv + (semantic-analyzer-debug-insert-tag-list + " >> Known symbols that are declared locally" + lv) + (princ "\n * No known symbols declared locally.")) + ) + ) + ) + +(defun semantic-analyzer-debug-global-miss-text (name-in) + "Use 'princ' to show text describing not finding symbol NAME-IN. +NAME is the name of the unfound symbol." + (let ((name (cond ((stringp name-in) + name-in) + ((semantic-tag-p name-in) + (semantic-format-tag-name name-in)) + (t (format "%S" name-in))))) + (when (not (string= name "")) + (princ "\nIf ") + (princ name) + (princ " is a local variable, argument, or symbol in some +namespace or class exposed via scoping statements, then it should +appear in the scope. + +Debugging the scope can be done with: + M-x semantic-calculate-scope RET + +If the prefix is a global symbol, in an included file, then +your search path may be incomplete. +")))) + +;;; Utils +;; +(defun semantic-analyzer-debug-insert-tag-list (text taglist) + "Prefixing with TEXT, dump TAGLIST in a help buffer." + (princ "\n") (princ text) (princ ":\n") + + (dolist (M taglist) + (princ " ") + ;;(princ (semantic-format-tag-prototype M)) + (semantic-analyzer-debug-insert-tag M) + (princ "\n")) + ) + +(defun semantic-analyzer-debug-insert-tag (tag &optional parent) + "Display a TAG by name, with possible jumpitude. +PARENT is a possible parent (by nesting) tag." + (let ((str (semantic-format-tag-prototype tag parent))) + (if (and (semantic-tag-with-position-p tag) + (semantic-tag-file-name tag)) + (insert-button str + 'mouse-face 'custom-button-pressed-face + 'tag tag + 'action + `(lambda (button) + (let ((buff nil) + (pnt nil)) + (save-excursion + (semantic-go-to-tag + (button-get button 'tag)) + (setq buff (current-buffer)) + (setq pnt (point))) + (if (get-buffer-window buff) + (select-window (get-buffer-window buff)) + (pop-to-buffer buff t)) + (goto-char pnt) + (pulse-line-hook-function))) + ) + (princ "\"") + (princ str) + (princ "\"")) + )) + +(defvar semantic-analyzer-debug-orig nil + "The originating buffer for a help button.") + +(defun semantic-analyzer-debug-add-buttons () + "Add push-buttons to the *Help* buffer. +Look for key expressions, and add push-buttons near them." + (let ((orig-buffer (make-marker))) + (set-marker orig-buffer (point) (current-buffer)) + (save-excursion + ;; Get a buffer ready. + (set-buffer "*Help*") + (toggle-read-only -1) + (goto-char (point-min)) + (set (make-local-variable 'semantic-analyzer-debug-orig) orig-buffer) + ;; First, add do-in buttons to recommendations. + (while (re-search-forward "^\\s-*M-x \\(\\(\\w\\|\\s_\\)+\\) " nil t) + (let ((fcn (match-string 1))) + (when (not (fboundp (intern-soft fcn))) + (error "Help Err: Can't find %s" fcn)) + (end-of-line) + (insert " ") + (insert-button "[ Do It ]" + 'mouse-face 'custom-button-pressed-face + 'do-fcn fcn + 'action `(lambda (arg) + (let ((M semantic-analyzer-debug-orig)) + (set-buffer (marker-buffer M)) + (goto-char M)) + (call-interactively (quote ,(intern-soft fcn)))) + ) + )) + ;; Do something else? + + ;; Clean up the mess + (toggle-read-only 1) + (set-buffer-modified-p nil) + ))) + +(provide 'semantic/analyze/debug) + +;;; semantic/analyze/debug.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/analyze/fcn.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze/fcn.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,337 @@ +;;; semantic/analyze/fcn.el --- Analyzer support functions. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Analyzer support functions. + +;;; Code: + +(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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/analyze/refs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/analyze/refs.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,332 @@ +;;; semantic/analyze/refs.el --- Analysis of the references between tags. + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Analyze the references between tags. +;; +;; The original purpose of these analysis is to provide a way to jump +;; between a prototype and implementation. +;; +;; Finding all prototype/impl matches is hard because you have to search +;; through the entire set of allowed databases to capture all possible +;; refs. The core analysis class stores basic starting point, and then +;; entire raw search data, which is expensive to calculate. +;; +;; Once the raw data is available, queries for impl, prototype, or +;; perhaps other things become cheap. + +(require 'semantic) +(require 'semantic/analyze) +(require 'semantic/db-find) +(eval-when-compile (require 'semantic/find)) + +(declare-function data-debug-new-buffer "data-debug") +(declare-function data-debug-insert-object-slots "eieio-datadebug") +(declare-function semantic-momentary-highlight-tag "semantic/decorate") + +;;; Code: +(defclass semantic-analyze-references () + ((tag :initarg :tag + :type semantic-tag + :documentation + "The starting TAG we are providing references analysis for.") + (tagdb :initarg :tagdb + :documentation + "The database that tag can be found in.") + (scope :initarg :scope + :documentation "A Scope object.") + (rawsearchdata :initarg :rawsearchdata + :documentation + "The raw search data for TAG's name across all databases.") + ;; Note: Should I cache queried data here? I expect that searching + ;; through rawsearchdata will be super-fast, so why bother? + ) + "Class containing data from a semantic analysis.") + +(define-overloadable-function semantic-analyze-tag-references (tag &optional db) + "Analyze the references for TAG. +Returns a class with information about TAG. + +Optional argument DB is a database. It will be used to help +locate TAG. + +Use `semantic-analyze-current-tag' to debug this fcn.") + +(defun semantic-analyze-tag-references-default (tag &optional db) + "Analyze the references for TAG. +Returns a class with information about TAG. + +Optional argument DB is a database. It will be used to help +locate TAG. + +Use `semantic-analyze-current-tag' to debug this fcn." + (when (not (semantic-tag-p tag)) (signal 'wrong-type-argument (list 'semantic-tag-p tag))) + (let ((allhits nil) + (scope nil) + ) + (save-excursion + (semantic-go-to-tag tag db) + (setq scope (semantic-calculate-scope)) + + (setq allhits (semantic--analyze-refs-full-lookup tag scope)) + + (semantic-analyze-references (semantic-tag-name tag) + :tag tag + :tagdb db + :scope scope + :rawsearchdata allhits) + ))) + +;;; METHODS +;; +;; These accessor methods will calculate the useful bits from the context, and cache values +;; into the context. +(defmethod semantic-analyze-refs-impl ((refs semantic-analyze-references) &optional in-buffer) + "Return the implementations derived in the reference analyzer REFS. +Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer." + (let ((allhits (oref refs rawsearchdata)) + (impl nil) + ) + (semanticdb-find-result-mapc + (lambda (T DB) + "Examine T in the database DB, and sont it." + (let* ((ans (semanticdb-normalize-one-tag DB T)) + (aT (cdr ans)) + (aDB (car ans)) + ) + (when (not (semantic-tag-prototype-p aT)) + (when in-buffer (save-excursion (semantic-go-to-tag aT aDB))) + (push aT impl)))) + allhits) + impl)) + +(defmethod semantic-analyze-refs-proto ((refs semantic-analyze-references) &optional in-buffer) + "Return the prototypes derived in the reference analyzer REFS. +Optional argument IN-BUFFER indicates that the returned tag should be in an active buffer." + (let ((allhits (oref refs rawsearchdata)) + (proto nil)) + (semanticdb-find-result-mapc + (lambda (T DB) + "Examine T in the database DB, and sort it." + (let* ((ans (semanticdb-normalize-one-tag DB T)) + (aT (cdr ans)) + (aDB (car ans)) + ) + (when (semantic-tag-prototype-p aT) + (when in-buffer (save-excursion (semantic-go-to-tag aT aDB))) + (push aT proto)))) + allhits) + proto)) + +;;; LOOKUP +;; +(defun semantic--analyze-refs-full-lookup (tag scope) + "Perform a full lookup for all occurances of TAG in the current project. +TAG should be the tag currently under point. +PARENT is the list of tags that are parents to TAG by +containment, as opposed to reference." + (if (not (oref scope parents)) + ;; If this tag has some named parent, but is not + (semantic--analyze-refs-full-lookup-simple tag) + + ;; We have some sort of lineage we need to consider when we do + ;; our side lookup of tags. + (semantic--analyze-refs-full-lookup-with-parents tag scope) + )) + +(defun semantic--analyze-refs-find-child-in-find-results (find-results name class) + "Find in FIND-RESULT a tag NAME which is a child of a tag in FIND-RESULTS. +CLASS is the class of the tag that ought to be returned." + (let ((ans nil) + (subans nil)) + ;; Loop over each segment of the find results. + (dolist (FDB find-results) + (setq subans nil) + ;; Loop over each tag in the find results. + (dolist (T (cdr FDB)) + ;; For each tag, get the children. + (let* ((chil (semantic-tag-type-members T)) + (match (semantic-find-tags-by-name name chil))) + ;; Go over the matches, looking for matching tag class. + (dolist (M match) + (when (semantic-tag-of-class-p M class) + (push M subans))))) + ;; Store current matches into a new find results. + (when subans + (push (cons (car FDB) subans) ans)) + ) + ans)) + +(defun semantic--analyze-refs-find-tags-with-parent (find-results parents) + "Find in FIND-RESULTS all tags with PARNTS. +NAME is the name of the tag needing finding. +PARENTS is a list of names." + (let ((ans nil)) + (semanticdb-find-result-mapc + (lambda (tag db) + (let* ((p (semantic-tag-named-parent tag)) + (ps (when (stringp p) + (semantic-analyze-split-name p)))) + (when (stringp ps) (setq ps (list ps))) + (when (and ps (equal ps parents)) + ;; We could optimize this, but it seems unlikely. + (push (list db tag) ans)) + )) + find-results) + ans)) + +(defun semantic--analyze-refs-full-lookup-with-parents (tag scope) + "Perform a lookup for all occurances of TAG based on TAG's SCOPE. +TAG should be the tag currently under point." + (let* ((classmatch (semantic-tag-class tag)) + (plist (mapcar (lambda (T) (semantic-tag-name T)) (oref scope parents))) + ;; The first item in the parent list + (name (car plist)) + ;; Stuff from the simple list. + (simple (semantic--analyze-refs-full-lookup-simple tag t)) + ;; Find all hits for the first parent name. + (brute (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-name-method table name tags) + ) + nil nil t)) + ;; Prime the answer. + (answer (semantic--analyze-refs-find-tags-with-parent simple plist)) + ) + ;; First parent is already search to initialize "brute". + (setq plist (cdr plist)) + ;; Go through the list of parents, and try to find matches. + ;; As we cycle through plist, for each level look for NAME, + ;; and compare the named-parent, and also dive into the next item of + ;; plist. + (while (and plist brute) + + ;; Find direct matches + (let* ((direct (semantic--analyze-refs-find-child-in-find-results + brute (semantic-tag-name tag) classmatch)) + (pdirect (semantic--analyze-refs-find-tags-with-parent + direct plist))) + (setq answer (append pdirect answer))) + + ;; The next set of search items. + (setq brute (semantic--analyze-refs-find-child-in-find-results + brute (car plist) 'type)) + + (setq plist (cdr plist))) + + ;; Brute now has the children from the very last match. + (let* ((direct (semantic--analyze-refs-find-child-in-find-results + brute (semantic-tag-name tag) classmatch)) + ) + (setq answer (append direct answer))) + + answer)) + +(defun semantic--analyze-refs-full-lookup-simple (tag &optional noerror) + "Perform a simple lookup for occurances of TAG in the current project. +TAG should be the tag currently under point. +Optional NOERROR means don't throw errors on failure to find something. +This only compares the tag name, and does not infer any matches in namespaces, +or parts of some other data structure. +Only works for tags in the global namespace." + (let* ((name (semantic-tag-name tag)) + (brute (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-name-method table name tags) + ) + nil nil t)) + ) + + (when (and (not brute) (not noerror)) + ;; An error, because tag under point ought to be found. + (error "Cannot find any references to %s in wide search" name)) + + (let* ((classmatch (semantic-tag-class tag)) + (RES + (semanticdb-find-tags-collector + (lambda (table tags) + (semantic-find-tags-by-class classmatch tags) + ;; @todo - Add parent check also. + ) + brute nil))) + + (when (and (not RES) (not noerror)) + (error "Cannot find any definitions for %s in wide search" + (semantic-tag-name tag))) + + ;; Return the matching tags and databases. + RES))) + + +;;; USER COMMANDS +;; +;;;###autoload +(defun semantic-analyze-current-tag () + "Analyze the tag under point." + (interactive) + (let* ((tag (semantic-current-tag)) + (start (current-time)) + (sac (semantic-analyze-tag-references tag)) + (end (current-time)) + ) + (message "Analysis took %.2f seconds." (semantic-elapsed-time start end)) + (if sac + (progn + (require 'eieio-datadebug) + (data-debug-new-buffer "*Analyzer Reference ADEBUG*") + (data-debug-insert-object-slots sac "]")) + (message "No Context to analyze here.")))) + +;;;###autoload +(defun semantic-analyze-proto-impl-toggle () + "Toggle between the implementation, and a prototype of tag under point." + (interactive) + (require 'semantic/decorate) + (semantic-fetch-tags) + (let* ((tag (semantic-current-tag)) + (sar (if tag + (semantic-analyze-tag-references tag) + (error "Point must be in a declaration"))) + (target (if (semantic-tag-prototype-p tag) + (car (semantic-analyze-refs-impl sar t)) + (car (semantic-analyze-refs-proto sar t)))) + ) + + (when (not target) + (error "Could not find suitable %s" + (if (semantic-tag-prototype-p tag) "implementation" "prototype"))) + + (push-mark) + (semantic-go-to-tag target) + (switch-to-buffer (current-buffer)) + (semantic-momentary-highlight-tag target)) + ) + +(provide 'semantic/analyze/refs) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/analyze/refs" +;; End: + +;;; semantic/analyze/refs.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/bovine.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,297 @@ +;;; 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 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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) + +(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) + + + +;; 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! + (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))) + (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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/bovine/c-by.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/c-by.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,2196 @@ +;;; 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 . + +;;; 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() // 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 ;") + ("default" summary "switch () { case : code; ... default: code; }") + ("case" summary "switch () { case : code; ... default: code; }") + ("switch" summary "switch () { case : code; ... default: code; }") + ("for" summary "for(; ; ) { code }") + ("while" summary "do { code } while (); or while () { code };") + ("do" summary " do { code } while ();") + ("else" summary "if () { code } [ else { code } ]") + ("if" summary "if () { code } [ else { code } ]") + ("friend" summary "friend class ") + ("catch" summary "try { } catch { }") + ("try" summary "try { } catch { }") + ("reentrant" summary " () reentrant ...") + ("throw" summary " () throw () ...") + ("template" summary "template TYPE_OR_FUNCTION") + ("delete" summary "delete ;") + ("new" summary "new ();") + ("using" summary "using ;") + ("namespace" summary "Namespace Declaration: namespace { ... };") + ("typename" summary "typename is used to handle a qualified name as a typename;") + ("class" summary "Class Declaration: class [:parents] { ... };") + ("typedef" summary "Arbitrary Type Declaration: typedef ;") + ("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 ...") + ("virtual" summary "Method Modifier: virtual (...) ...") + ("inline" summary "Function Modifier: inline (...) {...};") + ("unsigned" summary "Numeric Type Modifier: unsigned ...") + ("signed" summary "Numeric Type Modifier: signed ...") + ("register" summary "Declaration Modifier: register ...") + ("volatile" summary "Declaration Modifier: volatile ...") + ("const" summary "Declaration Modifier: const ...") + ("static" summary "Declaration Modifier: static ...") + ("extern" summary "Declaration Modifier: extern ..."))) + "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) + )) + +;;; Epilogue +;; + +(provide 'semantic/bovine/c-by) + +;;; semantic/bovine/c-by.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/bovine/c.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/c.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,1736 @@ +;;; 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 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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 'semantic/idle) +(require 'semantic/lex-spp) +(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'.") + + +;;; 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) + + +;;; 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) + + +;;; 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 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'." + (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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/bovine/debug.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/debug.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,147 @@ +;;; semantic/bovine/debug.el --- Debugger support for bovinator + +;;; Copyright (C) 2003 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Implementation of the semantic debug support framework for the +;; bovine parser. +;; + +(require 'semantic/debug) +(require 'semantic/find) + +;;; Code: + +;;; Support a frame for the Bovinator +;; +(defclass semantic-bovine-debug-frame (semantic-debug-frame) + ((nonterm :initarg :nonterm + :type symbol + :documentation + "The name of the semantic nonterminal for this frame.") + (rule :initarg :rule + :type number + :documentation + "The index into NONTERM's rule list. 0 based.") + (match :initarg :match + :type number + :documentation + "The index into NONTERM's RULE's match. 0 based..") + (collection :initarg :collection + :type list + :documentation + "List of things matched so far.") + (lextoken :initarg :lextoken + :type list + :documentation + "A Token created by `semantic-lex-token'. +This is the lexical token being matched by the parser.") + ) + "Debugger frame representation for the bovinator.") + +(defun semantic-bovine-debug-create-frame (nonterm rule match collection + lextoken) + "Create one bovine frame. +NONTERM is the name of a rule we are currently parsing. +RULE is the index into the list of rules in NONTERM. +MATCH is the index into the list of matches in RULE. +For example: + this: that + | other thing + | here + ; +The NONTERM is THIS. +The RULE is for \"thing\" is 1. +The MATCH for \"thing\" is 1. +COLLECTION is a list of `things' that have been matched so far. +LEXTOKEN, is a token returned by the lexer which is being matched." + (let ((frame (semantic-bovine-debug-frame "frame" + :nonterm nonterm + :rule rule + :match match + :collection collection + :lextoken lextoken))) + (semantic-debug-set-frame semantic-debug-current-interface + frame) + frame)) + +(defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame)) + "Highlight one parser frame." + (let* ((nonterm (oref frame nonterm)) + (pb (oref semantic-debug-current-interface parser-buffer)) + (start (semantic-brute-find-tag-by-class 'start pb)) + ) + ;; Make sure we get a good rule name, and that it is a string + (if (and (eq nonterm 'bovine-toplevel) start) + (setq nonterm (semantic-tag-name (car start))) + (setq nonterm (symbol-name nonterm))) + + (semantic-debug-highlight-rule semantic-debug-current-interface + nonterm + (oref frame rule) + (oref frame match)) + (semantic-debug-highlight-lexical-token semantic-debug-current-interface + (oref frame lextoken)) + )) + +(defmethod semantic-debug-frame-info ((frame semantic-debug-frame)) + "Display info about this one parser frame." + (message "%S" (oref frame collection)) + ) + +;;; Lisp error thrown frame. +;; +(defclass semantic-bovine-debug-error-frame (semantic-debug-frame) + ((condition :initarg :condition + :documentation + "An error condition caught in an action.") + ) + "Debugger frame representaion of a lisp error thrown during parsing.") + +(defun semantic-create-bovine-debug-error-frame (condition) + "Create an error frame for bovine debugger. +Argument CONDITION is the thrown error condition." + (let ((frame (semantic-bovine-debug-error-frame "frame" + :condition condition))) + (semantic-debug-set-frame semantic-debug-current-interface + frame) + frame)) + +(defmethod semantic-debug-frame-highlight ((frame semantic-bovine-debug-error-frame)) + "Highlight a frame from an action." + ;; How do I get the location of the action in the source buffer? + ) + +(defmethod semantic-debug-frame-info ((frame semantic-bovine-debug-error-frame)) + "Display info about the error thrown." + (message "Error: %S" (oref frame condition))) + +;;; Parser support for the debugger +;; +(defclass semantic-bovine-debug-parser (semantic-debug-parser) + ( + ) + "Represents a parser and its state.") + + +(provide 'semantic/bovine/debug) + +;;; semantic/bovine/debug.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/bovine/el.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/el.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,966 @@ +;;; semantic/bovine/el.el --- Semantic details for Emacs Lisp + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Use the Semantic Bovinator for Emacs Lisp + +(require 'semantic) +(require 'semantic/bovine) +(require 'find-func) + +(require 'semantic/ctxt) +(require 'semantic/format) +(require 'thingatpt) + +;;; Code: + +;;; Lexer +;; +(define-lex semantic-emacs-lisp-lexer + "A simple lexical analyzer for Emacs Lisp. +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) + +;;; Parser +;; +(defvar semantic--elisp-parse-table + `((bovine-toplevel + (semantic-list + ,(lambda (vals start end) + (let ((tag (semantic-elisp-use-read (car vals)))) + (cond + ((and (listp tag) (semantic-tag-p (car tag))) + ;; We got a list of tags back. This list is + ;; returned here in the correct order, but this + ;; list gets reversed later, putting the correctly ordered + ;; items into reverse order later. + (nreverse tag)) + ((semantic--tag-expanded-p tag) + ;; At this point, if `semantic-elisp-use-read' returned an + ;; already expanded tag (from definitions parsed inside an + ;; eval and compile wrapper), just pass it! + tag) + (t + ;; We got the basics of a single tag. + (append tag (list start end)))))))) + ) + "Top level bovination table for elisp.") + +(defun semantic-elisp-desymbolify (arglist) + "Convert symbols to strings for ARGLIST." + (let ((out nil)) + (while arglist + (setq out + (cons + (if (symbolp (car arglist)) + (symbol-name (car arglist)) + (if (and (listp (car arglist)) + (symbolp (car (car arglist)))) + (symbol-name (car (car arglist))) + (format "%S" (car arglist)))) + out) + arglist (cdr arglist))) + (nreverse out))) + +(defun semantic-elisp-desymbolify-args (arglist) + "Convert symbols to strings for ARGLIST." + (let ((in (semantic-elisp-desymbolify arglist)) + (out nil)) + (dolist (T in) + (when (not (string-match "^&" T)) + (push T out))) + (nreverse out))) + +(defun semantic-elisp-clos-slot-property-string (slot property) + "For SLOT, a string representing PROPERTY." + (let ((p (member property slot))) + (if (not p) + nil + (setq p (cdr p)) + (cond + ((stringp (car p)) + (car p)) + ((or (symbolp (car p)) + (listp (car p)) + (numberp (car p))) + (format "%S" (car p))) + (t nil))))) + +(defun semantic-elisp-clos-args-to-semantic (partlist) + "Convert a list of CLOS class slot PARTLIST to `variable' tags." + (let (vars part v) + (while partlist + (setq part (car partlist) + partlist (cdr partlist) + v (semantic-tag-new-variable + (symbol-name (car part)) + (semantic-elisp-clos-slot-property-string part :type) + (semantic-elisp-clos-slot-property-string part :initform) + ;; Attributes + :protection (semantic-elisp-clos-slot-property-string + part :protection) + :static-flag (equal (semantic-elisp-clos-slot-property-string + part :allocation) + ":class") + :documentation (semantic-elisp-clos-slot-property-string + part :documentation)) + vars (cons v vars))) + (nreverse vars))) + +(defun semantic-elisp-form-to-doc-string (form) + "After reading a form FORM, covert it to a doc string. +For Emacs Lisp, sometimes that string is non-existant. +Sometimes it is a form which is evaluated at compile time, permitting +compound strings." + (cond ((stringp form) form) + ((and (listp form) (eq (car form) 'concat) + (stringp (nth 1 form))) + (nth 1 form)) + (t nil))) + +(defvar semantic-elisp-store-documentation-in-tag nil + "*When non-nil, store documentation strings in the created tags.") + +(defun semantic-elisp-do-doc (str) + "Return STR as a documentation string IF they are enabled." + (when semantic-elisp-store-documentation-in-tag + (semantic-elisp-form-to-doc-string str))) + +(defmacro semantic-elisp-setup-form-parser (parser &rest symbols) + "Install the function PARSER as the form parser for SYMBOLS. +SYMBOLS is a list of symbols identifying the forms to parse. +PARSER is called on every forms whose first element (car FORM) is +found in SYMBOLS. It is passed the parameters FORM, START, END, +where: + +- FORM is an Elisp form read from the current buffer. +- START and END are the beginning and end location of the + corresponding data in the current buffer." + (let ((sym (make-symbol "sym"))) + `(dolist (,sym ',symbols) + (put ,sym 'semantic-elisp-form-parser #',parser)))) +(put 'semantic-elisp-setup-form-parser 'lisp-indent-function 1) + +(defmacro semantic-elisp-reuse-form-parser (symbol &rest symbols) + "Reuse the form parser of SYMBOL for forms identified by SYMBOLS. +See also `semantic-elisp-setup-form-parser'." + (let ((parser (make-symbol "parser")) + (sym (make-symbol "sym"))) + `(let ((,parser (get ',symbol 'semantic-elisp-form-parser))) + (or ,parser + (signal 'wrong-type-argument + '(semantic-elisp-form-parser ,symbol))) + (dolist (,sym ',symbols) + (put ,sym 'semantic-elisp-form-parser ,parser))))) + +(defun semantic-elisp-use-read (sl) + "Use `read' on the semantic list SL. +Return a bovination list to use." + (let* ((start (car sl)) + (end (cdr sl)) + (form (read (buffer-substring-no-properties start end)))) + (cond + ;; If the first elt is a list, then it is some arbitrary code. + ((listp (car form)) + (semantic-tag-new-code "anonymous" nil) + ) + ;; A special form parser is provided, use it. + ((and (car form) (symbolp (car form)) + (get (car form) 'semantic-elisp-form-parser)) + (funcall (get (car form) 'semantic-elisp-form-parser) + form start end)) + ;; Produce a generic code tag by default. + (t + (semantic-tag-new-code (format "%S" (car form)) nil) + )))) + +;;; Form parsers +;; +(semantic-elisp-setup-form-parser + (lambda (form start end) + (semantic-tag-new-function + (symbol-name (nth 2 form)) + nil + '("form" "start" "end") + :form-parser t + )) + semantic-elisp-setup-form-parser) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((tags + (condition-case foo + (semantic-parse-region start end nil 1) + (error (message "MUNGE: %S" foo) + nil)))) + (if (semantic-tag-p (car-safe tags)) + tags + (semantic-tag-new-code (format "%S" (car form)) nil)))) + eval-and-compile + eval-when-compile + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (semantic-tag-new-function + (symbol-name (nth 1 form)) + nil + (semantic-elisp-desymbolify-args (nth 2 form)) + :user-visible-flag (eq (car-safe (nth 4 form)) 'interactive) + :documentation (semantic-elisp-do-doc (nth 3 form)) + :overloadable (or (eq (car form) 'define-overload) + (eq (car form) 'define-overloadable-function)) + )) + defun + defun* + defsubst + defmacro + define-overload ;; @todo - remove after cleaning up semantic. + define-overloadable-function + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form)))) + (semantic-tag-new-variable + (symbol-name (nth 1 form)) + nil + (nth 2 form) + :user-visible-flag (and doc + (> (length doc) 0) + (= (aref doc 0) ?*)) + :constant-flag (eq (car form) 'defconst) + :documentation (semantic-elisp-do-doc doc) + ))) + defvar + defconst + defcustom + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form)))) + (semantic-tag-new-variable + (symbol-name (nth 1 form)) + "face" + (nth 2 form) + :user-visible-flag (and doc + (> (length doc) 0) + (= (aref doc 0) ?*)) + :documentation (semantic-elisp-do-doc doc) + ))) + defface + ) + + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form)))) + (semantic-tag-new-variable + (symbol-name (nth 1 form)) + "image" + (nth 2 form) + :user-visible-flag (and doc + (> (length doc) 0) + (= (aref doc 0) ?*)) + :documentation (semantic-elisp-do-doc doc) + ))) + defimage + defezimage + ) + + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((doc (semantic-elisp-form-to-doc-string (nth 3 form)))) + (semantic-tag + (symbol-name (nth 1 form)) + 'customgroup + :value (nth 2 form) + :user-visible-flag t + :documentation (semantic-elisp-do-doc doc) + ))) + defgroup + ) + + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (semantic-tag-new-function + (symbol-name (cadr (cadr form))) + nil nil + :user-visible-flag (and (nth 4 form) + (not (eq (nth 4 form) 'nil))) + :prototype-flag t + :documentation (semantic-elisp-do-doc (nth 3 form)))) + autoload + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let* ((a2 (nth 2 form)) + (a3 (nth 3 form)) + (args (if (listp a2) a2 a3)) + (doc (nth (if (listp a2) 3 4) form))) + (semantic-tag-new-function + (symbol-name (nth 1 form)) + nil + (if (listp (car args)) + (cons (symbol-name (caar args)) + (semantic-elisp-desymbolify-args (cdr args))) + (semantic-elisp-desymbolify-args (cdr args))) + :parent (if (listp (car args)) (symbol-name (cadr (car args))) nil) + :documentation (semantic-elisp-do-doc doc) + ))) + defmethod + defgeneric + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (semantic-tag-new-function + (symbol-name (nth 1 form)) + nil + (semantic-elisp-desymbolify (nth 2 form)) + )) + defadvice + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((docpart (nthcdr 4 form))) + (semantic-tag-new-type + (symbol-name (nth 1 form)) + "class" + (semantic-elisp-clos-args-to-semantic (nth 3 form)) + (semantic-elisp-desymbolify (nth 2 form)) + :typemodifiers (semantic-elisp-desymbolify + (unless (stringp (car docpart)) docpart)) + :documentation (semantic-elisp-do-doc + (if (stringp (car docpart)) + (car docpart) + (cadr (member :documentation docpart)))) + ))) + defclass + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((slots (nthcdr 2 form))) + ;; Skip doc string if present. + (and (stringp (car slots)) + (setq slots (cdr slots))) + (semantic-tag-new-type + (symbol-name (if (consp (nth 1 form)) + (car (nth 1 form)) + (nth 1 form))) + "struct" + (semantic-elisp-desymbolify slots) + (cons nil nil) + ))) + defstruct + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (semantic-tag-new-function + (symbol-name (nth 1 form)) + nil nil + :lexical-analyzer-flag t + :documentation (semantic-elisp-do-doc (nth 2 form)) + )) + define-lex + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((args (nth 3 form))) + (semantic-tag-new-function + (symbol-name (nth 1 form)) + nil + (and (listp args) (semantic-elisp-desymbolify args)) + :override-function-flag t + :parent (symbol-name (nth 2 form)) + :documentation (semantic-elisp-do-doc (nth 4 form)) + ))) + define-mode-overload-implementation ;; obsoleted + define-mode-local-override + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (semantic-tag-new-variable + (symbol-name (nth 2 form)) + nil + (nth 3 form) ; default value + :override-variable-flag t + :parent (symbol-name (nth 1 form)) + :documentation (semantic-elisp-do-doc (nth 4 form)) + )) + defvar-mode-local + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((name (nth 1 form))) + (semantic-tag-new-include + (symbol-name (if (eq (car-safe name) 'quote) + (nth 1 name) + name)) + nil + :directory (nth 2 form)))) + require + ) + +(semantic-elisp-setup-form-parser + (lambda (form start end) + (let ((name (nth 1 form))) + (semantic-tag-new-package + (symbol-name (if (eq (car-safe name) 'quote) + (nth 1 name) + name)) + (nth 3 form)))) + provide + ) + +;;; Mode setup +;; +(define-mode-local-override semantic-dependency-tag-file + emacs-lisp-mode (tag) + "Find the file BUFFER depends on described by TAG." + (if (fboundp 'find-library-name) + (condition-case nil + ;; Try an Emacs 22 fcn. This throws errors. + (find-library-name (semantic-tag-name tag)) + (error + (message "semantic: connot find source file %s" + (semantic-tag-name tag)))) + ;; No handy function available. (Older Emacsen) + (let* ((lib (locate-library (semantic-tag-name tag))) + (name (if lib (file-name-sans-extension lib) nil)) + (nameel (concat name ".el"))) + (cond + ((and name (file-exists-p nameel)) nameel) + ((and name (file-exists-p (concat name ".el.gz"))) + ;; This is the linux distro case. + (concat name ".el.gz")) + ;; source file does not exists + (name + (message "semantic: cannot find source file %s" (concat name ".el"))) + (t + nil))))) + +;;; DOC Strings +;; +(defun semantic-emacs-lisp-overridable-doc (tag) + "Return the documentation string generated for overloadable functions. +Fetch the item for TAG. Only returns info about what symbols can be +used to perform the override." + (if (and (eq (semantic-tag-class tag) 'function) + (semantic-tag-get-attribute tag :overloadable)) + ;; Calc the doc to use for the overloadable symbols. + (overload-docstring-extension (intern (semantic-tag-name tag))) + "")) + +(defun semantic-emacs-lisp-obsoleted-doc (tag) + "Indicate that TAG is a new name that has obsoleted some old name. +Unfortunately, this requires that the tag in question has been loaded +into Emacs Lisp's memory." + (let ((obsoletethis (intern-soft (semantic-tag-name tag))) + (obsoletor nil)) + ;; This asks if our tag is available in the Emacs name space for querying. + (when obsoletethis + (mapatoms (lambda (a) + (let ((oi (get a 'byte-obsolete-info))) + (if (and oi (eq (car oi) obsoletethis)) + (setq obsoletor a))))) + (if obsoletor + (format "\n@obsolete{%s,%s}" obsoletor (semantic-tag-name tag)) + "")))) + +(define-mode-local-override semantic-documentation-for-tag + emacs-lisp-mode (tag &optional nosnarf) + "Return the documentation string for TAG. +Optional argument NOSNARF is ignored." + (let ((d (semantic-tag-docstring tag))) + (when (not d) + (cond ((semantic-tag-with-position-p tag) + ;; Doc isn't in the tag itself. Lets pull it out of the + ;; sources. + (let ((semantic-elisp-store-documentation-in-tag t)) + (setq tag (with-current-buffer (semantic-tag-buffer tag) + (goto-char (semantic-tag-start tag)) + (semantic-elisp-use-read + ;; concoct a lexical token. + (cons (semantic-tag-start tag) + (semantic-tag-end tag)))) + d (semantic-tag-docstring tag)))) + ;; The tag may be the result of a system search. + ((intern-soft (semantic-tag-name tag)) + (let ((sym (intern-soft (semantic-tag-name tag)))) + ;; Query into the global table o stuff. + (cond ((eq (semantic-tag-class tag) 'function) + (setq d (documentation sym))) + (t + (setq d (documentation-property + sym 'variable-documentation))))) + ;; Label it as system doc.. perhaps just for debugging + ;; purposes. + (if d (setq d (concat "Sytem Doc: \n" d))) + )) + ) + + (when d + (concat + (substitute-command-keys + (if (and (> (length d) 0) (= (aref d 0) ?*)) + (substring d 1) + d)) + (semantic-emacs-lisp-overridable-doc tag) + (semantic-emacs-lisp-obsoleted-doc tag))))) + +;;; Tag Features +;; +(define-mode-local-override semantic-tag-include-filename emacs-lisp-mode + (tag) + "Return the name of the tag with .el appended. +If there is a detail, prepend that directory." + (let ((name (semantic-tag-name tag)) + (detail (semantic-tag-get-attribute tag :directory))) + (concat (expand-file-name name detail) ".el"))) + +(define-mode-local-override semantic-insert-foreign-tag + emacs-lisp-mode (tag) + "Insert TAG at point. +Attempts a simple prototype for calling or using TAG." + (cond ((semantic-tag-of-class-p tag 'function) + (insert "(" (semantic-tag-name tag) " )") + (forward-char -1)) + (t + (insert (semantic-tag-name tag))))) + +(define-mode-local-override semantic-tag-protection + emacs-lisp-mode (tag &optional parent) + "Return the protection of TAG in PARENT. +Override function for `semantic-tag-protection'." + (let ((prot (semantic-tag-get-attribute tag :protection))) + (cond + ;; If a protection is not specified, AND there is a parent + ;; data type, then it is public. + ((and (not prot) parent) 'public) + ((string= prot ":public") 'public) + ((string= prot "public") 'public) + ((string= prot ":private") 'private) + ((string= prot "private") 'private) + ((string= prot ":protected") 'protected) + ((string= prot "protected") 'protected)))) + +(define-mode-local-override semantic-tag-static-p + emacs-lisp-mode (tag &optional parent) + "Return non-nil if TAG is static in PARENT class. +Overrides `semantic-nonterminal-static'." + ;; This can only be true (theoretically) in a class where it is assigned. + (semantic-tag-get-attribute tag :static-flag)) + +;;; Context parsing +;; +;; Emacs lisp is very different from C,C++ which most context parsing +;; functions are written. Support them here. +(define-mode-local-override semantic-up-context emacs-lisp-mode + (&optional point bounds-type) + "Move up one context in an Emacs Lisp function. +A Context in many languages is a block with it's own local variables. +In Emacs, we will move up lists and stop when one starts with one of +the following context specifiers: + `let', `let*', `defun', `with-slots' +Returns non-nil it is not possible to go up a context." + (let ((last-up (semantic-up-context-default))) + (while + (and (not (looking-at + "(\\(let\\*?\\|def\\(un\\|method\\|generic\\|\ +define-mode-overload\\)\ +\\|with-slots\\)")) + (not last-up)) + (setq last-up (semantic-up-context-default))) + last-up)) + + +(define-mode-local-override semantic-ctxt-current-function emacs-lisp-mode + (&optional point same-as-symbol-return) + "Return a string which is the current function being called." + (save-excursion + (if point (goto-char point) (setq point (point))) + ;; (semantic-beginning-of-command) + (if (condition-case nil + (and (save-excursion + (up-list -2) + (looking-at "((")) + (save-excursion + (up-list -3) + (looking-at "(let"))) + (error nil)) + ;; This is really a let statement, not a function. + nil + (let ((fun (condition-case nil + (save-excursion + (up-list -1) + (forward-char 1) + (buffer-substring-no-properties + (point) (progn (forward-sexp 1) + (point)))) + (error nil)) + )) + (when fun + ;; Do not return FUN IFF the cursor is on FUN. + ;; Huh? Thats because if cursor is on fun, it is + ;; the current symbol, and not the current function. + (if (save-excursion + (condition-case nil + (progn (forward-sexp -1) + (and + (looking-at (regexp-quote fun)) + (<= point (+ (point) (length fun)))) + ) + (error t))) + ;; Go up and try again. + same-as-symbol-return + ;; We are ok, so get it. + (list fun)) + )) + ))) + + +(define-mode-local-override semantic-get-local-variables emacs-lisp-mode + (&optional point) + "Return a list of local variables for POINT. +Scan backwards from point at each successive function. For all occurances +of `let' or `let*', grab those variable names." + (let* ((vars nil) + (fn nil)) + (save-excursion + (while (setq fn (car (semantic-ctxt-current-function-emacs-lisp-mode + (point) (list t)))) + (cond + ((eq fn t) + nil) + ((member fn '("let" "let*" "with-slots")) + ;; Snarf variables + (up-list -1) + (forward-char 1) + (forward-symbol 1) + (skip-chars-forward "* \t\n") + (let ((varlst (read (buffer-substring-no-properties + (point) + (save-excursion + (forward-sexp 1) + (point)))))) + (while varlst + (let* ((oneelt (car varlst)) + (name (if (symbolp oneelt) + oneelt + (car oneelt)))) + (setq vars (cons (semantic-tag-new-variable + (symbol-name name) + nil nil) + vars))) + (setq varlst (cdr varlst))) + )) + ((string= fn "lambda") + ;; Snart args... + (up-list -1) + (forward-char 1) + (forward-word 1) + (skip-chars-forward "* \t\n") + (let ((arglst (read (buffer-substring-no-properties + (point) + (save-excursion + (forward-sexp 1) + (point)))))) + (while arglst + (let* ((name (car arglst))) + (when (/= ?& (aref (symbol-name name) 0)) + (setq vars (cons (semantic-tag-new-variable + (symbol-name name) + nil nil) + vars)))) + (setq arglst (cdr arglst))) + )) + ) + (up-list -1))) + (nreverse vars))) + +(define-mode-local-override semantic-end-of-command emacs-lisp-mode + () + "Move cursor to the end of the current command. +In emacs lisp this is easilly defined by parenthisis bounding." + (condition-case nil + (up-list 1) + (error nil))) + +(define-mode-local-override semantic-beginning-of-command emacs-lisp-mode + () + "Move cursor to the beginning of the current command. +In emacs lisp this is easilly defined by parenthisis bounding." + (condition-case nil + (progn + (up-list -1) + (forward-char 1)) + (error nil))) + +(define-mode-local-override semantic-ctxt-current-symbol emacs-lisp-mode + (&optional point) + "List the symbol under point." + (save-excursion + (if point (goto-char point)) + (require 'thingatpt) + (let ((sym (thing-at-point 'symbol))) + (if sym (list sym))) + )) + + +(define-mode-local-override semantic-ctxt-current-assignment emacs-lisp-mode + (&optional point) + "What is the variable being assigned into at POINT?" + (save-excursion + (if point (goto-char point)) + (let ((fn (semantic-ctxt-current-function point)) + (point (point))) + ;; We should never get lists from here. + (if fn (setq fn (car fn))) + (cond + ;; SETQ + ((and fn (or (string= fn "setq") (string= fn "set"))) + (save-excursion + (condition-case nil + (let ((count 0) + (lastodd nil) + (start nil)) + (up-list -1) + (down-list 1) + (forward-sexp 1) + ;; Skip over sexp until we pass point. + (while (< (point) point) + (setq count (1+ count)) + (forward-comment 1) + (setq start (point)) + (forward-sexp 1) + (if (= (% count 2) 1) + (setq lastodd + (buffer-substring-no-properties start (point)))) + ) + (if lastodd (list lastodd)) + ) + (error nil)))) + ;; This obscure thing finds let statements. + ((condition-case nil + (and + (save-excursion + (up-list -2) + (looking-at "((")) + (save-excursion + (up-list -3) + (looking-at "(let"))) + (error nil)) + (save-excursion + (semantic-beginning-of-command) + ;; Use func finding code, since it is the same format. + (semantic-ctxt-current-symbol))) + ;; + ;; DEFAULT- nothing + (t nil)) + ))) + +(define-mode-local-override semantic-ctxt-current-argument emacs-lisp-mode + (&optional point) + "Return the index into the argument the cursor is in, or nil." + (save-excursion + (if point (goto-char point)) + (if (looking-at "\\<\\w") + (forward-char 1)) + (let ((count 0)) + (while (condition-case nil + (progn + (forward-sexp -1) + t) + (error nil)) + (setq count (1+ count))) + (cond ((= count 0) + 0) + (t (1- count)))) + )) + +(define-mode-local-override semantic-ctxt-current-class-list emacs-lisp-mode + (&optional point) + "Return a list of tag classes allowed at POINT. +Emacs Lisp knows much more about the class of the tag needed to perform +completion than some langauges. We distincly know if we are to be +a function name, variable name, or any type of symbol. We could identify +fields and such to, but that is for some other day." + (save-excursion + (if point (goto-char point)) + (setq point (point)) + (condition-case nil + (let ((count 0)) + (up-list -1) + (forward-char 1) + (while (< (point) point) + (setq count (1+ count)) + (forward-sexp 1)) + (if (= count 1) + '(function) + '(variable)) + ) + (error '(variable))) + )) + +;;; Formatting +;; +(define-mode-local-override semantic-format-tag-abbreviate emacs-lisp-mode + (tag &optional parent color) + "Return an abbreviated string describing tag." + (let ((class (semantic-tag-class tag)) + (name (semantic-format-tag-name tag parent color)) + ) + (cond + ((eq class 'function) + (concat "(" name ")")) + (t + (semantic-format-tag-abbreviate-default tag parent color))))) + +(define-mode-local-override semantic-format-tag-prototype emacs-lisp-mode + (tag &optional parent color) + "Return a prototype string describing tag. +In Emacs Lisp, a prototype for something may start (autoload ...). +This is certainly not expected if this is used to display a summary. +Make up something else. When we go to write something that needs +a real Emacs Lisp protype, we can fix it then." + (let ((class (semantic-tag-class tag)) + (name (semantic-format-tag-name tag parent color)) + ) + (cond + ((eq class 'function) + (let* ((args (semantic-tag-function-arguments tag)) + (argstr (semantic--format-tag-arguments args + #'identity + color))) + (concat "(" name (if args " " "") + argstr + ")"))) + (t + (semantic-format-tag-prototype-default tag parent color))))) + +(define-mode-local-override semantic-format-tag-concise-prototype emacs-lisp-mode + (tag &optional parent color) + "Return a concise prototype string describing tag. +See `semantic-format-tag-prototype' for Emacs Lisp for more details." + (semantic-format-tag-prototype tag parent color)) + +(define-mode-local-override semantic-format-tag-uml-prototype emacs-lisp-mode + (tag &optional parent color) + "Return a uml prototype string describing tag. +See `semantic-format-tag-prototype' for Emacs Lisp for more details." + (semantic-format-tag-prototype tag parent color)) + +;;; IA Commands +;; +(define-mode-local-override semantic-ia-insert-tag + emacs-lisp-mode (tag) + "Insert TAG into the current buffer based on completion." + ;; This function by David is a tweaked version of the original. + (insert (semantic-tag-name tag)) + (let ((tt (semantic-tag-class tag)) + (args (semantic-tag-function-arguments tag))) + (cond ((eq tt 'function) + (if args + (insert " ") + (insert ")"))) + (t nil)))) + +;;; Lexical features and setup +;; +(defvar-mode-local emacs-lisp-mode semantic-lex-analyzer + 'semantic-emacs-lisp-lexer) + +(defvar-mode-local emacs-lisp-mode semantic--parse-table + semantic--elisp-parse-table) + +(defvar-mode-local emacs-lisp-mode semantic-function-argument-separator + " ") + +(defvar-mode-local emacs-lisp-mode semantic-function-argument-separation-character + " ") + +(defvar-mode-local emacs-lisp-mode semantic-symbol->name-assoc-list + '( + (type . "Types") + (variable . "Variables") + (function . "Defuns") + (include . "Requires") + (package . "Provides") + )) + +(defvar-mode-local emacs-lisp-mode imenu-create-index-function + 'semantic-create-imenu-index) + +(defvar-mode-local emacs-lisp-mode semantic-stickyfunc-sticky-classes + '(function type variable) + "Add variables. +ELisp variables can be pretty long, so track this one too.") + +(define-child-mode lisp-mode emacs-lisp-mode + "Make `lisp-mode' inherits mode local behavior from `emacs-lisp-mode'.") + +(defun semantic-default-elisp-setup () + "Setup hook function for Emacs Lisp files and Semantic." + ) + +(add-hook 'emacs-lisp-mode-hook 'semantic-default-elisp-setup) + +;;; LISP MODE +;; +;; @TODO: Lisp supports syntaxes that Emacs Lisp does not. +;; Write a Lisp only parser someday. +;; +;; See this syntax: +;; (defun foo () /#A) +;; +(add-hook 'lisp-mode-hook 'semantic-default-elisp-setup) + +(eval-after-load "semanticdb" + '(require 'semanticdb-el) + ) + +(provide 'semantic/bovine/el) + +;;; semantic/bovine/el.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/bovine/gcc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/gcc.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,224 @@ +;;; semantic/bovine/gcc.el --- gcc querying special code for the C parser + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; GCC stores things in special places. These functions will query +;; GCC, and set up the preprocessor and include paths. + +(require 'semantic/dep) + +(defvar semantic-lex-c-preprocessor-symbol-file) +(defvar semantic-lex-c-preprocessor-symbol-map) +(declare-function semantic-c-reset-preprocessor-symbol-map + "semantic/bovine/gcc") + +;;; Code: + +(defun semantic-gcc-query (gcc-cmd &rest gcc-options) + "Return program output to both standard output and standard error. +GCC-CMD is the program to execute and GCC-OPTIONS are the options +to give to the program." + ;; $ gcc -v + ;; + (let ((buff (get-buffer-create " *gcc-query*")) + (old-lc-messages (getenv "LC_ALL"))) + (save-excursion + (set-buffer buff) + (erase-buffer) + (setenv "LC_ALL" "C") + (condition-case nil + (apply 'call-process gcc-cmd nil (cons buff t) nil gcc-options) + (error ;; Some bogus directory for the first time perhaps? + (let ((default-directory (expand-file-name "~/"))) + (condition-case nil + (apply 'call-process gcc-cmd nil (cons buff t) nil gcc-options) + (error ;; gcc doesn't exist??? + nil))))) + (setenv "LC_ALL" old-lc-messages) + (prog1 + (buffer-string) + (kill-buffer buff) + ) + ))) + +;;(semantic-gcc-get-include-paths "c") +;;(semantic-gcc-get-include-paths "c++") +(defun semantic-gcc-get-include-paths (lang) + "Return include paths as gcc use them for language LANG." + (let* ((gcc-cmd (cond + ((string= lang "c") "gcc") + ((string= lang "c++") "c++") + (t (if (stringp lang) + (error "Unknown lang: %s" lang) + (error "LANG=%S, should be a string" lang))))) + (gcc-output (semantic-gcc-query gcc-cmd "-v" "-E" "-x" lang null-device)) + (lines (split-string gcc-output "\n")) + (include-marks 0) + (inc-mark "#include ") + (inc-mark-len (length "#include ")) + inc-path) + ;;(message "gcc-output=%s" gcc-output) + (dolist (line lines) + (when (> (length line) 1) + (if (= 0 include-marks) + (when (and (> (length line) inc-mark-len) + (string= inc-mark (substring line 0 inc-mark-len))) + (setq include-marks (1+ include-marks))) + (let ((chars (append line nil))) + (when (= 32 (nth 0 chars)) + (let ((path (substring line 1))) + (when (file-accessible-directory-p path) + (when (if (memq system-type '(windows-nt)) + (/= ?/ (nth 1 chars)) + (= ?/ (nth 1 chars))) + (add-to-list 'inc-path + (expand-file-name (substring line 1)) + t))))))))) + inc-path)) + + +(defun semantic-cpp-defs (str) + "Convert CPP output STR into a list of cons cells with defines for C++." + (let ((lines (split-string str "\n")) + (lst nil)) + (dolist (L lines) + (let ((dat (split-string L))) + (when (= (length dat) 3) + (add-to-list 'lst (cons (nth 1 dat) (nth 2 dat)))))) + lst)) + +(defun semantic-gcc-fields (str) + "Convert GCC output STR into an alist of fields." + (let ((fields nil) + (lines (split-string str "\n")) + ) + (dolist (L lines) + ;; For any line, what do we do with it? + (cond ((or (string-match "Configured with\\(:\\)" L) + (string-match "\\(:\\)\\s-*[^ ]*configure " L)) + (let* ((parts (substring L (match-end 1))) + (opts (split-string parts " " t)) + ) + (dolist (O (cdr opts)) + (let* ((data (split-string O "=")) + (sym (intern (car data))) + (val (car (cdr data)))) + (push (cons sym val) fields) + )) + )) + ((string-match "gcc[ -][vV]ersion" L) + (let* ((vline (substring L (match-end 0))) + (parts (split-string vline " "))) + (push (cons 'version (nth 1 parts)) fields))) + ((string-match "Target: " L) + (let ((parts (split-string L " "))) + (push (cons 'target (nth 1 parts)) fields))) + )) + fields)) + +(defvar semantic-gcc-setup-data nil + "The GCC setup data. +This is setup by `semantic-gcc-setup'. +This is an alist, and should include keys of: + 'version - The version of gcc + '--host - The host symbol. (Used in include directories) + '--prefix - Where GCC was installed. +It should also include other symbols GCC was compiled with.") + +;;;###autoload +(defun semantic-gcc-setup () + "Setup Semantic C/C++ parsing based on GCC output." + (interactive) + (let* ((fields (or semantic-gcc-setup-data + (semantic-gcc-fields (semantic-gcc-query "gcc" "-v")))) + (defines (semantic-cpp-defs (semantic-gcc-query "cpp" "-E" "-dM" "-x" "c++" null-device))) + (ver (cdr (assoc 'version fields))) + (host (or (cdr (assoc 'target fields)) + (cdr (assoc '--target fields)) + (cdr (assoc '--host fields)))) + (prefix (cdr (assoc '--prefix fields))) + ;; gcc output supplied paths + (c-include-path (semantic-gcc-get-include-paths "c")) + (c++-include-path (semantic-gcc-get-include-paths "c++"))) + ;; Remember so we don't have to call GCC twice. + (setq semantic-gcc-setup-data fields) + (unless c-include-path + ;; Fallback to guesses + (let* ( ;; gcc include dirs + (gcc-exe (locate-file "gcc" exec-path exec-suffixes 'executable)) + (gcc-root (expand-file-name ".." (file-name-directory gcc-exe))) + (gcc-include (expand-file-name "include" gcc-root)) + (gcc-include-c++ (expand-file-name "c++" gcc-include)) + (gcc-include-c++-ver (expand-file-name ver gcc-include-c++)) + (gcc-include-c++-ver-host (expand-file-name host gcc-include-c++-ver))) + (setq c-include-path + (remove-if-not 'file-accessible-directory-p + (list "/usr/include" gcc-include))) + (setq c++-include-path + (remove-if-not 'file-accessible-directory-p + (list "/usr/include" + gcc-include + gcc-include-c++ + gcc-include-c++-ver + gcc-include-c++-ver-host))))) + + ;;; Fix-me: I think this part might have been a misunderstanding, but I am not sure. + ;; If this option is specified, try it both with and without prefix, and with and without host + ;; (if (assoc '--with-gxx-include-dir fields) + ;; (let ((gxx-include-dir (cdr (assoc '--with-gxx-include-dir fields)))) + ;; (nconc try-paths (list gxx-include-dir + ;; (concat prefix gxx-include-dir) + ;; (concat gxx-include-dir "/" host) + ;; (concat prefix gxx-include-dir "/" host))))) + + ;; Now setup include paths etc + (dolist (D (semantic-gcc-get-include-paths "c")) + (semantic-add-system-include D 'c-mode)) + (dolist (D (semantic-gcc-get-include-paths "c++")) + (semantic-add-system-include D 'c++-mode) + (let ((cppconfig (concat D "/bits/c++config.h"))) + ;; Presumably there will be only one of these files in the try-paths list... + (when (file-readable-p cppconfig) + ;; Add it to the symbol file + (if (boundp 'semantic-lex-c-preprocessor-symbol-file) + ;; Add to the core macro header list + (add-to-list 'semantic-lex-c-preprocessor-symbol-file cppconfig) + ;; Setup the core macro header + (setq semantic-lex-c-preprocessor-symbol-file (list cppconfig))) + ))) + (if (not (boundp 'semantic-lex-c-preprocessor-symbol-map)) + (setq semantic-lex-c-preprocessor-symbol-map nil)) + (dolist (D defines) + (add-to-list 'semantic-lex-c-preprocessor-symbol-map D)) + (when (featurep 'semantic/bovine/c) + (semantic-c-reset-preprocessor-symbol-map)) + nil)) + +(provide 'semantic/bovine/gcc) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/bovine/gcc" +;; End: + +;;; semantic/bovine/gcc.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/bovine/make-by.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/make-by.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,387 @@ +;;; 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 . + +;;; 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)) + + +;;; Prologue +;; + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/bovine/make.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/make.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,242 @@ +;;; semantic/bovine/make.el --- Makefile parsing rules. + +;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2008 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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) +(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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/bovine/scm-by.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/scm-by.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,191 @@ +;;; 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 . + +;;; 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)) + +;;; Prologue +;; + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/bovine/scm.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/bovine/scm.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,119 @@ +;;; 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 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/chart.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/chart.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,174 @@ +;;; semantic/chart.el --- Utilities for use with semantic tag tables + +;;; Copyright (C) 1999, 2000, 2001, 2003, 2005, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; A set of simple functions for charting details about a file based on +;; the output of the semantic parser. +;; + +(require 'semantic) +(require 'chart) +(require 'semantic/db) +(require 'semantic/tag) + +(eval-when-compile (require 'semantic/find)) + +;;; Code: + +(defun semantic-chart-tags-by-class (&optional tagtable) + "Create a bar chart representing the number of tags for a given tag class. +Each bar represents how many toplevel tags in TAGTABLE +exist with a given class. See `semantic-symbol->name-assoc-list' +for tokens which will be charted. +TAGTABLE is passedto `semantic-something-to-tag-table'." + (interactive) + (let* ((stream (semantic-something-to-tag-table + (or tagtable (current-buffer)))) + (names (mapcar 'cdr semantic-symbol->name-assoc-list)) + (nums (mapcar + (lambda (symname) + (length + (semantic-brute-find-tag-by-class (car symname) + stream) + )) + semantic-symbol->name-assoc-list))) + (chart-bar-quickie 'vertical + "Semantic Toplevel Tag Volume" + names "Tag Class" + nums "Volume") + )) + +(defun semantic-chart-database-size (&optional tagtable) + "Create a bar chart representing the size of each file in semanticdb. +Each bar represents how many toplevel tags in TAGTABLE +exist in each database entry. +TAGTABLE is passed to `semantic-something-to-tag-table'." + (interactive) + (unless (and (fboundp 'semanticdb-minor-mode-p) + (semanticdb-minor-mode-p)) + (error "Semanticdb is not enabled")) + (let* ((db semanticdb-current-database) + (dbt (semanticdb-get-database-tables db)) + (names (mapcar 'car + (object-assoc-list + 'file + dbt))) + (numnuts (mapcar (lambda (dba) + (prog1 + (cons + (if (slot-boundp dba 'tags) + (length (oref dba tags)) + 1) + (car names)) + (setq names (cdr names)))) + dbt)) + (nums nil) + (fh (/ (- (frame-height) 7) 4))) + (setq numnuts (sort numnuts (lambda (a b) (> (car a) (car b))))) + (setq names (mapcar 'cdr numnuts) + nums (mapcar 'car numnuts)) + (if (> (length names) fh) + (progn + (setcdr (nthcdr fh names) nil) + (setcdr (nthcdr fh nums) nil))) + (chart-bar-quickie 'horizontal + "Semantic DB Toplevel Tag Volume" + names "File" + nums "Volume") + )) + +(defun semantic-chart-token-complexity (tok) + "Calculate the `complexity' of token TOK." + (count-lines + (semantic-tag-end tok) + (semantic-tag-start tok))) + +(defun semantic-chart-tag-complexity + (&optional class tagtable) + "Create a bar chart representing the complexity of some tags. +Complexity is calculated for tags of CLASS. Each bar represents +the complexity of some tag in TAGTABLE. Only the most complex +items are charted. TAGTABLE is passedto +`semantic-something-to-tag-table'." + (interactive) + (let* ((sym (if (not class) 'function)) + (stream + (semantic-find-tags-by-class + sym (semantic-something-to-tag-table (or tagtable + (current-buffer))) + )) + (name (cond ((semantic-tag-with-position-p (car stream)) + (buffer-name (semantic-tag-buffer (car stream)))) + (t ""))) + (cplx (mapcar (lambda (tok) + (cons tok (semantic-chart-token-complexity tok))) + stream)) + (namelabel (cdr (assoc 'function semantic-symbol->name-assoc-list))) + (names nil) + (nums nil)) + (setq cplx (sort cplx (lambda (a b) (> (cdr a) (cdr b))))) + (while (and cplx (<= (length names) (/ (- (frame-height) 7) 4))) + (setq names (cons (semantic-tag-name (car (car cplx))) + names) + nums (cons (cdr (car cplx)) nums) + cplx (cdr cplx))) +;; ;; (setq names (mapcar (lambda (str) +;; ;; (substring str (- (length str) 10))) +;; ;; names)) + (chart-bar-quickie 'horizontal + (format "%s Complexity in %s" + (capitalize (symbol-name sym)) + name) + names namelabel + nums "Complexity (Lines of code)") + )) + +(declare-function semanticdb-get-typecache "semantic/db-typecache") +(declare-function semantic-calculate-scope "semantic/scope") + +(defun semantic-chart-analyzer () + "Chart the extent of the context analysis." + (interactive) + (require 'semantic/db-typecache) + (require 'semantic/scope) + (let* ((p (semanticdb-find-translate-path nil nil)) + (plen (length p)) + (tab semanticdb-current-table) + (tc (semanticdb-get-typecache tab)) + (tclen (+ (length (oref tc filestream)) + (length (oref tc includestream)))) + (scope (semantic-calculate-scope)) + (fslen (length (oref scope fullscope))) + (lvarlen (length (oref scope localvar))) + ) + (chart-bar-quickie 'vertical + (format "Analyzer Overhead in %s" (buffer-name)) + '("includes" "typecache" "scopelen" "localvar") + "Overhead Entries" + (list plen tclen fslen lvarlen) + "Number of tags") + )) + +(provide 'semantic/chart) + +;;; semantic/chart.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/complete.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/complete.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,2101 @@ +;;; semantic/complete.el --- Routines for performing tag completion + +;;; Copyright (C) 2003, 2004, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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. + +(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)) + +;;; Code: + +(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) + (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) + (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 + )) + + +;;; 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)))) + + +;;; 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 + )) + + +;;; 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)) + + +;;; ------------------------------------------------------------ +;;; 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) + )) + + +;;; ------------------------------------------------------------ +;;; 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)))) + + + +;;; ------------------------------------------------------------ +;;; 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))))) + + +;;; ------------------------------------------------------------ +;;; 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))) + ))) + + +;;; Tooltip completion lister +;; +;; Written and contributed by Masatake YAMATO +;; +;; 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 + + +;;; 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))) + ))) + + +;;; ------------------------------------------------------------ +;;; 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) + )) + + +;;;###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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/ctxt.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/ctxt.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,621 @@ +;;; semantic/ctxt.el --- Context calculations for Semantic tools. + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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. +;; +;; This library provides the hooks needed for a language to specify how +;; the current context is calculated. +;; +(require 'semantic) + +;;; Code: +(defvar semantic-command-separation-character + ";" + "String which indicates the end of a command. +Used for identifying the end of a single command.") +(make-variable-buffer-local 'semantic-command-separation-character) + +(defvar semantic-function-argument-separation-character + "," + "String which indicates the end of an argument. +Used for identifying arguments to functions.") +(make-variable-buffer-local 'semantic-function-argument-separation-character) + +;;; Local Contexts +;; +;; These context are nested blocks of code, such as code in an +;; if clause +(declare-function semantic-current-tag-of-class "semantic/find") + +(define-overloadable-function semantic-up-context (&optional point bounds-type) + "Move point up one context from POINT. +Return non-nil if there are no more context levels. +Overloaded functions using `up-context' take no parameters. +BOUNDS-TYPE is a symbol representing a tag class to restrict +movement to. If this is nil, 'function is used. +This will find the smallest tag of that class (function, variable, +type, etc) and make sure non-nil is returned if you cannot +go up past the bounds of that tag." + (require 'semantic/find) + (if point (goto-char point)) + (let ((nar (semantic-current-tag-of-class (or bounds-type 'function)))) + (if nar + (semantic-with-buffer-narrowed-to-tag nar (:override-with-args ())) + (when bounds-type + (error "No context of type %s to advance in" bounds-type)) + (:override-with-args ())))) + +(defun semantic-up-context-default () + "Move the point up and out one context level. +Works with languages that use parenthetical grouping." + ;; By default, assume that the language uses some form of parenthetical + ;; do dads for their context. + (condition-case nil + (progn + (up-list -1) + nil) + (error t))) + +(define-overloadable-function semantic-beginning-of-context (&optional point) + "Move POINT to the beginning of the current context. +Return non-nil if there is no upper context. +The default behavior uses `semantic-up-context'.") + +(defun semantic-beginning-of-context-default (&optional point) + "Move POINT to the beginning of the current context via parenthisis. +Return non-nil if there is no upper context." + (if point (goto-char point)) + (if (semantic-up-context) + t + (forward-char 1) + nil)) + +(define-overloadable-function semantic-end-of-context (&optional point) + "Move POINT to the end of the current context. +Return non-nil if there is no upper context. +Be default, this uses `semantic-up-context', and assumes parenthetical +block delimiters.") + +(defun semantic-end-of-context-default (&optional point) + "Move POINT to the end of the current context via parenthisis. +Return non-nil if there is no upper context." + (if point (goto-char point)) + (let ((start (point))) + (if (semantic-up-context) + t + ;; Go over the list, and back over the end parenthisis. + (condition-case nil + (progn + (forward-sexp 1) + (forward-char -1)) + (error + ;; If an error occurs, get the current tag from the cache, + ;; and just go to the end of that. Make sure we end up at least + ;; where start was so parse-region type calls work. + (if (semantic-current-tag) + (progn + (goto-char (semantic-tag-end (semantic-current-tag))) + (when (< (point) start) + (goto-char start))) + (goto-char start)) + t))) + nil)) + +(defun semantic-narrow-to-context () + "Narrow the buffer to the extent of the current context." + (let (b e) + (save-excursion + (if (semantic-beginning-of-context) + nil + (setq b (point)))) + (save-excursion + (if (semantic-end-of-context) + nil + (setq e (point)))) + (if (and b e) (narrow-to-region b e)))) + +(defmacro semantic-with-buffer-narrowed-to-context (&rest body) + "Execute BODY with the buffer narrowed to the current context." + `(save-restriction + (semantic-narrow-to-context) + ,@body)) +(put 'semantic-with-buffer-narrowed-to-context 'lisp-indent-function 0) +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec semantic-with-buffer-narrowed-to-context + (def-body)))) + +;;; Local Variables +;; +;; +(define-overloadable-function semantic-get-local-variables (&optional point) + "Get the local variables based on POINT's context. +Local variables are returned in Semantic tag format. +This can be overriden with `get-local-variables'." + ;; The working status is to let the parser work properly + (let ((semantic--progress-reporter + (make-progress-reporter (semantic-parser-working-message "Local") + 0 100))) + (save-excursion + (if point (goto-char point)) + (let* ((semantic-working-type nil) + ;; Disable parsing messages + (case-fold-search semantic-case-fold)) + (:override-with-args ()))))) + +(defun semantic-get-local-variables-default () + "Get local values from a specific context. +Uses the bovinator with the special top-symbol `bovine-inner-scope' +to collect tags, such as local variables or prototypes." + ;; This assumes a bovine parser. Make sure we don't do + ;; anything in that case. + (when (and semantic--parse-table (not (eq semantic--parse-table t)) + (not (semantic-parse-tree-unparseable-p))) + (let ((vars (semantic-get-cache-data 'get-local-variables))) + (if vars + (progn + ;;(message "Found cached vars.") + vars) + (let ((vars2 nil) + ;; We want nothing to do with funny syntaxing while doing this. + (semantic-unmatched-syntax-hook nil) + (start (point)) + (firstusefulstart nil) + ) + (while (not (semantic-up-context (point) 'function)) + (when (not vars) + (setq firstusefulstart (point))) + (save-excursion + (forward-char 1) + (setq vars + ;; Note to self: semantic-parse-region returns cooked + ;; but unlinked tags. File information is lost here + ;; and is added next. + (append (semantic-parse-region + (point) + (save-excursion (semantic-end-of-context) (point)) + 'bovine-inner-scope + nil + t) + vars)))) + ;; Modify the tags in place. + (setq vars2 vars) + (while vars2 + (semantic--tag-put-property (car vars2) :filename (buffer-file-name)) + (setq vars2 (cdr vars2))) + ;; Hash our value into the first context that produced useful results. + (when (and vars firstusefulstart) + (let ((end (save-excursion + (goto-char firstusefulstart) + (save-excursion + (unless (semantic-end-of-context) + (point)))))) + ;;(message "Caching values %d->%d." firstusefulstart end) + (semantic-cache-data-to-buffer + (current-buffer) firstusefulstart + (or end + ;; If the end-of-context fails, + ;; just use our cursor starting + ;; position. + start) + vars 'get-local-variables 'exit-cache-zone)) + ) + ;; Return our list. + vars))))) + +(define-overloadable-function semantic-get-local-arguments (&optional point) + "Get arguments (variables) from the current context at POINT. +Parameters are available if the point is in a function or method. +Return a list of tags unlinked from the originating buffer. +Arguments are obtained by overriding `get-local-arguments', or by the +default function `semantic-get-local-arguments-default'. This, must +return a list of tags, or a list of strings that will be converted to +tags." + (save-excursion + (if point (goto-char point)) + (let* ((case-fold-search semantic-case-fold) + (args (:override-with-args ())) + arg tags) + ;; Convert unsafe arguments to the right thing. + (while args + (setq arg (car args) + args (cdr args) + tags (cons (cond + ((semantic-tag-p arg) + ;; Return a copy of tag without overlay. + ;; The overlay is preserved. + (semantic-tag-copy arg nil t)) + ((stringp arg) + (semantic--tag-put-property + (semantic-tag-new-variable arg nil nil) + :filename (buffer-file-name))) + (t + (error "Unknown parameter element %S" arg))) + tags))) + (nreverse tags)))) + +(defun semantic-get-local-arguments-default () + "Get arguments (variables) from the current context. +Parameters are available if the point is in a function or method." + (let ((tag (semantic-current-tag))) + (if (and tag (semantic-tag-of-class-p tag 'function)) + (semantic-tag-function-arguments tag)))) + +(define-overloadable-function semantic-get-all-local-variables (&optional point) + "Get all local variables for this context, and parent contexts. +Local variables are returned in Semantic tag format. +Be default, this gets local variables, and local arguments. +Optional argument POINT is the location to start getting the variables from.") + +(defun semantic-get-all-local-variables-default (&optional point) + "Get all local variables for this context. +Optional argument POINT is the location to start getting the variables from. +That is a cons (LOCAL-ARGUMENTS . LOCAL-VARIABLES) where: + +- LOCAL-ARGUMENTS is collected by `semantic-get-local-arguments'. +- LOCAL-VARIABLES is collected by `semantic-get-local-variables'." + (save-excursion + (if point (goto-char point)) + (let ((case-fold-search semantic-case-fold)) + (append (semantic-get-local-arguments) + (semantic-get-local-variables))))) + +;;; Local context parsing +;; +;; Context parsing assumes a series of language independent commonalities. +;; These terms are used to describe those contexts: +;; +;; command - One command in the language. +;; symbol - The symbol the cursor is on. +;; This would include a series of type/field when applicable. +;; assignment - The variable currently being assigned to +;; function - The function call the cursor is on/in +;; argument - The index to the argument the cursor is on. +;; +;; +(define-overloadable-function semantic-end-of-command () + "Move to the end of the current command. +Be default, uses `semantic-command-separation-character'.") + +(defun semantic-end-of-command-default () + "Move to the end of the current command. +Depends on `semantic-command-separation-character' to find the +beginning and end of a command." + (semantic-with-buffer-narrowed-to-context + (let ((case-fold-search semantic-case-fold)) + (with-syntax-table semantic-lex-syntax-table + + (if (re-search-forward (regexp-quote semantic-command-separation-character) + nil t) + (forward-char -1) + ;; If there wasn't a command after this, we are the last + ;; command, and we are incomplete. + (goto-char (point-max))))))) + +(define-overloadable-function semantic-beginning-of-command () + "Move to the beginning of the current command. +Be default, uses `semantic-command-separation-character'.") + +(defun semantic-beginning-of-command-default () + "Move to the beginning of the current command. +Depends on `semantic-command-separation-character' to find the +beginning and end of a command." + (semantic-with-buffer-narrowed-to-context + (with-syntax-table semantic-lex-syntax-table + (let ((case-fold-search semantic-case-fold)) + (skip-chars-backward semantic-command-separation-character) + (if (re-search-backward (regexp-quote semantic-command-separation-character) + nil t) + (goto-char (match-end 0)) + ;; If there wasn't a command after this, we are the last + ;; command, and we are incomplete. + (goto-char (point-min))) + (skip-chars-forward " \t\n") + )))) + + +(defsubst semantic-point-at-beginning-of-command () + "Return the point at the beginning of the current command." + (save-excursion (semantic-beginning-of-command) (point))) + +(defsubst semantic-point-at-end-of-command () + "Return the point at the beginning of the current command." + (save-excursion (semantic-end-of-command) (point))) + +(defsubst semantic-narrow-to-command () + "Narrow the current buffer to the current command." + (narrow-to-region (semantic-point-at-beginning-of-command) + (semantic-point-at-end-of-command))) + +(defmacro semantic-with-buffer-narrowed-to-command (&rest body) + "Execute BODY with the buffer narrowed to the current command." + `(save-restriction + (semantic-narrow-to-command) + ,@body)) +(put 'semantic-with-buffer-narrowed-to-command 'lisp-indent-function 0) +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec semantic-with-buffer-narrowed-to-command + (def-body)))) + + +(define-overloadable-function semantic-ctxt-current-symbol (&optional point) + "Return the current symbol the cursor is on at POINT in a list. +The symbol includes all logical parts of a complex reference. +For example, in C the statement: + this.that().entry + +Would be object `this' calling method `that' which returns some structure +whose field `entry' is being reference. In this case, this function +would return the list: + ( \"this\" \"that\" \"entry\" )") + +(defun semantic-ctxt-current-symbol-default (&optional point) + "Return the current symbol the cursor is on at POINT in a list. +This will include a list of type/field names when applicable. +Depends on `semantic-type-relation-separator-character'." + (save-excursion + (if point (goto-char point)) + (let* ((fieldsep1 (mapconcat (lambda (a) (regexp-quote a)) + semantic-type-relation-separator-character + "\\|")) + ;; NOTE: The [ \n] expression below should used \\s-, but that + ;; doesn't work in C since \n means end-of-comment, and isn't + ;; really whitespace. + (fieldsep (concat "[ \t\n\r]*\\(" fieldsep1 "\\)[ \t\n\r]*\\(\\w\\|\\s_\\)")) + (case-fold-search semantic-case-fold) + (symlist nil) + end) + (with-syntax-table semantic-lex-syntax-table + (save-excursion + (cond ((looking-at "\\w\\|\\s_") + ;; In the middle of a symbol, move to the end. + (forward-sexp 1)) + ((looking-at fieldsep1) + ;; We are in a find spot.. do nothing. + nil + ) + ((save-excursion + (and (condition-case nil + (progn (forward-sexp -1) + (forward-sexp 1) + t) + (error nil)) + (looking-at fieldsep1))) + (setq symlist (list "")) + (forward-sexp -1) + ;; Skip array expressions. + (while (looking-at "\\s(") (forward-sexp -1)) + (forward-sexp 1)) + ) + ;; Set our end point. + (setq end (point)) + + ;; Now that we have gotten started, lets do the rest. + (condition-case nil + (while (save-excursion + (forward-char -1) + (looking-at "\\w\\|\\s_")) + ;; We have a symbol.. Do symbol things + (forward-sexp -1) + (setq symlist (cons (buffer-substring-no-properties (point) end) + symlist)) + ;; Skip the next syntactic expression backwards, then go forwards. + (let ((cp (point))) + (forward-sexp -1) + (forward-sexp 1) + ;; If we end up at the same place we started, we are at the + ;; beginning of a buffer, or narrowed to a command and + ;; have to stop. + (if (<= cp (point)) (error nil))) + (if (looking-at fieldsep) + (progn + (forward-sexp -1) + ;; Skip array expressions. + (while (and (looking-at "\\s(") (not (bobp))) + (forward-sexp -1)) + (forward-sexp 1) + (setq end (point))) + (error nil)) + ) + (error nil))) + symlist)))) + + +(define-overloadable-function semantic-ctxt-current-symbol-and-bounds (&optional point) + "Return the current symbol and bounds the cursor is on at POINT. +The symbol should be the same as returned by `semantic-ctxt-current-symbol'. +Return (PREFIX ENDSYM BOUNDS).") + +(defun semantic-ctxt-current-symbol-and-bounds-default (&optional point) + "Return the current symbol and bounds the cursor is on at POINT. +Uses `semantic-ctxt-current-symbol' to calculate the symbol. +Return (PREFIX ENDSYM BOUNDS)." + (save-excursion + (when point (goto-char (point))) + (let* ((prefix (semantic-ctxt-current-symbol)) + (endsym (car (reverse prefix))) + ;; @todo - Can we get this data direct from ctxt-current-symbol? + (bounds (save-excursion + (cond ((string= endsym "") + (cons (point) (point)) + ) + ((and prefix (looking-at endsym)) + (cons (point) (progn + (condition-case nil + (forward-sexp 1) + (error nil)) + (point)))) + (prefix + (condition-case nil + (cons (progn (forward-sexp -1) (point)) + (progn (forward-sexp 1) (point))) + (error nil))) + (t nil)))) + ) + (list prefix endsym bounds)))) + +(define-overloadable-function semantic-ctxt-current-assignment (&optional point) + "Return the current assignment near the cursor at POINT. +Return a list as per `semantic-ctxt-current-symbol'. +Return nil if there is nothing relevant.") + +(defun semantic-ctxt-current-assignment-default (&optional point) + "Return the current assignment near the cursor at POINT. +By default, assume that \"=\" indicates an assignment." + (if point (goto-char point)) + (let ((case-fold-search semantic-case-fold)) + (with-syntax-table semantic-lex-syntax-table + (condition-case nil + (semantic-with-buffer-narrowed-to-command + (save-excursion + (skip-chars-forward " \t=") + (condition-case nil (forward-char 1) (error nil)) + (re-search-backward "[^=]=\\([^=]\\|$\\)") + ;; We are at an equals sign. Go backwards a sexp, and + ;; we'll have the variable. Otherwise we threw an error + (forward-sexp -1) + (semantic-ctxt-current-symbol))) + (error nil))))) + +(define-overloadable-function semantic-ctxt-current-function (&optional point) + "Return the current function call the cursor is in at POINT. +The function returned is the one accepting the arguments that +the cursor is currently in. It will not return function symbol if the +cursor is on the text representing that function.") + +(defun semantic-ctxt-current-function-default (&optional point) + "Return the current function call the cursor is in at POINT. +The call will be identifed for C like langauges with the form + NAME ( args ... )" + (if point (goto-char point)) + (let ((case-fold-search semantic-case-fold)) + (with-syntax-table semantic-lex-syntax-table + (save-excursion + (semantic-up-context) + (when (looking-at "(") + (semantic-ctxt-current-symbol)))) + )) + +(define-overloadable-function semantic-ctxt-current-argument (&optional point) + "Return the index of the argument position the cursor is on at POINT.") + +(defun semantic-ctxt-current-argument-default (&optional point) + "Return the index of the argument the cursor is on at POINT. +Depends on `semantic-function-argument-separation-character'." + (if point (goto-char point)) + (let ((case-fold-search semantic-case-fold)) + (with-syntax-table semantic-lex-syntax-table + (when (semantic-ctxt-current-function) + (save-excursion + ;; Only get the current arg index if we are in function args. + (let ((p (point)) + (idx 1)) + (semantic-up-context) + (while (re-search-forward + (regexp-quote semantic-function-argument-separation-character) + p t) + (setq idx (1+ idx))) + idx)))))) + +(defun semantic-ctxt-current-thing () + "Calculate a thing identified by the current cursor position. +Calls previously defined `semantic-ctxt-current-...' calls until something +gets a match. See `semantic-ctxt-current-symbol', +`semantic-ctxt-current-function', and `semantic-ctxt-current-assignment' +for details on the return value." + (or (semantic-ctxt-current-symbol) + (semantic-ctxt-current-function) + (semantic-ctxt-current-assignment))) + +(define-overloadable-function semantic-ctxt-current-class-list (&optional point) + "Return a list of tag classes that are allowed at POINT. +If POINT is nil, the current buffer location is used. +For example, in Emacs Lisp, the symbol after a ( is most likely +a function. In a makefile, symbols after a : are rules, and symbols +after a $( are variables.") + +(defun semantic-ctxt-current-class-list-default (&optional point) + "Return a list of tag classes that are allowed at POINT. +Assume a functional typed language. Uses very simple rules." + (save-excursion + (if point (goto-char point)) + + (let ((tag (semantic-current-tag))) + (if tag + (cond ((semantic-tag-of-class-p tag 'function) + '(function variable type)) + ((or (semantic-tag-of-class-p tag 'type) + (semantic-tag-of-class-p tag 'variable)) + '(type)) + (t nil)) + '(type) + )))) + +;;;###autoload +(define-overloadable-function semantic-ctxt-current-mode (&optional point) + "Return the major mode active at POINT. +POINT defaults to the value of point in current buffer. +You should override this function in multiple mode buffers to +determine which major mode apply at point.") + +(defun semantic-ctxt-current-mode-default (&optional point) + "Return the major mode active at POINT. +POINT defaults to the value of point in current buffer. +This default implementation returns the current major mode." + major-mode) + +;;; Scoped Types +;; +;; Scoped types are types that the current code would have access to. +;; The come from the global namespace or from special commands such as "using" +(define-overloadable-function semantic-ctxt-scoped-types (&optional point) + "Return a list of type names currently in scope at POINT. +The return value can be a mixed list of either strings (names of +types that are in scope) or actual tags (type declared locally +that may or may not have a name.)") + +(defun semantic-ctxt-scoped-types-default (&optional point) + "Return a list of scoped types by name for the current context at POINT. +This is very different for various languages, and does nothing unless +overriden." + (if point (goto-char point)) + (let ((case-fold-search semantic-case-fold)) + ;; We need to look at TYPES within the bounds of locally parse arguments. + ;; C needs to find using statements and the like too. Bleh. + nil + )) + +(provide 'semantic/ctxt) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/ctxt" +;; End: + +;;; semantic/ctxt.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db-debug.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-debug.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,111 @@ +;;; semantic/db-debug.el --- Extra level debugging routines for Semantic + +;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Various routines for debugging SemanticDB issues, or viewing +;; semanticdb state. + +(require 'data-debug) +(require 'semantic/db) +(require 'semantic/format) + +;;; Code: +;; +(defun semanticdb-dump-all-table-summary () + "Dump a list of all databases in Emacs memory." + (interactive) + (require 'data-debug) + (let ((db semanticdb-database-list)) + (data-debug-new-buffer "*SEMANTICDB*") + (data-debug-insert-stuff-list db "*"))) + +(defalias 'semanticdb-adebug-database-list 'semanticdb-dump-all-table-summary) + +(defun semanticdb-adebug-current-database () + "Run ADEBUG on the current database." + (interactive) + (require 'data-debug) + (let ((p semanticdb-current-database) + ) + (data-debug-new-buffer "*SEMANTICDB ADEBUG*") + (data-debug-insert-stuff-list p "*"))) + +(defun semanticdb-adebug-current-table () + "Run ADEBUG on the current database." + (interactive) + (require 'data-debug) + (let ((p semanticdb-current-table)) + (data-debug-new-buffer "*SEMANTICDB ADEBUG*") + (data-debug-insert-stuff-list p "*"))) + + +(defun semanticdb-adebug-project-database-list () + "Run ADEBUG on the current database." + (interactive) + (require 'data-debug) + (let ((p (semanticdb-current-database-list))) + (data-debug-new-buffer "*SEMANTICDB ADEBUG*") + (data-debug-insert-stuff-list p "*"))) + + + +;;; Sanity Checks +;; + +(defun semanticdb-table-oob-sanity-check (cache) + "Validate that CACHE tags do not have any overlays in them." + (while cache + (when (semantic-overlay-p (semantic-tag-overlay cache)) + (message "Tag %s has an erroneous overlay!" + (semantic-format-tag-summarize (car cache)))) + (semanticdb-table-oob-sanity-check + (semantic-tag-components-with-overlays (car cache))) + (setq cache (cdr cache)))) + +(defun semanticdb-table-sanity-check (&optional table) + "Validate the current semanticdb TABLE." + (interactive) + (if (not table) (setq table semanticdb-current-table)) + (let* ((full-filename (semanticdb-full-filename table)) + (buff (find-buffer-visiting full-filename))) + (if buff + (save-excursion + (set-buffer buff) + (semantic-sanity-check)) + ;; We can't use the usual semantic validity check, so hack our own. + (semanticdb-table-oob-sanity-check (semanticdb-get-tags table))))) + +(defun semanticdb-database-sanity-check () + "Validate the current semantic database." + (interactive) + (let ((tables (semanticdb-get-database-tables + semanticdb-current-database))) + (while tables + (semanticdb-table-sanity-check (car tables)) + (setq tables (cdr tables))) + )) + + + +(provide 'semantic/db-debug) + +;;; semantic/db-debug.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db-ebrowse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-ebrowse.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,666 @@ +;;; semantic/db-ebrowse.el --- Semanticdb backend using ebrowse. + +;;; Copyright (C) 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Authors: Eric M. Ludlam , 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 . + +;;; 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) + (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//.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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db-el.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-el.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,347 @@ +;;; semantic/db-el.el --- Semantic database extensions for Emacs Lisp + +;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; There are a lot of Emacs Lisp functions and variables available for +;; the asking. This adds on to the semanticdb programming interface to +;; allow all loaded Emacs Lisp functions to be queried via semanticdb. +;; +;; This allows you to use programs written for Semantic using the database +;; to also work in Emacs Lisp with no compromises. +;; + +(require 'semantic/db) + +(eval-when-compile + ;; For generic function searching. + (require 'eieio) + (require 'eieio-opt) + (require 'eieio-base)) + +(declare-function semantic-elisp-desymbolify "semantic/bovine/el") + +;;; Code: + +;;; Classes: +(defclass semanticdb-table-emacs-lisp (semanticdb-abstract-table) + ((major-mode :initform emacs-lisp-mode) + ) + "A table for returning search results from Emacs.") + +(defmethod semanticdb-refresh-table ((obj semanticdb-table-emacs-lisp) &optional force) + "Do not refresh Emacs Lisp table. +It does not need refreshing." + nil) + +(defmethod semanticdb-needs-refresh-p ((obj semanticdb-table-emacs-lisp)) + "Return nil, we never need a refresh." + nil) + +(defclass semanticdb-project-database-emacs-lisp + (semanticdb-project-database eieio-singleton) + ((new-table-class :initform semanticdb-table-emacs-lisp + :type class + :documentation + "New tables created for this database are of this class.") + ) + "Database representing Emacs core.") + +;; Create the database, and add it to searchable databases for Emacs Lisp mode. +(defvar-mode-local emacs-lisp-mode semanticdb-project-system-databases + (list + (semanticdb-project-database-emacs-lisp "Emacs")) + "Search Emacs core for symbols.") + +(defvar-mode-local emacs-lisp-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-emacs-lisp)) + "For an Emacs Lisp database, there are no explicit tables. +Create one of our special tables that can act as an intermediary." + ;; 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-emacs-lisp "Emacs System Table"))) + (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-emacs-lisp) filename) + "From OBJ, return FILENAME's associated table object. +For Emacs Lisp, creates a specialized table." + (car (semanticdb-get-database-tables obj)) + ) + +(defmethod semanticdb-get-tags ((table semanticdb-table-emacs-lisp )) + "Return the list of tags belonging to TABLE." + ;; specialty table ? Probably derive tags at request time. + nil) + +(defmethod semanticdb-equivalent-mode ((table semanticdb-table-emacs-lisp) &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) 'emacs-lisp-mode))) + +(defmethod semanticdb-full-filename ((obj semanticdb-table-emacs-lisp)) + "Fetch the full filename that OBJ refers to. +For Emacs Lisp system DB, there isn't one." + nil) + +;;; Conversion +;; +(defmethod semanticdb-normalize-tags ((obj semanticdb-table-emacs-lisp) tags) + "Convert tags, originating from Emacs OBJ, into standardized form." + (let ((newtags nil)) + (dolist (T tags) + (let* ((ot (semanticdb-normalize-one-tag obj T)) + (tag (cdr ot))) + (setq newtags (cons tag newtags)))) + ;; There is no promise to have files associated. + (nreverse newtags))) + +(defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-emacs-lisp) tag) + "Convert one TAG, originating from Emacs OBJ, into standardized form. +If Emacs cannot resolve this symbol to a particular file, then return nil." + ;; Here's the idea. For each tag, get the name, then use + ;; Emacs' `symbol-file' to get the source. Once we have that, + ;; we can use more typical semantic searching techniques to + ;; get a regularly parsed tag. + (let* ((type (cond ((semantic-tag-of-class-p tag 'function) + 'defun) + ((semantic-tag-of-class-p tag 'variable) + 'defvar) + )) + (sym (intern (semantic-tag-name tag))) + (file (condition-case err + (symbol-file sym type) + ;; Older [X]Emacs don't have a 2nd argument. + (error (symbol-file sym)))) + ) + (if (or (not file) (not (file-exists-p file))) + ;; The file didn't exist. Return nil. + ;; We can't normalize this tag. Fake it out. + (cons obj tag) + (when (string-match "\\.elc" file) + (setq file (concat (file-name-sans-extension file) + ".el")) + (when (and (not (file-exists-p file)) + (file-exists-p (concat file ".gz"))) + ;; Is it a .gz file? + (setq file (concat file ".gz")))) + + (let* ((tab (semanticdb-file-table-object file)) + (alltags (semanticdb-get-tags tab)) + (newtags (semanticdb-find-tags-by-name-method + tab (semantic-tag-name tag))) + (match nil)) + ;; Find the best match. + (dolist (T newtags) + (when (semantic-tag-similar-p T tag) + (setq match T))) + ;; Backup system. + (when (not match) + (setq match (car newtags))) + ;; Return it. + (cons tab match))))) + +(defun semanticdb-elisp-sym-function-arglist (sym) + "Get the argument list for SYM. +Deal with all different forms of function. +This was snarfed out of eldoc." + (let* ((prelim-def + (let ((sd (and (fboundp sym) + (symbol-function sym)))) + (and (symbolp sd) + (condition-case err + (setq sd (indirect-function sym)) + (error (setq sd nil)))) + sd)) + (def (if (eq (car-safe prelim-def) 'macro) + (cdr prelim-def) + prelim-def)) + (arglist (cond ((null def) nil) + ((byte-code-function-p def) + ;; This is an eieio compatibility function. + ;; We depend on EIEIO, so use this. + (eieio-compiled-function-arglist def)) + ((eq (car-safe def) 'lambda) + (nth 1 def)) + (t nil)))) + arglist)) + +(defun semanticdb-elisp-sym->tag (sym &optional toktype) + "Convert SYM into a semantic tag. +TOKTYPE is a hint to the type of tag desired." + (if (stringp sym) + (setq sym (intern-soft sym))) + (when sym + (cond ((and (eq toktype 'function) (fboundp sym)) + (require 'semantic/bovine/el) + (semantic-tag-new-function + (symbol-name sym) + nil ;; return type + (semantic-elisp-desymbolify + (semanticdb-elisp-sym-function-arglist sym)) ;; arg-list + :user-visible-flag (condition-case nil + (interactive-form sym) + (error nil)) + )) + ((and (eq toktype 'variable) (boundp sym)) + (semantic-tag-new-variable + (symbol-name sym) + nil ;; type + nil ;; value - ignore for now + )) + ((and (eq toktype 'type) (class-p sym)) + (semantic-tag-new-type + (symbol-name sym) + "class" + (semantic-elisp-desymbolify + (aref (class-v semanticdb-project-database) + class-public-a)) ;; slots + (semantic-elisp-desymbolify (class-parents sym)) ;; parents + )) + ((not toktype) + ;; Figure it out on our own. + (cond ((class-p sym) + (semanticdb-elisp-sym->tag sym 'type)) + ((fboundp sym) + (semanticdb-elisp-sym->tag sym 'function)) + ((boundp sym) + (semanticdb-elisp-sym->tag sym 'variable)) + (t nil)) + ) + (t nil)))) + +;;; Search Overrides +;; +(defvar semanticdb-elisp-mapatom-collector nil + "Variable used to collect mapatoms output.") + +(defmethod semanticdb-find-tags-by-name-method + ((table semanticdb-table-emacs-lisp) name &optional tags) + "Find all tags name NAME in TABLE. +Uses `inter-soft' to match NAME to emacs symbols. +Return a list of tags." + (if tags (call-next-method) + ;; No need to search. Use `intern-soft' which does the same thing for us. + (let* ((sym (intern-soft name)) + (fun (semanticdb-elisp-sym->tag sym 'function)) + (var (semanticdb-elisp-sym->tag sym 'variable)) + (typ (semanticdb-elisp-sym->tag sym 'type)) + (taglst nil) + ) + (when (or fun var typ) + ;; If the symbol is any of these things, build the search table. + (when var (setq taglst (cons var taglst))) + (when typ (setq taglst (cons typ taglst))) + (when fun (setq taglst (cons fun taglst))) + taglst + )))) + +(defmethod semanticdb-find-tags-by-name-regexp-method + ((table semanticdb-table-emacs-lisp) regex &optional tags) + "Find all tags with name matching REGEX in TABLE. +Optional argument TAGS is a list of tags to search. +Uses `apropos-internal' to find matches. +Return a list of tags." + (if tags (call-next-method) + (delq nil (mapcar 'semanticdb-elisp-sym->tag + (apropos-internal regex))))) + +(defmethod semanticdb-find-tags-for-completion-method + ((table semanticdb-table-emacs-lisp) 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) + (delq nil (mapcar 'semanticdb-elisp-sym->tag + (all-completions prefix obarray))))) + +(defmethod semanticdb-find-tags-by-class-method + ((table semanticdb-table-emacs-lisp) 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) + ;; We could implement this, but it could be messy. + nil)) + +;;; Deep Searches +;; +;; For Emacs Lisp deep searches are like top level searches. +(defmethod semanticdb-deep-find-tags-by-name-method + ((table semanticdb-table-emacs-lisp) name &optional tags) + "Find all tags name NAME in TABLE. +Optional argument TAGS is a list of tags to search. +Like `semanticdb-find-tags-by-name-method' for Emacs Lisp." + (semanticdb-find-tags-by-name-method table name tags)) + +(defmethod semanticdb-deep-find-tags-by-name-regexp-method + ((table semanticdb-table-emacs-lisp) 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 Emacs Lisp." + (semanticdb-find-tags-by-name-regexp-method table regex tags)) + +(defmethod semanticdb-deep-find-tags-for-completion-method + ((table semanticdb-table-emacs-lisp) 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 Emacs Lisp." + (semanticdb-find-tags-for-completion-method table prefix tags)) + +;;; Advanced Searches +;; +(defmethod semanticdb-find-tags-external-children-of-type-method + ((table semanticdb-table-emacs-lisp) 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) + ;; EIEIO is the only time this matters + (when (featurep 'eieio) + (let* ((class (intern-soft type)) + (taglst (when class + (delq nil + (mapcar 'semanticdb-elisp-sym->tag + ;; Fancy eieio function that knows all about + ;; built in methods belonging to CLASS. + (eieio-all-generic-functions class))))) + ) + taglst)))) + +(provide 'semantic/db-el) + +;;; semantic/db-el.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db-file.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-file.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,457 @@ +;;; semantic/db-file.el --- Save a semanticdb to a cache file. + +;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; A set of semanticdb classes for persistently saving caches on disk. +;; + +(require 'semantic) +(require 'semantic/db) +(require 'cedet-files) + +(defvar semanticdb-file-version semantic-version + "Version of semanticdb we are writing files to disk with.") +(defvar semanticdb-file-incompatible-version "1.4" + "Version of semanticdb we are not reverse compatible with.") + +;;; Settings +;; +(defcustom semanticdb-default-file-name "semantic.cache" + "File name of the semantic tag cache." + :group 'semanticdb + :type 'string) + +(defcustom semanticdb-default-save-directory + (expand-file-name "semanticdb" user-emacs-directory) + "Directory name where semantic cache files are stored. +If this value is nil, files are saved in the current directory. If the value +is a valid directory, then it overrides `semanticdb-default-file-name' and +stores caches in a coded file name in this directory." + :group 'semanticdb + :type '(choice :tag "Default-Directory" + :menu-tag "Default-Directory" + (const :tag "Use current directory" :value nil) + (directory))) + +(defcustom semanticdb-persistent-path '(always) + "List of valid paths that semanticdb will cache tags to. +When `global-semanticdb-minor-mode' is active, tag lists will +be saved to disk when Emacs exits. Not all directories will have +tags that should be saved. +The value should be a list of valid paths. A path can be a string, +indicating a directory in which to save a variable. An element in the +list can also be a symbol. Valid symbols are `never', which will +disable any saving anywhere, `always', which enables saving +everywhere, or `project', which enables saving in any directory that +passes a list of predicates in `semanticdb-project-predicate-functions'." + :group 'semanticdb + :type nil) + +(defcustom semanticdb-save-database-hooks nil + "Abnormal hook run after a database is saved. +Each function is called with one argument, the object representing +the database recently written." + :group 'semanticdb + :type 'hook) + +(defvar semanticdb-dir-sep-char (if (boundp 'directory-sep-char) + (symbol-value 'directory-sep-char) + ?/) + "Character used for directory separation. +Obsoleted in some versions of Emacs. Needed in others. +NOTE: This should get deleted from semantic soon.") + +(defun semanticdb-fix-pathname (dir) + "If DIR is broken, fix it. +Force DIR to end with a /. +Note: Same as `file-name-as-directory'. +NOTE: This should get deleted from semantic soon." + (file-name-as-directory dir)) +;; I didn't initially know about the above fcn. Keep the below as a +;; reference. Delete it someday once I've proven everything is the same. +;; (if (not (= semanticdb-dir-sep-char (aref path (1- (length path))))) +;; (concat path (list semanticdb-dir-sep-char)) +;; path)) + +;;; Classes +;; +;;;###autoload +(defclass semanticdb-project-database-file (semanticdb-project-database + eieio-persistent) + ((file-header-line :initform ";; SEMANTICDB Tags save file") + (do-backups :initform nil) + (semantic-tag-version :initarg :semantic-tag-version + :initform "1.4" + :documentation + "The version of the tags saved. +The default value is 1.4. In semantic 1.4 there was no versioning, so +when those files are loaded, this becomes the version number. +To save the version number, we must hand-set this version string.") + (semanticdb-version :initarg :semanticdb-version + :initform "1.4" + :documentation + "The version of the object system saved. +The default value is 1.4. In semantic 1.4, there was no versioning, +so when those files are loaded, this becomes the version number. +To save the version number, we must hand-set this version string.") + ) + "Database of file tables saved to disk.") + +;;; Code: +;; +(defmethod semanticdb-create-database :STATIC ((dbc semanticdb-project-database-file) + directory) + "Create a new semantic database for DIRECTORY and return it. +If a database for DIRECTORY has already been loaded, return it. +If a database for DIRECTORY exists, then load that database, and return it. +If DIRECTORY doesn't exist, create a new one." + ;; Make sure this is fully expanded so we don't get duplicates. + (setq directory (file-truename directory)) + (let* ((fn (semanticdb-cache-filename dbc directory)) + (db (or (semanticdb-file-loaded-p fn) + (if (file-exists-p fn) + (progn + (semanticdb-load-database fn)))))) + (unless db + (setq db (make-instance + dbc ; Create the database requested. Perhaps + (concat (file-name-nondirectory + (directory-file-name + directory)) + "/") + :file fn :tables nil + :semantic-tag-version semantic-version + :semanticdb-version semanticdb-file-version))) + ;; 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 directory) + db)) + +;;; File IO + +(declare-function inversion-test "inversion") + +(defun semanticdb-load-database (filename) + "Load the database FILENAME." + (condition-case foo + (let* ((r (eieio-persistent-read filename)) + (c (semanticdb-get-database-tables r)) + (tv (oref r semantic-tag-version)) + (fv (oref r semanticdb-version)) + ) + ;; Restore the parent-db connection + (while c + (oset (car c) parent-db r) + (setq c (cdr c))) + (unless (and (equal semanticdb-file-version fv) + (equal semantic-tag-version tv)) + ;; Try not to load inversion unless we need it: + (require 'inversion) + (if (not (inversion-test 'semanticdb-file fv)) + (when (inversion-test 'semantic-tag tv) + ;; Incompatible version. Flush tables. + (semanticdb-flush-database-tables r) + ;; Reset the version to new version. + (oset r semantic-tag-version semantic-tag-version) + ;; Warn user + (message "Semanticdb file is old. Starting over for %s" + filename)) + ;; Version is not ok. Flush whole system + (message "semanticdb file is old. Starting over for %s" + filename) + ;; This database is so old, we need to replace it. + ;; We also need to delete it from the instance tracker. + (delete-instance r) + (setq r nil))) + r) + (error (message "Cache Error: [%s] %s, Restart" + filename foo) + nil))) + +(defun semanticdb-file-loaded-p (filename) + "Return the project belonging to FILENAME if it was already loaded." + (eieio-instance-tracker-find filename 'file 'semanticdb-database-list)) + +(defmethod semanticdb-file-directory-exists-p ((DB semanticdb-project-database-file) + &optional supress-questions) + "Does the directory the database DB needs to write to exist? +If SUPRESS-QUESTIONS, then do not ask to create the directory." + (let ((dest (file-name-directory (oref DB file))) + ) + (cond ((null dest) + ;; @TODO - If it was never set up... what should we do ? + nil) + ((file-exists-p dest) t) + ((or supress-questions + (and (boundp 'semanticdb--inhibit-make-directory) + semanticdb--inhibit-make-directory)) + nil) + ((y-or-n-p (format "Create directory %s for SemanticDB? " dest)) + (make-directory dest t) + t) + (t + (if (boundp 'semanticdb--inhibit-make-directory) + (setq semanticdb--inhibit-make-directory t)) + nil)))) + +(defmethod semanticdb-save-db ((DB semanticdb-project-database-file) + &optional + supress-questions) + "Write out the database DB to its file. +If DB is not specified, then use the current database." + (let ((objname (oref DB file))) + (when (and (semanticdb-dirty-p DB) + (semanticdb-live-p DB) + (semanticdb-file-directory-exists-p DB supress-questions) + (semanticdb-write-directory-p DB) + ) + ;;(message "Saving tag summary for %s..." objname) + (condition-case foo + (eieio-persistent-save (or DB semanticdb-current-database)) + (file-error ; System error saving? Ignore it. + (message "%S: %s" foo objname)) + (error + (cond + ((and (listp foo) + (stringp (nth 1 foo)) + (string-match "write[- ]protected" (nth 1 foo))) + (message (nth 1 foo))) + ((and (listp foo) + (stringp (nth 1 foo)) + (string-match "no such directory" (nth 1 foo))) + (message (nth 1 foo))) + (t + ;; @todo - It should ask if we are not called from a hook. + ;; How? + (if (or supress-questions + (y-or-n-p (format "Skip Error: %S ?" (car (cdr foo))))) + (message "Save Error: %S: %s" (car (cdr foo)) + objname) + (error "%S" (car (cdr foo)))))))) + (run-hook-with-args 'semanticdb-save-database-hooks + (or DB semanticdb-current-database)) + ;;(message "Saving tag summary for %s...done" objname) + ) + )) + +(defmethod semanticdb-live-p ((obj semanticdb-project-database)) + "Return non-nil if the file associated with OBJ is live. +Live databases are objects associated with existing directories." + (and (slot-boundp obj 'reference-directory) + (file-exists-p (oref obj reference-directory)))) + +(defmethod semanticdb-live-p ((obj semanticdb-table)) + "Return non-nil if the file associated with OBJ is live. +Live files are either buffers in Emacs, or files existing on the filesystem." + (let ((full-filename (semanticdb-full-filename obj))) + (or (find-buffer-visiting full-filename) + (file-exists-p full-filename)))) + +(defvar semanticdb-data-debug-on-write-error nil + "Run the data debugger on tables that issue errors. +This variable is set to nil after the first error is encountered +to prevent overload.") + +(declare-function data-debug-insert-thing "data-debug") + +(defmethod object-write ((obj semanticdb-table)) + "When writing a table, we have to make sure we deoverlay it first. +Restore the overlays after writting. +Argument OBJ is the object to write." + (when (semanticdb-live-p obj) + (when (semanticdb-in-buffer-p obj) + (save-excursion + (set-buffer (semanticdb-in-buffer-p obj)) + + ;; Make sure all our tag lists are up to date. + (semantic-fetch-tags) + + ;; Try to get an accurate unmatched syntax table. + (when (and (boundp semantic-show-unmatched-syntax-mode) + semantic-show-unmatched-syntax-mode) + ;; Only do this if the user runs unmatched syntax + ;; mode display enties. + (oset obj unmatched-syntax + (semantic-show-unmatched-lex-tokens-fetch)) + ) + + ;; Make sure pointmax is up to date + (oset obj pointmax (point-max)) + )) + + ;; Make sure that the file size and other attributes are + ;; up to date. + (let ((fattr (file-attributes (semanticdb-full-filename obj)))) + (oset obj fsize (nth 7 fattr)) + (oset obj lastmodtime (nth 5 fattr)) + ) + + ;; Do it! + (condition-case tableerror + (call-next-method) + (error + (when semanticdb-data-debug-on-write-error + (require 'data-debug) + (data-debug-new-buffer (concat "*SEMANTICDB ERROR*")) + (data-debug-insert-thing obj "*" "") + (setq semanticdb-data-debug-on-write-error nil)) + (message "Error Writing Table: %s" (object-name obj)) + (error "%S" (car (cdr tableerror))))) + + ;; Clear the dirty bit. + (oset obj dirty nil) + )) + +;;; State queries +;; +(defmethod semanticdb-write-directory-p ((obj semanticdb-project-database-file)) + "Return non-nil if OBJ should be written to disk. +Uses `semanticdb-persistent-path' to determine the return value." + (let ((path semanticdb-persistent-path)) + (catch 'found + (while path + (cond ((stringp (car path)) + (if (string= (oref obj reference-directory) (car path)) + (throw 'found t))) + ((eq (car path) 'project) + ;; @TODO - EDE causes us to go in here and disable + ;; the old default 'always save' setting. + ;; + ;; With new default 'always' should I care? + (if semanticdb-project-predicate-functions + (if (run-hook-with-args-until-success + 'semanticdb-project-predicate-functions + (oref obj reference-directory)) + (throw 'found t)) + ;; If the mode is 'project, and there are no project + ;; modes, then just always save the file. If users + ;; wish to restrict the search, modify + ;; `semanticdb-persistent-path' to include desired paths. + (if (= (length semanticdb-persistent-path) 1) + (throw 'found t)) + )) + ((eq (car path) 'never) + (throw 'found nil)) + ((eq (car path) 'always) + (throw 'found t)) + (t (error "Invalid path %S" (car path)))) + (setq path (cdr path))) + (call-next-method)) + )) + +;;; Filename manipulation +;; +(defmethod semanticdb-file-table ((obj semanticdb-project-database-file) filename) + "From OBJ, return FILENAME's associated table object." + ;; Cheater option. In this case, we always have files directly + ;; under ourselves. The main project type may not. + (object-assoc (file-name-nondirectory filename) 'file (oref obj tables))) + +(defmethod semanticdb-file-name-non-directory :STATIC + ((dbclass semanticdb-project-database-file)) + "Return the file name DBCLASS will use. +File name excludes any directory part." + semanticdb-default-file-name) + +(defmethod semanticdb-file-name-directory :STATIC + ((dbclass semanticdb-project-database-file) directory) + "Return the relative directory to where DBCLASS will save its cache file. +The returned path is related to DIRECTORY." + (if semanticdb-default-save-directory + (let ((file (cedet-directory-name-to-file-name directory))) + ;; Now create a filename for the cache file in + ;; ;`semanticdb-default-save-directory'. + (expand-file-name + file (file-name-as-directory semanticdb-default-save-directory))) + directory)) + +(defmethod semanticdb-cache-filename :STATIC + ((dbclass semanticdb-project-database-file) path) + "For DBCLASS, return a file to a cache file belonging to PATH. +This could be a cache file in the current directory, or an encoded file +name in a secondary directory." + ;; Use concat and not expand-file-name, because the dir part + ;; may include some of the file name. + (concat (semanticdb-file-name-directory dbclass path) + (semanticdb-file-name-non-directory dbclass))) + +(defmethod semanticdb-full-filename ((obj semanticdb-project-database-file)) + "Fetch the full filename that OBJ refers to." + (oref obj file)) + +;;; FLUSH OLD FILES +;; +(defun semanticdb-cleanup-cache-files (&optional noerror) + "Cleanup any cache files associated with directories that no longer exist. +Optional NOERROR prevents errors from being displayed." + (interactive) + (when (and (not semanticdb-default-save-directory) + (not noerror)) + (error "No default save directory for semantic-save files")) + + (when semanticdb-default-save-directory + + ;; Calculate all the cache files we have. + (let* ((regexp (regexp-quote semanticdb-default-file-name)) + (files (directory-files semanticdb-default-save-directory + t regexp)) + (orig nil) + (to-delete nil)) + (dolist (F files) + (setq orig (cedet-file-name-to-directory-name + (file-name-nondirectory F))) + (when (not (file-exists-p (file-name-directory orig))) + (setq to-delete (cons F to-delete)) + )) + (if to-delete + (save-window-excursion + (let ((buff (get-buffer-create "*Semanticdb Delete*"))) + (with-current-buffer buff + (erase-buffer) + (insert "The following Cache files appear to be obsolete.\n\n") + (dolist (F to-delete) + (insert F "\n"))) + (pop-to-buffer buff t t) + (fit-window-to-buffer (get-buffer-window buff) nil 1) + (when (y-or-n-p "Delete Old Cache Files? ") + (mapc (lambda (F) + (message "Deleting to %s..." F) + (delete-file F)) + to-delete) + (message "done.")) + )) + ;; No files to delete + (when (not noerror) + (message "No obsolete semanticdb.cache files.")) + )))) + +(provide 'semantic/db-file) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/db-file" +;; End: + +;;; semantic/db-file.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db-find.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-find.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,1373 @@ +;;; 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 +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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 + (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)) + + +;;; 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 "*") + ))) + +;;; 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 "#)")) + result + " ") + ">") + ;; Longer results should have an abreviated form. + (format "#" + (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)) + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db-global.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-global.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,227 @@ +;;; semantic/db-global.el --- Semantic database extensions for GLOBAL + +;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Use GNU Global for by-name database searches. +;; +;; This will work as an "omniscient" database for a given project. +;; + +(require 'cedet-global) +(require 'semantic/db-find) +(require 'semantic/symref/global) + +(eval-when-compile + ;; For generic function searching. + (require 'eieio) + (require 'eieio-opt) + ) + +;;; Code: + +(declare-function data-debug-new-buffer "data-debug") +(declare-function data-debug-insert-thing result "data-debug") + +;;;###autoload +(defun semanticdb-enable-gnu-global-databases (mode) + "Enable the use of the GNU Global SemanticDB back end for all files of MODE. +This will add an instance of a GNU Global database to each buffer +in a GNU Global supported hierarchy." + (interactive + (list (completing-read + "Emable in Mode: " obarray + #'(lambda (s) (get s 'mode-local-symbol-table)) + t (symbol-name major-mode)))) + + ;; First, make sure the version is ok. + (cedet-gnu-global-version-check) + + ;; Make sure mode is a symbol. + (when (stringp mode) + (setq mode (intern mode))) + + (let ((ih (mode-local-value mode 'semantic-init-mode-hook))) + (eval `(setq-mode-local + ,mode semantic-init-mode-hook + (cons 'semanticdb-enable-gnu-global-hook ih)))) + + ) + +(defun semanticdb-enable-gnu-global-hook () + "Add support for GNU Global in the current buffer via semantic-init-hook. +MODE is the major mode to support." + (semanticdb-enable-gnu-global-in-buffer t)) + +(defclass semanticdb-project-database-global + ;; @todo - convert to one DB per directory. + (semanticdb-project-database eieio-instance-tracker) + () + "Database representing a GNU Global tags file.") + +(defun semanticdb-enable-gnu-global-in-buffer (&optional dont-err-if-not-available) + "Enable a GNU Global database in the current buffer. +Argument DONT-ERR-IF-NOT-AVAILABLE will throw an error if GNU Global +is not available for this directory." + (interactive "P") + (if (cedet-gnu-global-root) + (setq + ;; Add to the system database list. + semanticdb-project-system-databases + (cons (semanticdb-project-database-global "global") + semanticdb-project-system-databases) + ;; Apply the throttle. + semanticdb-find-default-throttle + (append semanticdb-find-default-throttle + '(omniscience)) + ) + (if dont-err-if-not-available + (message "No Global support in %s" default-directory) + (error "No Global support in %s" default-directory)) + )) + +;;; Classes: +(defclass semanticdb-table-global (semanticdb-search-results-table) + ((major-mode :initform nil) + ) + "A table for returning search results from GNU Global.") + +(defmethod semanticdb-equivalent-mode ((table semanticdb-table-global) &optional buffer) + "Return t, pretend that this table's mode is equivalent to BUFFER. +Equivalent modes are specified by by `semantic-equivalent-major-modes' +local variable." + ;; @todo - hack alert! + t) + +;;; Filename based methods +;; +(defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-global)) + "For a global database, there are no explicit tables. +For each file hit, get the traditional semantic table from that file." + ;; 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-global "GNU Global Search Table"))) + (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-global) filename) + "From OBJ, return FILENAME's associated table object." + ;; We pass in "don't load". I wonder if we need to avoid that or not? + (car (semanticdb-get-database-tables obj)) + ) + +;;; Search Overrides +;; +;; Only NAME based searches work with GLOBAL as that is all it tracks. +;; +(defmethod semanticdb-find-tags-by-name-method + ((table semanticdb-table-global) 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) + ;; Call out to GNU Global for some results. + (let* ((semantic-symref-tool 'global) + (result (semantic-symref-find-tags-by-name name 'project)) + ) + (when result + ;; We could ask to keep the buffer open, but that annoys + ;; people. + (semantic-symref-result-get-tags result)) + ))) + +(defmethod semanticdb-find-tags-by-name-regexp-method + ((table semanticdb-table-global) 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) + (let* ((semantic-symref-tool 'global) + (result (semantic-symref-find-tags-by-regexp regex 'project)) + ) + (when result + (semantic-symref-result-get-tags result)) + ))) + +(defmethod semanticdb-find-tags-for-completion-method + ((table semanticdb-table-global) 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) + (let* ((semantic-symref-tool 'global) + (result (semantic-symref-find-tags-by-completion prefix 'project)) + (faketags nil) + ) + (when result + (dolist (T (oref result :hit-text)) + ;; We should look up each tag one at a time, but I'm lazy! + ;; Doing this may be good enough. + (setq faketags (cons + (semantic-tag T 'function :faux t) + faketags)) + ) + faketags)))) + +;;; 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-global) 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 global." + (semanticdb-find-tags-by-name-method table name tags)) + +(defmethod semanticdb-deep-find-tags-by-name-regexp-method + ((table semanticdb-table-global) 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 global." + (semanticdb-find-tags-by-name-regexp-method table regex tags)) + +(defmethod semanticdb-deep-find-tags-for-completion-method + ((table semanticdb-table-global) 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 global." + (semanticdb-find-tags-for-completion-method table prefix tags)) + +(provide 'semantic/db-global) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/db-global" +;; End: + +;;; semantic/db-global.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db-javascript.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-javascript.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,311 @@ +;;; 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 . + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db-mode.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-mode.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,221 @@ +;;; semantic/db-mode.el --- Semanticdb Minor Mode + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Major mode for managing Semantic Databases automatically. + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db-ref.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-ref.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,173 @@ +;;; semantic/db-ref.el --- Handle cross-db file references + +;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Handle cross-database file references. +;; +;; Any given database may be referred to by some other database. For +;; example, if a .cpp file has a #include in a header, then that +;; header file should have a reference to the .cpp file that included +;; it. +;; +;; This is critical for purposes where a file (such as a .cpp file) +;; needs to have its caches flushed because of changes in the +;; header. Changing a header may cause a referring file to be +;; reparsed due to account for changes in defined macros, or perhaps +;; a change to files the header includes. + + +;;; Code: +(require 'eieio) +(require 'semantic) +(require 'semantic/db) +(require 'semantic/tag) + +;; For the semantic-find-tags-by-name-regexp macro. +(eval-when-compile (require 'semantic/find)) + +(defmethod semanticdb-add-reference ((dbt semanticdb-abstract-table) + include-tag) + "Add a reference for the database table DBT based on INCLUDE-TAG. +DBT is the database table that owns the INCLUDE-TAG. The reference +will be added to the database that INCLUDE-TAG refers to." + ;; NOTE: I should add a check to make sure include-tag is in DB. + ;; but I'm too lazy. + (let* ((semanticdb-find-default-throttle + (if (featurep 'semantic/db-find) + (remq 'unloaded semanticdb-find-default-throttle) + nil)) + (refdbt (semanticdb-find-table-for-include include-tag dbt)) + ;;(fullfile (semanticdb-full-filename dbt)) + ) + (when refdbt + ;; Add our filename (full path) + ;; (object-add-to-list refdbt 'file-refs fullfile) + + ;; Add our database. + (object-add-to-list refdbt 'db-refs dbt) + t))) + +(defmethod semanticdb-check-references ((dbt semanticdb-abstract-table)) + "Check and cleanup references in the database DBT. +Abstract tables would be difficult to reference." + ;; Not sure how an abstract table can have references. + nil) + +(defmethod semanticdb-includes-in-table ((dbt semanticdb-abstract-table)) + "Return a list of direct includes in table DBT." + (semantic-find-tags-by-class 'include (semanticdb-get-tags dbt))) + + +(defmethod semanticdb-check-references ((dbt semanticdb-table)) + "Check and cleanup references in the database DBT. +Any reference to a file that cannot be found, or whos file no longer +refers to DBT will be removed." + (let ((refs (oref dbt db-refs)) + (myexpr (concat "\\<" (oref dbt file))) + ) + (while refs + (let* ((ok t) + (db (car refs)) + (f (when (semanticdb-table-child-p db) + (semanticdb-full-filename db))) + ) + + ;; The file was deleted + (when (and f (not (file-exists-p f))) + (setq ok nil)) + + ;; The reference no longer includes the textual reference? + (let* ((refs (semanticdb-includes-in-table db)) + (inc (semantic-find-tags-by-name-regexp + myexpr refs))) + (when (not inc) + (setq ok nil))) + + ;; Remove not-ok databases from the list. + (when (not ok) + (object-remove-from-list dbt 'db-refs db) + )) + (setq refs (cdr refs))))) + +(defmethod semanticdb-refresh-references ((dbt semanticdb-abstract-table)) + "Refresh references to DBT in other files." + ;; alternate tables can't be edited, so can't be changed. + nil + ) + +(defmethod semanticdb-refresh-references ((dbt semanticdb-table)) + "Refresh references to DBT in other files." + (let ((refs (semanticdb-includes-in-table dbt)) + ) + (while refs + (if (semanticdb-add-reference dbt (car refs)) + nil + ;; If we succeeded, then do... nothing? + nil + ) + (setq refs (cdr refs))) + )) + +(defmethod semanticdb-notify-references ((dbt semanticdb-table) + method) + "Notify all references of the table DBT using method. +METHOD takes two arguments. + (METHOD TABLE-TO-NOTIFY DBT) +TABLE-TO-NOTIFY is a semanticdb-table which is being notified. +DBT, the second argument is DBT." + (mapc (lambda (R) (funcall method R dbt)) + (oref dbt db-refs))) + +;;; DEBUG +;; +(defclass semanticdb-ref-adebug () + ((i-depend-on :initarg :i-depend-on) + (local-table :initarg :local-table) + (i-include :initarg :i-include)) + "Simple class to allow ADEBUG to show a nice list.") + +(declare-function data-debug-new-buffer "data-debug") +(declare-function data-debug-insert-object-slots "eieio-datadebug") + +(defun semanticdb-ref-test (refresh) + "Dump out the list of references for the current buffer. +If REFRESH is non-nil, cause the current table to have its references +refreshed before dumping the result." + (interactive "p") + (require 'eieio-datadebug) + ;; If we need to refresh... then do so. + (when refresh + (semanticdb-refresh-references semanticdb-current-table)) + ;; Do the debug system + (let* ((tab semanticdb-current-table) + (myrefs (oref tab db-refs)) + (myinc (semanticdb-includes-in-table tab)) + (adbc (semanticdb-ref-adebug "DEBUG" + :i-depend-on myrefs + :local-table tab + :i-include myinc))) + (data-debug-new-buffer "*References ADEBUG*") + (data-debug-insert-object-slots adbc "!")) + ) + +(provide 'semantic/db-ref) +;;; semantic/db-ref.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db-typecache.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db-typecache.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,606 @@ +;;; db-typecache.el --- Manage Datatypes + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Manage a datatype cache. +;; +;; For typed languages like C++ collect all known types from various +;; headers, merge namespaces, and expunge duplicates. +;; +;; It is likely this feature will only be needed for C/C++. + +(require 'semantic) +(require 'semantic/db) +(require 'semantic/db-find) +(require 'semantic/analyze/fcn) + +;; For semantic-find-tags-by-* macros +(eval-when-compile (require 'semantic/find)) + +(declare-function data-debug-insert-thing "data-debug") +(declare-function data-debug-new-buffer "data-debug") +(declare-function semantic-sort-tags-by-name-then-type-increasing "semantic/sort") +(declare-function semantic-scope-tag-clone-with-scope "semantic/scope") + +;;; Code: + + +;;; TABLE TYPECACHE +;;;###autoload +(defclass semanticdb-typecache () + ((filestream :initform nil + :documentation + "Fully sorted/merged list of tags within this buffer.") + (includestream :initform nil + :documentation + "Fully sorted/merged list of tags from this file's includes list.") + (stream :initform nil + :documentation + "The searchable tag stream for this cache. +NOTE: Can I get rid of this? Use a hashtable instead?") + (dependants :initform nil + :documentation + "Any other object that is dependent on typecache results. +Said object must support `semantic-reset' methods.") + ;; @todo - add some sort of fast-hash. + ;; @note - Rebuilds in large projects already take a while, and the + ;; actual searches are pretty fast. Really needed? + ) + "Structure for maintaining a typecache.") + +(defmethod semantic-reset ((tc semanticdb-typecache)) + "Reset the object IDX." + (oset tc filestream nil) + (oset tc includestream nil) + + (oset tc stream nil) + + (mapc 'semantic-reset (oref tc dependants)) + (oset tc dependants nil) + ) + +(defmethod semanticdb-typecache-notify-reset ((tc semanticdb-typecache)) + "Do a reset from a notify from a table we depend on." + (oset tc includestream nil) + (mapc 'semantic-reset (oref tc dependants)) + (oset tc dependants nil) + ) + +(defmethod semanticdb-partial-synchronize ((tc semanticdb-typecache) + new-tags) + "Reset the typecache based on a partial reparse." + (when (semantic-find-tags-by-class 'include new-tags) + (oset tc includestream nil) + (mapc 'semantic-reset (oref tc dependants)) + (oset tc dependants nil) + ) + + (when (semantic-find-tags-by-class 'type new-tags) + ;; Reset our index + (oset tc filestream nil) + t ;; Return true, our core file tags have changed in a relavant way. + ) + + ;; NO CODE HERE + ) + +(defun semanticdb-typecache-add-dependant (dep) + "Add into the local typecache a dependant DEP." + (let* ((table semanticdb-current-table) + ;;(idx (semanticdb-get-table-index table)) + (cache (semanticdb-get-typecache table)) + ) + (object-add-to-list cache 'dependants dep))) + +(defun semanticdb-typecache-length(thing) + "How long is THING? +Debugging function." + (cond ((semanticdb-typecache-child-p thing) + (length (oref thing stream))) + ((semantic-tag-p thing) + (length (semantic-tag-type-members thing))) + ((and (listp thing) (semantic-tag-p (car thing))) + (length thing)) + ((null thing) + 0) + (t -1) )) + + +(defmethod semanticdb-get-typecache ((table semanticdb-abstract-table)) + "Retrieve the typecache from the semanticdb TABLE. +If there is no table, create one, and fill it in." + (semanticdb-refresh-table table) + (let* ((idx (semanticdb-get-table-index table)) + (cache (oref idx type-cache)) + ) + + ;; Make sure we have a cache object in the DB index. + (when (not cache) + ;; The object won't change as we fill it with stuff. + (setq cache (semanticdb-typecache (semanticdb-full-filename table))) + (oset idx type-cache cache)) + + cache)) + +(defmethod semanticdb-have-typecache-p ((table semanticdb-abstract-table)) + "Return non-nil (the typecache) if TABLE has a pre-calculated typecache." + (let* ((idx (semanticdb-get-table-index table))) + (oref idx type-cache))) + + +;;; DATABASE TYPECACHE +;; +;; A full database can cache the types across its files. +;; +;; Unlike file based caches, this one is a bit simpler, and just needs +;; to get reset when a table gets updated. + +;;;###autoload +(defclass semanticdb-database-typecache (semanticdb-abstract-db-cache) + ((stream :initform nil + :documentation + "The searchable tag stream for this cache.") + ) + "Structure for maintaining a typecache.") + +(defmethod semantic-reset ((tc semanticdb-database-typecache)) + "Reset the object IDX." + (oset tc stream nil) + ) + +(defmethod semanticdb-synchronize ((cache semanticdb-database-typecache) + new-tags) + "Synchronize a CACHE with some NEW-TAGS." + ) + +(defmethod semanticdb-partial-synchronize ((cache semanticdb-database-typecache) + new-tags) + "Synchronize a CACHE with some changed NEW-TAGS." + ) + +(defmethod semanticdb-get-typecache ((db semanticdb-project-database)) + "Retrieve the typecache from the semantic database DB. +If there is no table, create one, and fill it in." + (semanticdb-cache-get db semanticdb-database-typecache) + ) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; MERGING +;; +;; Managing long streams of tags representing data types. +;; +(defun semanticdb-typecache-apply-filename (file stream) + "Apply the filename FILE to all tags in STREAM." + (let ((new nil)) + (while stream + (setq new (cons (semantic-tag-copy (car stream) nil file) + new)) + ;The below is handled by the tag-copy fcn. + ;(semantic--tag-put-property (car new) :filename file) + (setq stream (cdr stream))) + (nreverse new))) + + +(defsubst semanticdb-typecache-safe-tag-members (tag) + "Return a list of members for TAG that are safe to permute." + (let ((mem (semantic-tag-type-members tag)) + (fname (semantic-tag-file-name tag))) + (if fname + (setq mem (semanticdb-typecache-apply-filename fname mem)) + (copy-sequence mem)))) + +(defsubst semanticdb-typecache-safe-tag-list (tags table) + "Make the tag list TAGS found in TABLE safe for the typecache. +Adds a filename and copies the tags." + (semanticdb-typecache-apply-filename + (semanticdb-full-filename table) + tags)) + +(defun semanticdb-typecache-merge-streams (cache1 cache2) + "Merge into CACHE1 and CACHE2 together. The Caches will be merged in place." + (if (or (and (not cache1) (not cache2)) + (and (not (cdr cache1)) (not cache2)) + (and (not cache1) (not (cdr cache2)))) + ;; If all caches are empty OR + ;; cache1 is length 1 and no cache2 OR + ;; no cache1 and length 1 cache2 + ;; + ;; then just return the cache, and skip all this merging stuff. + (or cache1 cache2) + + ;; Assume we always have datatypes, as this typecache isn't really + ;; useful without a typed language. + (require 'semantic/sort) + (let ((S (semantic-sort-tags-by-name-then-type-increasing + ;; I used to use append, but it copied cache1 but not cache2. + ;; Since sort was permuting cache2, I already had to make sure + ;; the caches were permute-safe. Might as well use nconc here. + (nconc cache1 cache2))) + (ans nil) + (next nil) + (prev nil) + (type nil)) + ;; With all the tags in order, we can loop over them, and when + ;; two have the same name, we can either throw one away, or construct + ;; a fresh new tag merging the items together. + (while S + (setq prev (car ans)) + (setq next (car S)) + (if (or + ;; CASE 1 - First item + (null prev) + ;; CASE 2 - New name + (not (string= (semantic-tag-name next) + (semantic-tag-name prev)))) + (setq ans (cons next ans)) + ;; ELSE - We have a NAME match. + (setq type (semantic-tag-type next)) + (if (semantic-tag-of-type-p prev type) ; Are they the same datatype + ;; Same Class, we can do a merge. + (cond + ((and (semantic-tag-of-class-p next 'type) + (string= type "namespace")) + ;; Namespaces - merge the children together. + (setcar ans + (semantic-tag-new-type + (semantic-tag-name prev) ; - they are the same + "namespace" ; - we know this as fact + (semanticdb-typecache-merge-streams + (semanticdb-typecache-safe-tag-members prev) + (semanticdb-typecache-safe-tag-members next)) + nil ; - no attributes + )) + ;; Make sure we mark this as a fake tag. + (semantic-tag-set-faux (car ans)) + ) + ((semantic-tag-prototype-p next) + ;; NEXT is a prototype... so keep previous. + nil ; - keep prev, do nothing + ) + ((semantic-tag-prototype-p prev) + ;; PREV is a prototype, but not next.. so keep NEXT. + ;; setcar - set by side-effect on top of prev + (setcar ans next) + ) + (t + ;;(message "Don't know how to merge %s. Keeping first entry." (semantic-tag-name next)) + )) + ;; Not same class... but same name + ;(message "Same name, different type: %s, %s!=%s" + ; (semantic-tag-name next) + ; (semantic-tag-type next) + ; (semantic-tag-type prev)) + (setq ans (cons next ans)) + )) + (setq S (cdr S))) + (nreverse ans)))) + +;;; Refresh / Query API +;; +;; Queries that can be made for the typecache. +(defmethod semanticdb-typecache-file-tags ((table semanticdb-abstract-table)) + "No tags available from non-file based tables." + nil) + +(defmethod semanticdb-typecache-file-tags ((table semanticdb-table)) + "Update the typecache for TABLE, and return the file-tags. +File-tags are those that belong to this file only, and excludes +all included files." + (let* (;(idx (semanticdb-get-table-index table)) + (cache (semanticdb-get-typecache table)) + ) + + ;; Make sure our file-tags list is up to date. + (when (not (oref cache filestream)) + (let ((tags (semantic-find-tags-by-class 'type table))) + (when tags + (setq tags (semanticdb-typecache-safe-tag-list tags table)) + (oset cache filestream (semanticdb-typecache-merge-streams tags nil))))) + + ;; Return our cache. + (oref cache filestream) + )) + +(defmethod semanticdb-typecache-include-tags ((table semanticdb-abstract-table)) + "No tags available from non-file based tables." + nil) + +(defmethod semanticdb-typecache-include-tags ((table semanticdb-table)) + "Update the typecache for TABLE, and return the merged types from the include tags. +Include-tags are the tags brought in via includes, all merged together into +a master list." + (let* ((cache (semanticdb-get-typecache table)) + ) + + ;; Make sure our file-tags list is up to date. + (when (not (oref cache includestream)) + (let (;; Calc the path first. This will have a nice side -effect of + ;; getting the cache refreshed if a refresh is needed. Most of the + ;; time this value is itself cached, so the query is fast. + (incpath (semanticdb-find-translate-path table nil)) + (incstream nil)) + ;; Get the translated path, and extract all the type tags, then merge + ;; them all together. + (dolist (i incpath) + ;; don't include ourselves in this crazy list. + (when (and i (not (eq i table)) + ;; @todo - This eieio fcn can be slow! Do I need it? + ;; (semanticdb-table-child-p i) + ) + (setq incstream + (semanticdb-typecache-merge-streams + incstream + ;; Getting the cache from this table will also cause this + ;; file to update it's cache from it's decendants. + ;; + ;; In theory, caches are only built for most includes + ;; only once (in the loop before this one), so this ends + ;; up being super fast as we edit our file. + (copy-sequence + (semanticdb-typecache-file-tags i)))) + )) + + ;; Save... + (oset cache includestream incstream))) + + ;; Return our cache. + (oref cache includestream) + )) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Search Routines +;;;###autoload +(define-overloadable-function semanticdb-typecache-find (type &optional path find-file-match) + "Search the typecache for TYPE in PATH. +If type is a string, split the string, and search for the parts. +If type is a list, treat the type as a pre-split string. +PATH can be nil for the current buffer, or a semanticdb table. +FIND-FILE-MATCH is non-nil to force all found tags to be loaded into a buffer.") + +(defun semanticdb-typecache-find-default (type &optional path find-file-match) + "Default implementation of `semanticdb-typecache-find'. +TYPE is the datatype to find. +PATH is the search path.. which should be one table object. +If FIND-FILE-MATCH is non-nil, then force the file belonging to the +found tag to be loaded." + (semanticdb-typecache-find-method (or path semanticdb-current-table) + type find-file-match)) + +(defun semanticdb-typecache-find-by-name-helper (name table) + "Find the tag with NAME in TABLE, which is from a typecache. +If more than one tag has NAME in TABLE, we will prefer the tag that +is of class 'type." + (let* ((names (semantic-find-tags-by-name name table)) + (types (semantic-find-tags-by-class 'type names))) + (or (car-safe types) (car-safe names)))) + +(defmethod semanticdb-typecache-find-method ((table semanticdb-abstract-table) + type find-file-match) + "Search the typecache in TABLE for the datatype TYPE. +If type is a string, split the string, and search for the parts. +If type is a list, treat the type as a pre-split string. +If FIND-FILE-MATCH is non-nil, then force the file belonging to the +found tag to be loaded." + ;; convert string to a list. + (when (stringp type) (setq type (semantic-analyze-split-name type))) + (when (stringp type) (setq type (list type))) + + ;; Search for the list in our typecache. + (let* ((file (semanticdb-typecache-file-tags table)) + (inc (semanticdb-typecache-include-tags table)) + (stream nil) + (f-ans nil) + (i-ans nil) + (ans nil) + (notdone t) + (lastfile nil) + (thisfile nil) + (lastans nil) + (calculated-scope nil) + ) + ;; 1) Find first symbol in the two master lists and then merge + ;; the found streams. + + ;; We stripped duplicates, so these will be super-fast! + (setq f-ans (semantic-find-first-tag-by-name (car type) file)) + (setq i-ans (semantic-find-first-tag-by-name (car type) inc)) + (if (and f-ans i-ans) + (progn + ;; This trick merges the two identified tags, making sure our lists are + ;; complete. The second find then gets the new 'master' from the list of 2. + (setq ans (semanticdb-typecache-merge-streams (list f-ans) (list i-ans))) + (setq ans (semantic-find-first-tag-by-name (car type) ans)) + ) + + ;; The answers are already sorted and merged, so if one misses, + ;; no need to do any special work. + (setq ans (or f-ans i-ans))) + + ;; 2) Loop over the remaining parts. + (while (and type notdone) + + ;; For pass > 1, stream will be non-nil, so do a search, otherwise + ;; ans is from outside the loop. + (when stream + (setq ans (semanticdb-typecache-find-by-name-helper (car type) stream)) + + ;; NOTE: The below test to make sure we get a type is only relevant + ;; for the SECOND pass or later. The first pass can only ever + ;; find a type/namespace because everything else is excluded. + + ;; If this is not the last entry from the list, then it + ;; must be a type or a namespace. Lets double check. + (when (cdr type) + + ;; From above, there is only one tag in ans, and we prefer + ;; types. + (when (not (semantic-tag-of-class-p ans 'type)) + + (setq ans nil))) + ) + + (push ans calculated-scope) + + ;; Track most recent file. + (setq thisfile (semantic-tag-file-name ans)) + (when (and thisfile (stringp thisfile)) + (setq lastfile thisfile)) + + ;; If we have a miss, exit, otherwise, update the stream to + ;; the next set of members. + (if (not ans) + (setq notdone nil) + (setq stream (semantic-tag-type-members ans))) + + (setq lastans ans + ans nil + type (cdr type))) + + (if (or type (not notdone)) + ;; If there is stuff left over, then we failed. Just return + ;; nothing. + nil + + ;; We finished, so return everything. + + (if (and find-file-match lastfile) + ;; This won't liven up the tag since we have a copy, but + ;; we ought to be able to get there and go to the right line. + (find-file-noselect lastfile) + ;; We don't want to find-file match, so instead lets + ;; push the filename onto the return tag. + (when lastans + (setq lastans (semantic-tag-copy lastans nil lastfile)) + ;; We used to do the below, but we would erroneously be putting + ;; attributes on tags being shred with other lists. + ;;(semantic--tag-put-property lastans :filename lastfile) + ) + ) + + (if (and lastans calculated-scope) + + ;; Put our discovered scope into the tag if we have a tag + (progn + (require 'semantic/scope) + (semantic-scope-tag-clone-with-scope + lastans (reverse (cdr calculated-scope)))) + + ;; Else, just return + lastans + )))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; BRUTISH Typecache +;; +;; Routines for a typecache that crosses all tables in a given database +;; for a matching major-mode. +(defmethod semanticdb-typecache-for-database ((db semanticdb-project-database) + &optional mode) + "Return the typecache for the project database DB. +If there isn't one, create it. +" + (let ((lmode (or mode major-mode)) + (cache (semanticdb-get-typecache db)) + (stream nil) + ) + (dolist (table (semanticdb-get-database-tables db)) + (when (eq lmode (oref table :major-mode)) + (setq stream + (semanticdb-typecache-merge-streams + stream + (copy-sequence + (semanticdb-typecache-file-tags table)))) + )) + (oset cache stream stream) + cache)) + +(defun semanticdb-typecache-refresh-for-buffer (buffer) + "Refresh the typecache for BUFFER." + (save-excursion + (set-buffer buffer) + (let* ((tab semanticdb-current-table) + ;(idx (semanticdb-get-table-index tab)) + (tc (semanticdb-get-typecache tab))) + (semanticdb-typecache-file-tags tab) + (semanticdb-typecache-include-tags tab) + tc))) + + +;;; DEBUG +;; +(defun semanticdb-typecache-complete-flush () + "Flush all typecaches referenced by the current buffer." + (interactive) + (let* ((path (semanticdb-find-translate-path nil nil))) + (dolist (P path) + (oset P pointmax nil) + (semantic-reset (semanticdb-get-typecache P))))) + +(defun semanticdb-typecache-dump () + "Dump the typecache for the current buffer." + (interactive) + (require 'data-debug) + (let* ((start (current-time)) + (tc (semanticdb-typecache-refresh-for-buffer (current-buffer))) + (end (current-time)) + ) + (data-debug-new-buffer "*TypeCache ADEBUG*") + (message "Calculating Cache took %.2f seconds." + (semantic-elapsed-time start end)) + + (data-debug-insert-thing tc "]" "") + + )) + +(defun semanticdb-db-typecache-dump () + "Dump the typecache for the current buffer's database." + (interactive) + (require 'data-debug) + (let* ((tab semanticdb-current-table) + (idx (semanticdb-get-table-index tab)) + (junk (oset idx type-cache nil)) ;; flush! + (start (current-time)) + (tc (semanticdb-typecache-for-database (oref tab parent-db))) + (end (current-time)) + ) + (data-debug-new-buffer "*TypeCache ADEBUG*") + (message "Calculating Cache took %.2f seconds." + (semantic-elapsed-time start end)) + + (data-debug-insert-thing tc "]" "") + + )) + +(provide 'semantic/db-typecache) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/db-typecache" +;; End: + +;;; semanticdb-typecache.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/db.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/db.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,1026 @@ +;;; 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 +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Maintain a database of tags for a group of files and enable +;; queries into the database. +;; +;; By default, assume one database per directory. +;; + +;;; Code: + +(require 'eieio-base) +(require 'semantic) + +(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)) + ) + )))) + + +;;; 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)) + + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/debug.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/debug.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,576 @@ +;;; semantic/debug.el --- Language Debugger framework + +;;; Copyright (C) 2003, 2004, 2005, 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; To provide better support for debugging parsers, this framework +;; provides the interface for debugging. The work of parsing and +;; controlling and stepping through the parsing work must be implemented +;; by the parser. +;; +;; Fortunatly, the nature of language support files means that the parser +;; may not need to be instrumented first. +;; +;; The debugger uses EIEIO objects. One object controls the user +;; interface, including stepping, data-view, queries. A second +;; object implemented here represents the parser itself. A third represents +;; a parser independent frame which knows how to highlight the parser buffer. +;; Each parser must implement the interface and override any methods as needed. +;; + +(require 'semantic) +(require 'eieio) +(eval-when-compile (require 'semantic/find)) + +;;; Code: + +;;;###autoload +(defvar semantic-debug-parser-source nil + "For any buffer, the file name (no path) of the parser. +This would be a parser for a specific language, not the source +to one of the parser generators.") +;;;###autoload +(make-variable-buffer-local 'semantic-debug-parser-source) + +;;;###autoload +(defvar semantic-debug-parser-class nil + "Class to create when building a debug parser object.") +;;;###autoload +(make-variable-buffer-local 'semantic-debug-parser-class) + +(defvar semantic-debug-enabled nil + "Non-nil when debugging a parser.") + +;;; Variables used during a debug session. +(defvar semantic-debug-current-interface nil + "The debugger interface currently active for this buffer.") + +(defvar semantic-debug-current-parser nil + "The parser current active for this buffer.") + +;;; User Interface Portion +;; +(defclass semantic-debug-interface () + ((parser-buffer :initarg :parser-buffer + :type buffer + :documentation + "The buffer containing the parser we are debugging.") + (parser-local-map :initarg :parser-local-map + :type keymap + :documentation + "The local keymap originally in the PARSER buffer.") + (parser-location :type marker + :documentation + "A marker representing where we are in the parser buffer.") + (source-buffer :initarg :source-buffer + :type buffer + :documentation + "The buffer containing the source we are parsing. +The :parser-buffer defines a parser that can parse the text in the +:source-buffer.") + (source-local-map :initarg :source-local-map + :type keymap + :documentation + "The local keymap originally in the SOURCE buffer.") + (source-location :type marker + :documentation + "A marker representing where we are in the parser buffer.") + (data-buffer :initarg :data-buffer + :type buffer + :documentation + "Buffer being used to display some useful data. +These buffers are brought into view when layout occurs.") + (current-frame :type semantic-debug-frame + :documentation + "The currently displayed frame.") + (overlays :type list + :initarg nil + :documentation + "Any active overlays being used to show the debug position.") + ) + "Controls action when in `semantic-debug-mode'") + +;; Methods +(defmethod semantic-debug-set-frame ((iface semantic-debug-interface) frame) + "Set the current frame on IFACE to FRAME." + (if frame + (oset iface current-frame frame) + (slot-makeunbound iface 'current-frame))) + +(defmethod semantic-debug-set-parser-location ((iface semantic-debug-interface) point) + "Set the parser location in IFACE to POINT." + (save-excursion + (set-buffer (oref iface parser-buffer)) + (if (not (slot-boundp iface 'parser-location)) + (oset iface parser-location (make-marker))) + (move-marker (oref iface parser-location) point)) + ) + +(defmethod semantic-debug-set-source-location ((iface semantic-debug-interface) point) + "Set the source location in IFACE to POINT." + (save-excursion + (set-buffer (oref iface source-buffer)) + (if (not (slot-boundp iface 'source-location)) + (oset iface source-location (make-marker))) + (move-marker (oref iface source-location) point)) + ) + +(defmethod semantic-debug-interface-layout ((iface semantic-debug-interface)) + "Layout windows in the current frame to facilitate debugging." + (delete-other-windows) + ;; Deal with the data buffer + (when (slot-boundp iface 'data-buffer) + (let ((lines (/ (frame-height (selected-frame)) 3)) + (cnt (save-excursion + (set-buffer (oref iface data-buffer)) + (count-lines (point-min) (point-max)))) + ) + ;; Set the number of lines to 1/3, or the size of the data buffer. + (if (< cnt lines) (setq cnt lines)) + + (split-window-vertically cnt) + (switch-to-buffer (oref iface data-buffer)) + ) + (other-window 1)) + ;; Parser + (switch-to-buffer (oref iface parser-buffer)) + (when (slot-boundp iface 'parser-location) + (goto-char (oref iface parser-location))) + (split-window-vertically) + (other-window 1) + ;; Source + (switch-to-buffer (oref iface source-buffer)) + (when (slot-boundp iface 'source-location) + (goto-char (oref iface source-location))) + ) + +(defmethod semantic-debug-highlight-lexical-token ((iface semantic-debug-interface) token) + "For IFACE, highlight TOKEN in the source buffer . +TOKEN is a lexical token." + (set-buffer (oref iface :source-buffer)) + + (object-add-to-list iface 'overlays + (semantic-lex-highlight-token token)) + + (semantic-debug-set-source-location iface (semantic-lex-token-start token)) + ) + +(defmethod semantic-debug-highlight-rule ((iface semantic-debug-interface) nonterm &optional rule match) + "For IFACE, highlight NONTERM in the parser buffer. +NONTERM is the name of the rule currently being processed that shows up +as a nonterminal (or tag) in the source buffer. +If RULE and MATCH indicies are specified, highlight those also." + (set-buffer (oref iface :parser-buffer)) + + (let* ((rules (semantic-find-tags-by-class 'nonterminal (current-buffer))) + (nt (semantic-find-first-tag-by-name nonterm rules)) + (o nil) + ) + (when nt + ;; I know it is the first symbol appearing in the body of this token. + (goto-char (semantic-tag-start nt)) + + (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point)))) + (semantic-overlay-put o 'face 'highlight) + + (object-add-to-list iface 'overlays o) + + (semantic-debug-set-parser-location iface (semantic-overlay-start o)) + + (when (and rule match) + + ;; Rule, an int, is the rule inside the nonterminal we are following. + (re-search-forward ":\\s-*") + (while (/= 0 rule) + (re-search-forward "^\\s-*|\\s-*") + (setq rule (1- rule))) + + ;; Now find the match inside the rule + (while (/= 0 match) + (forward-sexp 1) + (skip-chars-forward " \t") + (setq match (1- match))) + + ;; Now highlight the thingy we find there. + (setq o (semantic-make-overlay (point) (progn (forward-sexp 1) (point)))) + (semantic-overlay-put o 'face 'highlight) + + (object-add-to-list iface 'overlays o) + + ;; If we have a match for a sub-rule, have the parser position + ;; move so we can see it in the output window for very long rules. + (semantic-debug-set-parser-location iface (semantic-overlay-start o)) + + )))) + +(defmethod semantic-debug-unhighlight ((iface semantic-debug-interface)) + "Remove all debugging overlays." + (mapc 'semantic-overlay-delete (oref iface overlays)) + (oset iface overlays nil)) + +;; Call from the parser at a breakpoint +(defvar semantic-debug-user-command nil + "The command the user is requesting.") + +(defun semantic-debug-break (frame) + "Stop parsing now at FRAME. +FRAME is an object that represents the parser's view of the +current state of the world. +This function enters a recursive edit. It returns +on an `exit-recursive-edit', or if someone uses one +of the `semantic-debug-mode' commands. +It returns the command specified. Parsers need to take action +on different types of return values." + (save-window-excursion + ;; Set up displaying information + (semantic-debug-mode t) + (unwind-protect + (progn + (semantic-debug-frame-highlight frame) + (semantic-debug-interface-layout semantic-debug-current-interface) + (condition-case nil + ;; Enter recursive edit... wait for user command. + (recursive-edit) + (error nil))) + (semantic-debug-unhighlight semantic-debug-current-interface) + (semantic-debug-mode nil)) + ;; Find the requested user state. Do something. + (let ((returnstate semantic-debug-user-command)) + (setq semantic-debug-user-command nil) + returnstate) + )) + +;;; Frame +;; +;; A frame can represent the state at a break point. +(defclass semantic-debug-frame () + ( + ) + "One frame representation.") + +(defmethod semantic-debug-frame-highlight ((frame semantic-debug-frame)) + "Highlight one parser frame." + + ) + +(defmethod semantic-debug-frame-info ((frame semantic-debug-frame)) + "Display info about this one parser frame." + + ) + +;;; Major Mode +;; +(defvar semantic-debug-mode-map + (let ((km (make-sparse-keymap))) + (define-key km "n" 'semantic-debug-next) + (define-key km " " 'semantic-debug-next) + (define-key km "s" 'semantic-debug-step) + (define-key km "u" 'semantic-debug-up) + (define-key km "d" 'semantic-debug-down) + (define-key km "f" 'semantic-debug-fail-match) + (define-key km "h" 'semantic-debug-print-state) + (define-key km "s" 'semantic-debug-jump-to-source) + (define-key km "p" 'semantic-debug-jump-to-parser) + (define-key km "q" 'semantic-debug-quit) + (define-key km "a" 'semantic-debug-abort) + (define-key km "g" 'semantic-debug-go) + (define-key km "b" 'semantic-debug-set-breakpoint) + ;; Some boring bindings. + (define-key km "e" 'eval-expression) + + km) + "Keymap used when in semantic-debug-node.") + +(defun semantic-debug-mode (onoff) + "Turn `semantic-debug-mode' on and off. +Argument ONOFF is non-nil when we are entering debug mode. +\\{semantic-debug-mode-map}" + (let ((iface semantic-debug-current-interface)) + (if onoff + ;; Turn it on + (save-excursion + (set-buffer (oref iface parser-buffer)) + ;; Install our map onto this buffer + (use-local-map semantic-debug-mode-map) + ;; Make the buffer read only + (toggle-read-only 1) + + (set-buffer (oref iface source-buffer)) + ;; Use our map in the source buffer also + (use-local-map semantic-debug-mode-map) + ;; Make the buffer read only + (toggle-read-only 1) + ;; Hooks + (run-hooks 'semantic-debug-mode-hook) + ) + ;; Restore old mode information + (save-excursion + (set-buffer + (oref semantic-debug-current-interface parser-buffer)) + (use-local-map + (oref semantic-debug-current-interface parser-local-map)) + ) + (save-excursion + (set-buffer + (oref semantic-debug-current-interface source-buffer)) + (use-local-map + (oref semantic-debug-current-interface source-local-map)) + ) + (run-hooks 'semantic-debug-exit-hook) + ))) + +(defun semantic-debug () + "Parse the current buffer and run in debug mode." + (interactive) + (if semantic-debug-current-interface + (error "You are already in a debug session")) + (if (not semantic-debug-parser-class) + (error "This major mode does not support parser debugging")) + ;; Clear the cache to force a full reparse. + (semantic-clear-toplevel-cache) + ;; Do the parse + (let ((semantic-debug-enabled t) + ;; Create an interface + (semantic-debug-current-interface + (let ((parserb (semantic-debug-find-parser-source))) + (semantic-debug-interface + "Debug Interface" + :parser-buffer parserb + :parser-local-map (save-excursion + (set-buffer parserb) + (current-local-map)) + :source-buffer (current-buffer) + :source-local-map (current-local-map) + ))) + ;; Create a parser debug interface + (semantic-debug-current-parser + (funcall semantic-debug-parser-class "parser")) + ) + ;; We could recurse into a parser while debugging. + ;; Is that a problem? + (semantic-fetch-tags) + ;; We should turn the auto-parser back on, but don't do it for + ;; now until the debugger is working well. + )) + +(defun semantic-debug-find-parser-source () + "Return a buffer containing the parser source file for the current buffer. +The parser needs to be on the load path, or this routine returns nil." + (if (not semantic-debug-parser-source) + (error "No parser is associated with this buffer")) + (let ((parser (locate-library semantic-debug-parser-source t))) + (if parser + (find-file-noselect parser) + (error "Cannot find parser source. It should be on the load-path")))) + +;;; Debugger commands +;; +(defun semantic-debug-next () + "Perform one parser operation. +In the recursive parser, this steps past one match rule. +In other parsers, this may be just like `semantic-debug-step'." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-next parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-step () + "Perform one parser operation." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-step parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-up () + "Move highlighting representation up one level." + (interactive) + (message "Not implemented yet.") + ) + +(defun semantic-debug-down () + "Move highlighting representation down one level." + (interactive) + (message "Not implemented yet.") + ) + +(defun semantic-debug-fail-match () + "Artificially fail the current match." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-fail parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-print-state () + "Show interesting parser state." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-print-state parser) + ) + ) + +(defun semantic-debug-jump-to-source () + "Move cursor to the source code being parsed at the current lexical token." + (interactive) + (let* ((interface semantic-debug-current-interface) + (buf (oref interface source-buffer))) + (if (get-buffer-window buf) + (progn + (select-frame (window-frame (get-buffer-window buf))) + (select-window (get-buffer-window buf))) + ;; Technically, this should do a window layout operation + (switch-to-buffer buf)) + ) + ) + +(defun semantic-debug-jump-to-parser () + "Move cursor to the parser being debugged." + (interactive) + (let* ((interface semantic-debug-current-interface) + (buf (oref interface parser-buffer))) + (if (get-buffer-window buf) + (progn + (select-frame (window-frame (get-buffer-window buf))) + (select-window (get-buffer-window buf))) + ;; Technically, this should do a window layout operation + (switch-to-buffer buf)) + ) + ) + +(defun semantic-debug-quit () + "Exit debug mode, blowing all stack, and leaving the parse incomplete. +Do not update any tokens already parsed." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-quit parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-abort () + "Abort one level of debug mode, blowing all stack." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-abort parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-go () + "Continue parsing till finish or breakpoint." + (interactive) + (let ((parser semantic-debug-current-parser)) + (semantic-debug-parser-go parser) + (exit-recursive-edit) + ) + ) + +(defun semantic-debug-set-breakpoint () + "Set a breakpoint at the current rule location." + (interactive) + (let ((parser semantic-debug-current-parser) + ;; Get the location as semantic tokens. + (location (semantic-current-tag)) + ) + (if location + (semantic-debug-parser-break parser location) + (error "Not on a rule")) + ) + ) + + +;;; Debugger superclass +;; +(defclass semantic-debug-parser () + ( + ) + "Represents a parser and its state. +When implementing the debug parser you can add extra functionality +by overriding one of the command methods. Be sure to use +`call-next-method' so that the debug command is saved, and passed +down to your parser later." + :abstract t) + +(defmethod semantic-debug-parser-next ((parser semantic-debug-parser)) + "Execute next for this PARSER." + (setq semantic-debug-user-command 'next) + ) + +(defmethod semantic-debug-parser-step ((parser semantic-debug-parser)) + "Execute a step for this PARSER." + (setq semantic-debug-user-command 'step) + ) + +(defmethod semantic-debug-parser-go ((parser semantic-debug-parser)) + "Continue executiong in this PARSER until the next breakpoint." + (setq semantic-debug-user-command 'go) + ) + +(defmethod semantic-debug-parser-fail ((parser semantic-debug-parser)) + "Continue executiong in this PARSER until the next breakpoint." + (setq semantic-debug-user-command 'fail) + ) + +(defmethod semantic-debug-parser-quit ((parser semantic-debug-parser)) + "Continue executiong in this PARSER until the next breakpoint." + (setq semantic-debug-user-command 'quit) + ) + +(defmethod semantic-debug-parser-abort ((parser semantic-debug-parser)) + "Continue executiong in this PARSER until the next breakpoint." + (setq semantic-debug-user-command 'abort) + ) + +(defmethod semantic-debug-parser-print-state ((parser semantic-debug-parser)) + "Print state for this PARSER at the current breakpoint." + (with-slots (current-frame) semantic-debug-current-interface + (when current-frame + (semantic-debug-frame-info current-frame) + ))) + +(defmethod semantic-debug-parser-break ((parser semantic-debug-parser)) + "Set a breakpoint for this PARSER." + ) + +;; Stack stuff +(defmethod semantic-debug-parser-frames ((parser semantic-debug-parser)) + "Return a list of frames for the current parser. +A frame is of the form: + ( .. .what ? .. ) +" + (error "Parser has not implemented frame values") + ) + + +(provide 'semantic/debug) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/debug" +;; End: + +;;; semantic/debug.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/decorate.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/decorate.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,299 @@ +;;; semantic/decorate.el --- Utilities for decorating/highlighting tokens. + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2005, 2006, 2007, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Text representing a semantic tag is wrapped in an overlay. +;; This overlay can be used for highlighting, or setting other +;; editing properties on a tag, such as "read only." +;; + +(require 'semantic) +(require 'pulse) + +;;; Code: + +;;; Highlighting Basics +(defun semantic-highlight-tag (tag &optional face) + "Specify that TAG should be highlighted. +Optional FACE specifies the face to use." + (let ((o (semantic-tag-overlay tag))) + (semantic-overlay-put o 'old-face + (cons (semantic-overlay-get o 'face) + (semantic-overlay-get o 'old-face))) + (semantic-overlay-put o 'face (or face 'semantic-tag-highlight-face)) + )) + +(defun semantic-unhighlight-tag (tag) + "Unhighlight TAG, restoring it's previous face." + (let ((o (semantic-tag-overlay tag))) + (semantic-overlay-put o 'face (car (semantic-overlay-get o 'old-face))) + (semantic-overlay-put o 'old-face (cdr (semantic-overlay-get o 'old-face))) + )) + +;;; Momentary Highlighting - One line +(defun semantic-momentary-highlight-one-tag-line (tag &optional face) + "Highlight the first line of TAG, unhighlighting before next command. +Optional argument FACE specifies the face to do the highlighting." + (save-excursion + ;; Go to first line in tag + (semantic-go-to-tag tag) + (pulse-momentary-highlight-one-line (point)))) + +;;; Momentary Highlighting - Whole Tag +(defun semantic-momentary-highlight-tag (tag &optional face) + "Highlight TAG, removing highlighting when the user hits a key. +Optional argument FACE is the face to use for highlighting. +If FACE is not specified, then `highlight' will be used." + (when (semantic-tag-with-position-p tag) + (if (not (semantic-overlay-p (semantic-tag-overlay tag))) + ;; No overlay, but a position. Highlight the first line only. + (semantic-momentary-highlight-one-tag-line tag face) + ;; The tag has an overlay, highlight the whole thing + (pulse-momentary-highlight-overlay (semantic-tag-overlay tag) + face) + ))) + +(defun semantic-set-tag-face (tag face) + "Specify that TAG should use FACE for display." + (semantic-overlay-put (semantic-tag-overlay tag) 'face face)) + +(defun semantic-set-tag-invisible (tag &optional visible) + "Enable the text in TAG to be made invisible. +If VISIBLE is non-nil, make the text visible." + (semantic-overlay-put (semantic-tag-overlay tag) 'invisible + (not visible))) + +(defun semantic-tag-invisible-p (tag) + "Return non-nil if TAG is invisible." + (semantic-overlay-get (semantic-tag-overlay tag) 'invisible)) + +(defun semantic-set-tag-intangible (tag &optional tangible) + "Enable the text in TAG to be made intangible. +If TANGIBLE is non-nil, make the text visible. +This function does not have meaning in XEmacs because it seems that +the extent 'intangible' property does not exist." + (semantic-overlay-put (semantic-tag-overlay tag) 'intangible + (not tangible))) + +(defun semantic-tag-intangible-p (tag) + "Return non-nil if TAG is intangible. +This function does not have meaning in XEmacs because it seems that +the extent 'intangible' property does not exist." + (semantic-overlay-get (semantic-tag-overlay tag) 'intangible)) + +(defun semantic-overlay-signal-read-only + (overlay after start end &optional len) + "Hook used in modification hooks to prevent modification. +Allows deletion of the entire text. +Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system." + ;; Stolen blithly from cpp.el in Emacs 21.1 + (if (and (not after) + (or (< (semantic-overlay-start overlay) start) + (> (semantic-overlay-end overlay) end))) + (error "This text is read only"))) + +(defun semantic-set-tag-read-only (tag &optional writable) + "Enable the text in TAG to be made read-only. +Optional argument WRITABLE should be non-nil to make the text writable +instead of read-only." + (let ((o (semantic-tag-overlay tag)) + (hook (if writable nil '(semantic-overlay-signal-read-only)))) + (if (featurep 'xemacs) + ;; XEmacs extents have a 'read-only' property. + (semantic-overlay-put o 'read-only (not writable)) + (semantic-overlay-put o 'modification-hooks hook) + (semantic-overlay-put o 'insert-in-front-hooks hook) + (semantic-overlay-put o 'insert-behind-hooks hook)))) + +(defun semantic-tag-read-only-p (tag) + "Return non-nil if the current TAG is marked read only." + (let ((o (semantic-tag-overlay tag))) + (if (featurep 'xemacs) + ;; XEmacs extents have a 'read-only' property. + (semantic-overlay-get o 'read-only) + (member 'semantic-overlay-signal-read-only + (semantic-overlay-get o 'modification-hooks))))) + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/decorate/include.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/decorate/include.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,774 @@ +;;; semantic/decorate/include.el --- Decoration modes for include statements + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Highlight any include that is in a state the user may care about. +;; The basic idea is to have the state be highly visible so users will +;; as 'what is this?" and get the info they need to fix problems that +;; are otherwises transparent when trying to get smart completion +;; working. + +(require 'semantic/decorate/mode) +(require 'semantic/db) +(require 'semantic/db-ref) +(require 'semantic/db-find) + +(eval-when-compile + (require 'semantic/find)) + +(defvar semantic-dependency-system-include-path) +(declare-function ede-get-locator-object "ede/files") +(declare-function ede-system-include-path "ede/cpp-root") + +;;; Code: + +;;; FACES AND KEYMAPS +(defvar semantic-decoratiton-mouse-3 (if (featurep 'xemacs) [ button3 ] [ mouse-3 ]) + "The keybinding lisp object to use for binding the right mouse button.") + +;;; Includes that that are in a happy state! +;; +(defface semantic-decoration-on-includes + nil + "*Overlay Face used on includes that are not in some other state. +Used by the decoration style: `semantic-decoration-on-includes'." + :group 'semantic-faces) + +(defvar semantic-decoration-on-include-map + (let ((km (make-sparse-keymap))) + (define-key km semantic-decoratiton-mouse-3 'semantic-decoration-include-menu) + km) + "Keymap used on includes.") + + +(defvar semantic-decoration-on-include-menu nil + "Menu used for include headers.") + +(easy-menu-define + semantic-decoration-on-include-menu + semantic-decoration-on-include-map + "Include Menu" + (list + "Include" + (semantic-menu-item + ["What Is This?" semantic-decoration-include-describe + :active t + :help "Describe why this include has been marked this way." ]) + (semantic-menu-item + ["Visit This Include" semantic-decoration-include-visit + :active t + :help "Visit this include file." ]) + "---" + (semantic-menu-item + ["Summarize includes current buffer" semantic-decoration-all-include-summary + :active t + :help "Show a summary for the current buffer containing this include." ]) + (semantic-menu-item + ["List found includes (load unparsed)" semanticdb-find-test-translate-path + :active t + :help "List all includes found for this file, and parse unparsed files." ]) + (semantic-menu-item + ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading + :active t + :help "List all includes found for this file, do not parse unparsed files." ]) + (semantic-menu-item + ["List all unknown includes" semanticdb-find-adebug-lost-includes + :active t + :help "Show a list of all includes semantic cannot find for this file." ]) + "---" + (semantic-menu-item + ["Customize System Include Path" semantic-customize-system-include-path + :active (get 'semantic-dependency-system-include-path major-mode) + :help "Run customize for the system include path for this major mode." ]) + (semantic-menu-item + ["Add a System Include Path" semantic-add-system-include + :active t + :help "Add an include path for this session." ]) + (semantic-menu-item + ["Remove a System Include Path" semantic-remove-system-include + :active t + :help "Add an include path for this session." ]) + ;;["" semantic-decoration-include- + ;; :active t + ;; :help "" ] + )) + +;;; Unknown Includes! +;; +(defface semantic-decoration-on-unknown-includes + '((((class color) (background dark)) + (:background "#900000")) + (((class color) (background light)) + (:background "#ff5050"))) + "*Face used to show includes that cannot be found. +Used by the decoration style: `semantic-decoration-on-unknown-includes'." + :group 'semantic-faces) + +(defvar semantic-decoration-on-unknown-include-map + (let ((km (make-sparse-keymap))) + ;(define-key km [ mouse-2 ] 'semantic-decoration-unknown-include-describe) + (define-key km semantic-decoratiton-mouse-3 'semantic-decoration-unknown-include-menu) + km) + "Keymap used on unparsed includes.") + +(defvar semantic-decoration-on-unknown-include-menu nil + "Menu used for unparsed include headers.") + +(easy-menu-define + semantic-decoration-on-unknown-include-menu + semantic-decoration-on-unknown-include-map + "Unknown Include Menu" + (list + "Unknown Include" + (semantic-menu-item + ["What Is This?" semantic-decoration-unknown-include-describe + :active t + :help "Describe why this include has been marked this way." ]) + (semantic-menu-item + ["List all unknown includes" semanticdb-find-adebug-lost-includes + :active t + :help "Show a list of all includes semantic cannot find for this file." ]) + "---" + (semantic-menu-item + ["Summarize includes current buffer" semantic-decoration-all-include-summary + :active t + :help "Show a summary for the current buffer containing this include." ]) + (semantic-menu-item + ["List found includes (load unparsed)" semanticdb-find-test-translate-path + :active t + :help "List all includes found for this file, and parse unparsed files." ]) + (semantic-menu-item + ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading + :active t + :help "List all includes found for this file, do not parse unparsed files." ]) + "---" + (semantic-menu-item + ["Customize System Include Path" semantic-customize-system-include-path + :active (get 'semantic-dependency-system-include-path major-mode) + :help "Run customize for the system include path for this major mode." ]) + (semantic-menu-item + ["Add a System Include Path" semantic-add-system-include + :active t + :help "Add an include path for this session." ]) + (semantic-menu-item + ["Remove a System Include Path" semantic-remove-system-include + :active t + :help "Add an include path for this session." ]) + )) + +;;; Includes that need to be parsed. +;; +(defface semantic-decoration-on-unparsed-includes + '((((class color) (background dark)) + (:background "#555500")) + (((class color) (background light)) + (:background "#ffff55"))) + "*Face used to show includes that have not yet been parsed. +Used by the decoration style: `semantic-decoration-on-unparsed-includes'." + :group 'semantic-faces) + +(defvar semantic-decoration-on-unparsed-include-map + (let ((km (make-sparse-keymap))) + (define-key km semantic-decoratiton-mouse-3 'semantic-decoration-unparsed-include-menu) + km) + "Keymap used on unparsed includes.") + + +(defvar semantic-decoration-on-unparsed-include-menu nil + "Menu used for unparsed include headers.") + +(easy-menu-define + semantic-decoration-on-unparsed-include-menu + semantic-decoration-on-unparsed-include-map + "Unparsed Include Menu" + (list + "Unparsed Include" + (semantic-menu-item + ["What Is This?" semantic-decoration-unparsed-include-describe + :active t + :help "Describe why this include has been marked this way." ]) + (semantic-menu-item + ["Visit This Include" semantic-decoration-include-visit + :active t + :help "Visit this include file so that header file's tags can be used." ]) + (semantic-menu-item + ["Parse This Include" semantic-decoration-unparsed-include-parse-include + :active t + :help "Parse this include file so that header file's tags can be used." ]) + (semantic-menu-item + ["Parse All Includes" semantic-decoration-unparsed-include-parse-all-includes + :active t + :help "Parse all the includes so the contents can be used." ]) + "---" + (semantic-menu-item + ["Summarize includes current buffer" semantic-decoration-all-include-summary + :active t + :help "Show a summary for the current buffer containing this include." ]) + (semantic-menu-item + ["List found includes (load unparsed)" semanticdb-find-test-translate-path + :active t + :help "List all includes found for this file, and parse unparsed files." ]) + (semantic-menu-item + ["List found includes (no loading)" semanticdb-find-test-translate-path-no-loading + :active t + :help "List all includes found for this file, do not parse unparsed files." ]) + (semantic-menu-item + ["List all unknown includes" semanticdb-find-adebug-lost-includes + :active t + :help "Show a list of all includes semantic cannot find for this file." ]) + "---" + (semantic-menu-item + ["Customize System Include Path" semantic-customize-system-include-path + :active (get 'semantic-dependency-system-include-path major-mode) + :help "Run customize for the system include path for this major mode." ]) + (semantic-menu-item + ["Add a System Include Path" semantic-add-system-include + :active t + :help "Add an include path for this session." ]) + (semantic-menu-item + ["Remove a System Include Path" semantic-remove-system-include + :active t + :help "Add an include path for this session." ]) + ;;["" semantic-decoration-unparsed-include- + ;; :active t + ;; :help "" ] + )) + + +;;; MODES + +;;; Include statement Decorate Mode +;; +;; This mode handles the three states of an include statements +;; +(define-semantic-decoration-style semantic-decoration-on-includes + "Highlight class members that are includes. +This mode provides a nice context menu on the include statements." + :enabled t) + +(defun semantic-decoration-on-includes-p-default (tag) + "Return non-nil if TAG has is an includes that can't be found." + (semantic-tag-of-class-p tag 'include)) + +(defun semantic-decoration-on-includes-highlight-default (tag) + "Highlight the include TAG to show that semantic can't find it." + (let* ((file (semantic-dependency-tag-file tag)) + (table (when file + (semanticdb-file-table-object file t))) + (face nil) + (map nil) + ) + (cond + ((not file) + ;; Cannot find this header. + (setq face 'semantic-decoration-on-unknown-includes + map semantic-decoration-on-unknown-include-map) + ) + ((and table (number-or-marker-p (oref table pointmax))) + ;; A found and parsed file. + (setq face 'semantic-decoration-on-includes + map semantic-decoration-on-include-map) + ) + (t + ;; An unparsed file. + (setq face 'semantic-decoration-on-unparsed-includes + map semantic-decoration-on-unparsed-include-map) + (when table + ;; Set ourselves up for synchronization + (semanticdb-cache-get + table 'semantic-decoration-unparsed-include-cache) + ;; Add a dependancy. + (let ((table semanticdb-current-table)) + (semanticdb-add-reference table tag)) + ) + )) + + (let ((ol (semantic-decorate-tag tag + (semantic-tag-start tag) + (semantic-tag-end tag) + face)) + ) + (semantic-overlay-put ol 'mouse-face 'highlight) + (semantic-overlay-put ol 'keymap map) + (semantic-overlay-put ol 'help-echo + "Header File : mouse-3 - Context menu") + ))) + +;;; Regular Include Functions +;; +(defun semantic-decoration-include-describe () + "Describe what unparsed includes are in the current buffer. +Argument EVENT is the mouse clicked event." + (interactive) + (let* ((tag (or (semantic-current-tag) + (error "No tag under point"))) + (file (semantic-dependency-tag-file tag)) + (table (when file + (semanticdb-file-table-object file t)))) + (with-output-to-temp-buffer (help-buffer) ; "*Help*" + (help-setup-xref (list #'semantic-decoration-include-describe) + (interactive-p)) + (princ "Include File: ") + (princ (semantic-format-tag-name tag nil t)) + (princ "\n") + (princ "This include file was found at:\n ") + (princ (semantic-dependency-tag-file tag)) + (princ "\n\n") + (princ "Semantic knows where this include file is, and has parsed +its contents. + +") + (let ((inc (semantic-find-tags-by-class 'include table)) + (ok 0) + (unknown 0) + (unparsed 0) + (all 0)) + (dolist (i inc) + (let* ((fileinner (semantic-dependency-tag-file i)) + ) + (cond ((not fileinner) + (setq unknown (1+ unknown))) + ((number-or-marker-p (oref table pointmax)) + (setq ok (1+ ok))) + (t + (setq unparsed (1+ unparsed)))))) + (setq all (+ ok unknown unparsed)) + (if (= 0 all) + (princ "There are no other includes in this file.\n") + (princ (format "There are %d more includes in this file.\n" + all)) + (princ (format " Unknown Includes: %d\n" unknown)) + (princ (format " Unparsed Includes: %d\n" unparsed)) + (princ (format " Parsed Includes: %d\n" ok))) + ) + ;; Get the semanticdb statement, and display it's contents. + (princ "\nDetails for header file...\n") + (princ "\nMajor Mode: ") + (princ (oref table :major-mode)) + (princ "\nTags: ") + (princ (format "%s entries" (length (oref table :tags)))) + (princ "\nFile Size: ") + (princ (format "%s chars" (oref table :pointmax))) + (princ "\nSave State: ") + (cond ((oref table dirty) + (princ "Table needs to be saved.")) + (t + (princ "Table is saved on disk.")) + ) + (princ "\nExternal References:") + (dolist (r (oref table db-refs)) + (princ "\n ") + (princ (oref r file))) + ))) + +;;;###autoload +(defun semantic-decoration-include-visit () + "Visit the included file at point." + (interactive) + (let ((tag (semantic-current-tag))) + (unless (eq (semantic-tag-class tag) 'include) + (error "Point is not on an include tag")) + (let ((file (semantic-dependency-tag-file tag))) + (cond + ((or (not file) (not (file-exists-p file))) + (error "Could not location include %s" + (semantic-tag-name tag))) + ((get-file-buffer file) + (switch-to-buffer (get-file-buffer file))) + ((stringp file) + (find-file file)) + )))) + +(defun semantic-decoration-include-menu (event) + "Popup a menu that can help a user understand unparsed includes. +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-decoration-on-include-menu) + ) + (select-window startwin))) + + +;;; Unknown Include functions +;; +(defun semantic-decoration-unknown-include-describe () + "Describe what unknown includes are in the current buffer. +Argument EVENT is the mouse clicked event." + (interactive) + (let ((tag (semantic-current-tag)) + (mm major-mode)) + (with-output-to-temp-buffer (help-buffer) ; "*Help*" + (help-setup-xref (list #'semantic-decoration-unknown-include-describe) + (interactive-p)) + (princ "Include File: ") + (princ (semantic-format-tag-name tag nil t)) + (princ "\n\n") + (princ "This header file has been marked \"Unknown\". +This means that Semantic has not been able to locate this file on disk. + +When Semantic cannot find an include file, this means that the +idle summary mode and idle completion modes cannot use the contents of +that file to provide coding assistance. + +If this is a system header and you want it excluded from Semantic's +searches (which may be desirable for speed reasons) then you can +safely ignore this state. + +If this is a system header, and you want to include it in Semantic's +searches, then you will need to use: + +M-x semantic-add-system-include RET /path/to/includes RET + +or, in your .emacs file do: + + (semantic-add-system-include \"/path/to/include\" '") + (princ (symbol-name mm)) + (princ ") + +to add the path to Semantic's search. + +If this is an include file that belongs to your project, then you may +need to update `semanticdb-project-roots' or better yet, use `ede' +to manage your project. See the ede manual for projects that will +wrap existing project code for Semantic's benifit. +") + + (when (or (eq mm 'c++-mode) (eq mm 'c-mode)) + (princ " +For C/C++ includes located within a a project, you can use a special +EDE project that will wrap an existing build system. You can do that +like this in your .emacs file: + + (ede-cpp-root-project \"NAME\" :file \"FILENAME\" :locate-fcn 'MYFCN) + +See the CEDET manual, the EDE manual, or the commentary in +ede-cpp-root.el for more. + +If you think this header tag is marked in error, you may need to do: + +C-u M-x bovinate RET + +to refresh the tags in this buffer, and recalculate the state.")) + + (princ " +See the Semantic manual node on SemanticDB for more about search paths.") + ))) + +(defun semantic-decoration-unknown-include-menu (event) + "Popup a menu that can help a user understand unparsed includes. +Argument EVENT describes the event that caused this function to be called." + (interactive "e") + (let* ((startwin (selected-window)) + ;; This line has an issue in XEmacs. + (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-decoration-on-unknown-include-menu) + ) + (select-window startwin))) + + +;;; Interactive parts of unparsed includes +;; +(defun semantic-decoration-unparsed-include-describe () + "Describe what unparsed includes are in the current buffer. +Argument EVENT is the mouse clicked event." + (interactive) + (let ((tag (semantic-current-tag))) + (with-output-to-temp-buffer (help-buffer); "*Help*" + (help-setup-xref (list #'semantic-decoration-unparsed-include-describe) + (interactive-p)) + + (princ "Include File: ") + (princ (semantic-format-tag-name tag nil t)) + (princ "\n") + (princ "This include file was found at:\n ") + (princ (semantic-dependency-tag-file tag)) + (princ "\n\n") + (princ "This header file has been marked \"Unparsed\". +This means that Semantic has located this header file on disk +but has not yet opened and parsed this file. + +So long as this header file is unparsed, idle summary and +idle completion will not be able to reference the details in this +header. + +To resolve this, use the context menu to parse this include file, +or all include files referred to in ") + (princ (buffer-name)) + (princ ". +This can take a while in large projects. + +Alternately, you can call: + +M-x semanticdb-find-test-translate-path RET + +to search path Semantic uses to perform completion. + + +If you think this header tag is marked in error, you may need to do: + +C-u M-x bovinate RET + +to refresh the tags in this buffer, and recalculate the state. +If you find a repeatable case where a header is marked in error, +report it to cedet-devel@lists.sf.net.") ))) + + +(defun semantic-decoration-unparsed-include-menu (event) + "Popup a menu that can help a user understand unparsed includes. +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-decoration-on-unparsed-include-menu) + ) + (select-window startwin))) + +(defun semantic-decoration-unparsed-include-parse-include () + "Parse the include file the user menu-selected from." + (interactive) + (let* ((file (semantic-dependency-tag-file (semantic-current-tag)))) + (semanticdb-file-table-object file) + (semantic-decoration-unparsed-include-do-reset))) + + +(defun semantic-decoration-unparsed-include-parse-all-includes () + "Parse the include file the user menu-selected from." + (interactive) + (semanticdb-find-translate-path nil nil) + ) + + +;;; General Includes Information +;; +(defun semantic-decoration-all-include-summary () + "Provide a general summary for the state of all includes." + (interactive) + (require 'semantic/dep) + (let* ((table semanticdb-current-table) + (tags (semantic-fetch-tags)) + (inc (semantic-find-tags-by-class 'include table)) + ) + (with-output-to-temp-buffer (help-buffer) ;"*Help*" + (help-setup-xref (list #'semantic-decoration-all-include-summary) + (interactive-p)) + + (princ "Include Summary for File: ") + (princ (file-truename (buffer-file-name))) + (princ "\n") + + (when (oref table db-refs) + (princ "\nExternal Database References to this buffer:") + (dolist (r (oref table db-refs)) + (princ "\n ") + (princ (oref r file))) + ) + + (princ (format "\nThis file contains %d tags, %d of which are includes.\n" + (length tags) (length inc))) + (let ((ok 0) + (unknown 0) + (unparsed 0) + (all 0)) + (dolist (i inc) + (let* ((fileinner (semantic-dependency-tag-file i)) + (tableinner (when fileinner + (semanticdb-file-table-object fileinner t)))) + (cond ((not fileinner) + (setq unknown (1+ unknown))) + ((number-or-marker-p (oref tableinner pointmax)) + (setq ok (1+ ok))) + (t + (setq unparsed (1+ unparsed)))))) + (setq all (+ ok unknown unparsed)) + (when (not (= 0 all)) + (princ (format " Unknown Includes: %d\n" unknown)) + (princ (format " Unparsed Includes: %d\n" unparsed)) + (princ (format " Parsed Includes: %d\n" ok))) + ) + + (princ "\nInclude Path Summary:\n\n") + (when (and (boundp 'ede-object) + (boundp 'ede-object-project) + ede-object) + (princ " This file's project include search is handled by the EDE object:\n") + (princ " Buffer Target: ") + (princ (object-print ede-object)) + (princ "\n") + (when (not (eq ede-object ede-object-project)) + (princ " Buffer Project: ") + (princ (object-print ede-object-project)) + (princ "\n") + ) + (when ede-object-project + (let ((loc (ede-get-locator-object ede-object-project))) + (princ " Backup in-project Locator: ") + (princ (object-print loc)) + (princ "\n"))) + (let ((syspath (ede-system-include-path ede-object-project))) + (if (not syspath) + (princ " EDE Project system include path: Empty\n") + (princ " EDE Project system include path:\n") + (dolist (dir syspath) + (princ " ") + (princ dir) + (princ "\n")) + ))) + + (princ "\n This file's system include path is:\n") + (dolist (dir semantic-dependency-system-include-path) + (princ " ") + (princ dir) + (princ "\n")) + + (let ((unk semanticdb-find-lost-includes)) + (when unk + (princ "\nAll unknown includes:\n") + (dolist (tag unk) + (princ " ") + (princ (semantic-tag-name tag)) + (princ "\n")) + )) + + (let* ((semanticdb-find-default-throttle + (if (featurep 'semantic/db-find) + (remq 'unloaded semanticdb-find-default-throttle) + nil)) + (path (semanticdb-find-translate-path nil nil))) + (if (<= (length path) (length inc)) + (princ "\nThere are currently no includes found recursively.\n") + ;; List the full include list. + (princ "\nSummary of all includes needed by ") + (princ (buffer-name)) + (dolist (p path) + (if (slot-boundp p 'tags) + (princ (format "\n %s :\t%d tags, %d are includes. %s" + (object-name-string p) + (length (oref p tags)) + (length (semantic-find-tags-by-class + 'include p)) + (cond + ((condition-case nil + (oref p dirty) + (error nil)) + " dirty.") + ((not (number-or-marker-p (oref table pointmax))) + " Needs to be parsed.") + (t "")))) + (princ (format "\n %s :\tUnparsed" + (object-name-string p)))) + ))) + ))) + + +;;; Unparsed Include Features +;; +;; This section handles changing states of unparsed include +;; decorations base on what happens in other files. +;; + +(defclass semantic-decoration-unparsed-include-cache (semanticdb-abstract-cache) + () + "Class used to reset decorated includes. +When an include's referring file is parsed, we need to undecorate +any decorated referring includes.") + + +(defmethod semantic-reset ((obj semantic-decoration-unparsed-include-cache)) + "Reset OBJ back to it's empty settings." + (let ((table (oref obj table))) + ;; This is a hack. Add in something better? + (semanticdb-notify-references + table (lambda (tab me) + (semantic-decoration-unparsed-include-refrence-reset tab) + )) + )) + +(defmethod semanticdb-partial-synchronize ((cache semantic-decoration-unparsed-include-cache) + new-tags) + "Synchronize CACHE with some NEW-TAGS." + (if (semantic-find-tags-by-class 'include new-tags) + (semantic-reset cache))) + +(defmethod semanticdb-synchronize ((cache semantic-decoration-unparsed-include-cache) + new-tags) + "Synchronize a CACHE with some NEW-TAGS." + (semantic-reset cache)) + +(defun semantic-decoration-unparsed-include-refrence-reset (table) + "Refresh any highlighting in buffers referred to by TABLE. +If TABLE is not in a buffer, do nothing." + ;; This cache removal may seem odd in that we are "creating one", but + ;; since we cant get in the fcn unless one exists, this ought to be + ;; ok. + (let ((c (semanticdb-cache-get + table 'semantic-decoration-unparsed-include-cache))) + (semanticdb-cache-remove table c)) + + (let ((buf (semanticdb-in-buffer-p table))) + (when buf + (semantic-decorate-add-pending-decoration + 'semantic-decoration-unparsed-include-do-reset + buf) + ))) + +;;;###autoload +(defun semantic-decoration-unparsed-include-do-reset () + "Do a reset of unparsed includes in the current buffer." + (let* ((style (assoc "semantic-decoration-on-includes" + semantic-decoration-styles))) + (when (cdr style) + (let ((allinc (semantic-find-tags-included + (semantic-fetch-tags-fast)))) + ;; This will do everything, but it should be speedy since it + ;; would have been done once already. + (semantic-decorate-add-decorations allinc) + )))) + + +(provide 'semantic/decorate/include) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/decorate/include" +;; End: + +;;; semantic/decorate/include.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/decorate/mode.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/decorate/mode.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,567 @@ +;;; 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 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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) + +;;; Styles List +;; +(defcustom semantic-decoration-styles nil + "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) + +;;; 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)) + +;;; 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)))) + +;;; 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))) + +(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))) + + +;;; 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 + "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) + +(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)) + + +;;; 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)) + ))) + + +;;; 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 - 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)) + ))) + +;;; 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/dep.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/dep.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,234 @@ +;;; semantic/dep.el --- Methods for tracking dependencies (include files) + +;;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Include tags (dependencies for a given source file) usually have +;; some short name. The target file that it is dependent on is +;; generally found on some sort of path controlled by the compiler or +;; project. +;; +;; EDE or even ECB can control our project dependencies, and help us +;; find file within the setting of a given project. For system +;; dependencies, we need to depend on user supplied lists, which can +;; manifest themselves in the form of system datatabases (from +;; semanticdb.) +;; +;; Provide ways to track these different files here. + +(require 'semantic/tag) + +;;; Code: + +(defvar semantic-dependency-include-path nil + "Defines the include path used when searching for files. +This should be a list of directories to search which is specific +to the file being included. + +If `semantic-dependency-tag-file' is overridden for a given +language, this path is most likely ignored. + +The above function, reguardless of being overriden, caches the +located dependency file location in the tag property +`dependency-file'. If you override this function, you do not +need to implement your own cache. Each time the buffer is fully +reparsed, the cache will be reset. + +TODO: use ffap.el to locate such items? + +NOTE: Obsolete this, or use as special user") +(make-variable-buffer-local `semantic-dependency-include-path) + +(defvar semantic-dependency-system-include-path nil + "Defines the system include path. +This should be set with either `defvar-mode-local', or with +`semantic-add-system-include'. + +For mode authors, use +`defcustom-mode-local-semantic-dependency-system-include-path' +to create a mode-specific variable to control this. + +When searching for a file associated with a name found in an tag of +class include, this path will be inspected for includes of type +`system'. Some include tags are agnostic to this setting and will +check both the project and system directories.") +(make-variable-buffer-local `semantic-dependency-system-include-path) + +(defmacro defcustom-mode-local-semantic-dependency-system-include-path + (mode name value &optional docstring) + "Create a mode-local value of the system-dependency include path. +MODE is the `major-mode' this name/value pairs is for. +NAME is the name of the customizable value users will use. +VALUE is the path (a list of strings) to add. +DOCSTRING is a documentation string applied to the variable NAME +users will customize. + +Creates a customizable variable users can customize that will +keep semantic data structures up to date." + `(progn + ;; Create a variable users can customize. + (defcustom ,name ,value + ,docstring + :group (quote ,(intern (car (split-string (symbol-name mode) "-")))) + :group 'semantic + :type '(repeat (directory :tag "Directory")) + :set (lambda (sym val) + (set-default sym val) + (setq-mode-local ,mode + semantic-dependency-system-include-path + val) + (when (fboundp + 'semantic-decoration-unparsed-include-do-reset) + (mode-local-map-mode-buffers + 'semantic-decoration-unparsed-include-do-reset + (quote ,mode)))) + ) + ;; Set the variable to the default value. + (defvar-mode-local ,mode semantic-dependency-system-include-path + ,name + "System path to search for include files.") + ;; Bind NAME onto our variable so tools can customize it + ;; without knowing about it. + (put 'semantic-dependency-system-include-path + (quote ,mode) (quote ,name)) + )) + +;;; PATH MANAGEMENT +;; +;; Some fcns to manage paths for a give mode. +;;;###autoload +(defun semantic-add-system-include (dir &optional mode) + "Add a system include DIR to path for MODE. +Modifies a mode-local version of `semantic-dependency-system-include-path'. + +Changes made by this function are not persistent." + (interactive "DNew Include Directory: ") + (if (not mode) (setq mode major-mode)) + (let ((dirtmp (file-name-as-directory dir)) + (value + (mode-local-value mode 'semantic-dependency-system-include-path)) + ) + (add-to-list 'value dirtmp t) + (eval `(setq-mode-local ,mode + semantic-dependency-system-include-path value)) + )) + +;;;###autoload +(defun semantic-remove-system-include (dir &optional mode) + "Add a system include DIR to path for MODE. +Modifies a mode-local version of`semantic-dependency-system-include-path'. + +Changes made by this function are not persistent." + (interactive (list + (completing-read + "Include Directory to Remove: " + semantic-dependency-system-include-path)) + ) + (if (not mode) (setq mode major-mode)) + (let ((dirtmp (file-name-as-directory dir)) + (value + (mode-local-value mode 'semantic-dependency-system-include-path)) + ) + (setq value (delete dirtmp value)) + (eval `(setq-mode-local ,mode semantic-dependency-system-include-path + value)) + )) + +;;;###autoload +(defun semantic-reset-system-include (&optional mode) + "Reset the system include list to empty for MODE. +Modifies a mode-local version of +`semantic-dependency-system-include-path'." + (interactive) + (if (not mode) (setq mode major-mode)) + (eval `(setq-mode-local ,mode semantic-dependency-system-include-path + nil)) + ) + +;;;###autoload +(defun semantic-customize-system-include-path (&optional mode) + "Customize the include path for this `major-mode'. +To create a customizable include path for a major MODE, use the +macro `defcustom-mode-local-semantic-dependency-system-include-path'." + (interactive) + (let ((ips (get 'semantic-dependency-system-include-path + (or mode major-mode)))) + ;; Do we have one? + (when (not ips) + (error "There is no customizable includepath variable for %s" + (or mode major-mode))) + ;; Customize it. + (customize-variable ips))) + +;;; PATH SEARCH +;; +;; methods for finding files on a provided path. +(defmacro semantic--dependency-find-file-on-path (file path) + (if (fboundp 'locate-file) + `(locate-file ,file ,path) + `(let ((p ,path) + (found nil)) + (while (and p (not found)) + (let ((f (expand-file-name ,file (car p)))) + (if (file-exists-p f) + (setq found f))) + (setq p (cdr p))) + found))) + +(defvar ede-minor-mode) +(defvar ede-object) +(declare-function ede-system-include-path "ede") + +(defun semantic-dependency-find-file-on-path (file systemp &optional mode) + "Return an expanded file name for FILE on available paths. +If SYSTEMP is true, then only search system paths. +If optional argument MODE is non-nil, then derive paths from the +provided mode, not from the current major mode." + (if (not mode) (setq mode major-mode)) + (let ((sysp (mode-local-value + mode 'semantic-dependency-system-include-path)) + (edesys (when (and (featurep 'ede) ede-minor-mode + ede-object) + (ede-system-include-path ede-object))) + (locp (mode-local-value + mode 'semantic-dependency-include-path)) + (found nil)) + (when (file-exists-p file) + (setq found file)) + (when (and (not found) (not systemp)) + (setq found (semantic--dependency-find-file-on-path file locp))) + (when (and (not found) edesys) + (setq found (semantic--dependency-find-file-on-path file edesys))) + (when (not found) + (setq found (semantic--dependency-find-file-on-path file sysp))) + (if found (expand-file-name found)))) + + +(provide 'semantic/dep) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/dep" +;; End: + +;;; semantic/dep.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/doc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/doc.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,129 @@ +;;; 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 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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))) + )) + +(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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/ede-grammar.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/ede-grammar.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,202 @@ +;;; semantic/ede-grammar.el --- EDE support for Semantic Grammar Files + +;;; Copyright (C) 2003, 2004, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam +;; 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 . + +;;; Commentary: +;; +;; Handle .by or .wy files. + +(require 'semantic) +(require 'ede/proj) +(require 'ede/pmake) +(require 'ede/pconf) +(require 'ede/proj-elisp) +(require 'semantic/grammar) + +;;; Code: +(defclass semantic-ede-proj-target-grammar (ede-proj-target-makefile) + ((menu :initform nil) + (keybindings :initform nil) + (phony :initform t) + (sourcetype :initform + (semantic-ede-source-grammar-wisent + semantic-ede-source-grammar-bovine + )) + (availablecompilers :initform + (semantic-ede-grammar-compiler-wisent + semantic-ede-grammar-compiler-bovine + )) + ) + "This target consists of a group of grammar files. +A grammar target consists of grammar files that build Emacs Lisp programs for +parsing different languages.") + +(defvar semantic-ede-source-grammar-wisent + (ede-sourcecode "semantic-ede-grammar-source-wisent" + :name "Wisent Grammar" + :sourcepattern "\\.wy$" + ) + "Semantic Grammar source code definition for wisent.") + +(defclass semantic-ede-grammar-compiler-class (ede-compiler) + nil + "Specialized compiler for semantic grammars.") + +(defvar semantic-ede-grammar-compiler-wisent + (semantic-ede-grammar-compiler-class + "ede-emacs-wisent-compiler" + :name "emacs" + :variables '(("EMACS" . "emacs")) + :commands + '( + "@echo \"(add-to-list 'load-path nil)\" > grammar-make-script" + "@for loadpath in . ${LOADPATH}; do \\" + " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> grammar-make-script; \\" + "done;" + "@echo \"(require 'semantic-load)\" >> grammar-make-script" + "@echo \"(require 'semantic-grammar)\" >> grammar-make-script" + ;; "@echo \"(setq debug-on-error t)\" >> grammar-make-script" + "\"$(EMACS)\" -batch --no-site-file -l grammar-make-script -f semantic-grammar-batch-build-packages $^" + ) + ;; :autoconf '("AM_PATH_LISPDIR") + :sourcetype '(semantic-ede-source-grammar-wisent) + :objectextention "-wy.elc" + ) + "Compile Emacs Lisp programs.") + + +(defvar semantic-ede-source-grammar-bovine + (ede-sourcecode "semantic-ede-grammar-source-bovine" + :name "Bovine Grammar" + :sourcepattern "\\.by$" + ) + "Semantic Grammar source code definition for the bovinator.") + +(defvar semantic-ede-grammar-compiler-bovine + (semantic-ede-grammar-compiler-class + "ede-emacs-wisent-compiler" + :name "emacs" + :variables '(("EMACS" . "emacs")) + :commands + '( + "@echo \"(add-to-list 'load-path nil)\" > grammar-make-script" + "@for loadpath in . ${LOADPATH}; do \\" + " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> grammar-make-script; \\" + "done;" + "@echo \"(require 'semantic-load)\" >> grammar-make-script" + "@echo \"(require 'semantic-grammar)\" >> grammar-make-script" + ;; "@echo \"(setq debug-on-error t)\" >> grammar-make-script" + "\"$(EMACS)\" -batch --no-site-file -l grammar-make-script -f semantic-grammar-batch-build-packages $^" + ) + ;; :autoconf '("AM_PATH_LISPDIR") + :sourcetype '(semantic-ede-source-grammar-bovine) + :objectextention "-by.elc" + ) + "Compile Emacs Lisp programs.") + +;;; Target options. +(defmethod ede-buffer-mine ((this semantic-ede-proj-target-grammar) buffer) + "Return t if object THIS lays claim to the file in BUFFER. +Lays claim to all -by.el, and -wy.el files." + ;; We need to be a little more careful than this, but at the moment it + ;; is common to have only one target of this class per directory. + (if (string-match "-[bw]y\\.elc?$" (buffer-file-name buffer)) + t + (call-next-method) ; The usual thing. + )) + +(defmethod project-compile-target ((obj semantic-ede-proj-target-grammar)) + "Compile all sources in a Lisp target OBJ." + (let* ((cb (current-buffer)) + (proj (ede-target-parent obj)) + (default-directory (oref proj directory))) + (mapc (lambda (src) + (save-excursion + (set-buffer (find-file-noselect src)) + (save-excursion + (semantic-grammar-create-package)) + (save-buffer) + (let ((cf (concat (semantic-grammar-package) ".el"))) + (if (or (not (file-exists-p cf)) + (file-newer-than-file-p src cf)) + (byte-compile-file cf))))) + (oref obj source))) + (message "All Semantic Grammar sources are up to date in %s" (object-name obj))) + +;;; Makefile generation functions +;; +(defmethod ede-proj-makefile-sourcevar ((this semantic-ede-proj-target-grammar)) + "Return the variable name for THIS's sources." + (cond ((ede-proj-automake-p) + (error "No Automake support for Semantic Grammars")) + (t (concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR")))) + +(defmethod ede-proj-makefile-insert-variables :AFTER ((this semantic-ede-proj-target-grammar)) + "Insert variables needed by target THIS." + (ede-proj-makefile-insert-loadpath-items + (ede-proj-elisp-packages-to-loadpath + (list "eieio" "semantic" "inversion" "ede"))) + ;; eieio for object system needed in ede + ;; semantic because it is + ;; Inversion for versioning system. + ;; ede for project regeneration + (ede-pmake-insert-variable-shared + (concat (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL") + (insert + (mapconcat (lambda (src) + (save-excursion + (set-buffer (find-file-noselect src)) + (concat (semantic-grammar-package) ".el"))) + (oref this source) + " "))) + ) + +(defmethod ede-proj-makefile-insert-rules ((this semantic-ede-proj-target-grammar)) + "Insert rules needed by THIS target." + ;; Add in some dependencies. +;; (mapc (lambda (src) +;; (let ((nm (file-name-sans-extension src))) +;; (insert nm "-wy.el: " src "\n" +;; nm "-wy.elc: " nm "-wy.el\n\n") +;; )) +;; (oref this source)) + ;; Call the normal insertion of rules. + (call-next-method) + ) + +(defmethod ede-proj-makefile-insert-dist-dependencies ((this semantic-ede-proj-target-grammar)) + "Insert dist dependencies, or intermediate targets. +This makes sure that all grammar lisp files are created before the dist +runs, so they are always up to date. +Argument THIS is the target that should insert stuff." + (call-next-method) + (insert " $(" (ede-pmake-varname this) "_SEMANTIC_GRAMMAR_EL)") + ) + +;; (autoload 'ede-proj-target-elisp "ede/proj-elisp" +;; "Target class for Emacs/Semantic grammar files." nil nil) + +(ede-proj-register-target "semantic grammar" + semantic-ede-proj-target-grammar) + +(provide 'semantic/ede-grammar) + +;;; semantic/ede-grammar.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/edit.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/edit.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,972 @@ +;;; semantic/edit.el --- Edit Management for Semantic + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; In Semantic 1.x, changes were handled in a simplistic manner, where +;; tags that changed were reparsed one at a time. Any other form of +;; edit were managed through a full reparse. +;; +;; This code attempts to minimize the number of times a full reparse +;; needs to occur. While overlays and tags will continue to be +;; recycled in the simple case, new cases where tags are inserted +;; or old tags removed from the original list are handled. +;; + +;;; NOTES FOR IMPROVEMENT +;; +;; Work done by the incremental parser could be improved by the +;; following: +;; +;; 1. Tags created could have as a property an overlay marking a region +;; of themselves that can be edited w/out affecting the definition of +;; that tag. +;; +;; 2. Tags w/ positioned children could have a property of an +;; overlay marking the region in themselves that contain the +;; children. This could be used to better improve splicing near +;; the beginning and end of the child lists. +;; + +;;; BUGS IN INCREMENTAL PARSER +;; +;; 1. Changes in the whitespace between tags could extend a +;; following tag. These will be marked as merely unmatched +;; syntax instead. +;; +;; 2. Incremental parsing while a new function is being typed in +;; somtimes gets a chance only when lists are incomplete, +;; preventing correct context identification. + +;; +(require 'semantic) + +;;; Code: +(defvar semantic-after-partial-cache-change-hook nil + "Normal hook run after the buffer cache has been updated. + +This hook will run when the cache has been partially reparsed. +Partial reparses are incurred when a user edits a buffer, and only the +modified sections are rescanned. + +Hook functions must take one argument, which is the list of tags +updated in the current buffer. + +For language specific hooks, make sure you define this as a local hook.") + +(defvar semantic-change-hooks + '(semantic-edits-change-function-handle-changes) + "Abnormal hook run when semantic detects a change in a buffer. +Each hook function must take three arguments, identical to the +common hook `after-change-functions'.") + +(defvar semantic-reparse-needed-change-hook nil + "Hooks run when a user edit is detected as needing a reparse. +For language specific hooks, make sure you define this as a local +hook. +Not used yet; part of the next generation reparse mechanism") + +(defvar semantic-no-reparse-needed-change-hook nil + "Hooks run when a user edit is detected as not needing a reparse. +If the hook returns non-nil, then declare that a reparse is needed. +For language specific hooks, make sure you define this as a local +hook. +Not used yet; part of the next generation reparse mechanism.") + +(defvar semantic-edits-new-change-hooks nil + "Abnormal hook run when a new change is found. +Functions must take one argument representing an overlay on that change.") + +(defvar semantic-edits-delete-change-hooks nil + "Abnormal hook run before a change overlay is deleted. +Deleted changes occur when multiple changes are merged. +Functions must take one argument representing an overlay being deleted.") + +(defvar semantic-edits-move-change-hook nil + "Abnormal hook run after a change overlay is moved. +Changes move when a new change overlaps an old change. The old change +will be moved. +Functions must take one argument representing an overlay being moved.") + +(defvar semantic-edits-reparse-change-hooks nil + "Abnormal hook run after a change results in a reparse. +Functions are called before the overlay is deleted, and after the +incremental reparse.") + +(defvar semantic-edits-incremental-reparse-failed-hook nil + "Hook run after the incremental parser fails. +When this happens, the buffer is marked as needing a full reprase.") + +(semantic-varalias-obsolete 'semantic-edits-incremental-reparse-failed-hooks + 'semantic-edits-incremental-reparse-failed-hook) + +(defcustom semantic-edits-verbose-flag nil + "Non-nil means the incremental perser is verbose. +If nil, errors are still displayed, but informative messages are not." + :group 'semantic + :type 'boolean) + +;;; Change State management +;; +;; Manage a series of overlays that define changes recently +;; made to the current buffer. +;;;###autoload +(defun semantic-change-function (start end length) + "Provide a mechanism for semantic tag management. +Argument START, END, and LENGTH specify the bounds of the change." + (setq semantic-unmatched-syntax-cache-check t) + (let ((inhibit-point-motion-hooks t) + ) + (run-hook-with-args 'semantic-change-hooks start end length) + )) + +(defun semantic-changes-in-region (start end &optional buffer) + "Find change overlays which exist in whole or in part between START and END. +Optional argument BUFFER is the buffer to search for changes in." + (save-excursion + (if buffer (set-buffer buffer)) + (let ((ol (semantic-overlays-in (max start (point-min)) + (min end (point-max)))) + (ret nil)) + (while ol + (when (semantic-overlay-get (car ol) 'semantic-change) + (setq ret (cons (car ol) ret))) + (setq ol (cdr ol))) + (sort ret #'(lambda (a b) (< (semantic-overlay-start a) + (semantic-overlay-start b))))))) + +(defun semantic-edits-change-function-handle-changes (start end length) + "Run whenever a buffer controlled by `semantic-mode' change. +Tracks when and how the buffer is re-parsed. +Argument START, END, and LENGTH specify the bounds of the change." + ;; We move start/end by one so that we can merge changes that occur + ;; just before, or just after. This lets simple typing capture everything + ;; into one overlay. + (let ((changes-in-change (semantic-changes-in-region (1- start) (1+ end))) + ) + (semantic-parse-tree-set-needs-update) + (if (not changes-in-change) + (let ((o (semantic-make-overlay start end))) + (semantic-overlay-put o 'semantic-change t) + ;; Run the hooks safely. When hooks blow it, our dirty + ;; function will be removed from the list of active change + ;; functions. + (condition-case nil + (run-hook-with-args 'semantic-edits-new-change-hooks o) + (error nil))) + (let ((tmp changes-in-change)) + ;; Find greatest bounds of all changes + (while tmp + (when (< (semantic-overlay-start (car tmp)) start) + (setq start (semantic-overlay-start (car tmp)))) + (when (> (semantic-overlay-end (car tmp)) end) + (setq end (semantic-overlay-end (car tmp)))) + (setq tmp (cdr tmp))) + ;; Move the first found overlay, recycling that overlay. + (semantic-overlay-move (car changes-in-change) start end) + (condition-case nil + (run-hook-with-args 'semantic-edits-move-change-hooks + (car changes-in-change)) + (error nil)) + (setq changes-in-change (cdr changes-in-change)) + ;; Delete other changes. They are now all bound here. + (while changes-in-change + (condition-case nil + (run-hook-with-args 'semantic-edits-delete-change-hooks + (car changes-in-change)) + (error nil)) + (semantic-overlay-delete (car changes-in-change)) + (setq changes-in-change (cdr changes-in-change)))) + ))) + +(defsubst semantic-edits-flush-change (change) + "Flush the CHANGE overlay." + (condition-case nil + (run-hook-with-args 'semantic-edits-delete-change-hooks + change) + (error nil)) + (semantic-overlay-delete change)) + +(defun semantic-edits-flush-changes () + "Flush the changes in the current buffer." + (let ((changes (semantic-changes-in-region (point-min) (point-max)))) + (while changes + (semantic-edits-flush-change (car changes)) + (setq changes (cdr changes)))) + ) + +(defun semantic-edits-change-in-one-tag-p (change hits) + "Return non-nil of the overlay CHANGE exists solely in one leaf tag. +HITS is the list of tags that CHANGE is in. It can have more than +one tag in it if the leaf tag is within a parent tag." + (and (< (semantic-tag-start (car hits)) + (semantic-overlay-start change)) + (> (semantic-tag-end (car hits)) + (semantic-overlay-end change)) + ;; Recurse on the rest. If this change is inside all + ;; of these tags, then they are all leaves or parents + ;; of the smallest tag. + (or (not (cdr hits)) + (semantic-edits-change-in-one-tag-p change (cdr hits)))) + ) + +;;; Change/Tag Query functions +;; +;; A change (region of space) can effect tags in different ways. +;; These functions perform queries on a buffer to determine different +;; ways that a change effects a buffer. +;; +;; NOTE: After debugging these, replace below to no longer look +;; at point and mark (via comments I assume.) +(defsubst semantic-edits-os (change) + "For testing: Start of CHANGE, or smaller of (point) and (mark)." + (if change (semantic-overlay-start change) + (if (< (point) (mark)) (point) (mark)))) + +(defsubst semantic-edits-oe (change) + "For testing: End of CHANGE, or larger of (point) and (mark)." + (if change (semantic-overlay-end change) + (if (> (point) (mark)) (point) (mark)))) + +(defun semantic-edits-change-leaf-tag (change) + "A leaf tag which completely encompasses CHANGE. +If change overlaps a tag, but is not encompassed in it, return nil. +Use `semantic-edits-change-overlap-leaf-tag'. +If CHANGE is completely encompassed in a tag, but overlaps sub-tags, +return nil." + (let* ((start (semantic-edits-os change)) + (end (semantic-edits-oe change)) + (tags (nreverse + (semantic-find-tag-by-overlay-in-region + start end)))) + ;; A leaf is always first in this list + (if (and tags + (<= (semantic-tag-start (car tags)) start) + (> (semantic-tag-end (car tags)) end)) + ;; Ok, we have a match. If this tag has children, + ;; we have to do more tests. + (let ((chil (semantic-tag-components (car tags)))) + (if (not chil) + ;; Simple leaf. + (car tags) + ;; For this type, we say that we encompass it if the + ;; change occurs outside the range of the children. + (if (or (not (semantic-tag-with-position-p (car chil))) + (> start (semantic-tag-end (nth (1- (length chil)) chil))) + (< end (semantic-tag-start (car chil)))) + ;; We have modifications to the definition of this parent + ;; so we have to reparse the whole thing. + (car tags) + ;; We actually modified an area between some children. + ;; This means we should return nil, as that case is + ;; calculated by someone else. + nil))) + nil))) + +(defun semantic-edits-change-between-tags (change) + "Return a cache list of tags surrounding CHANGE. +The returned list is the CONS cell in the master list pointing to +a tag just before CHANGE. The CDR will have the tag just after CHANGE. +CHANGE cannot encompass or overlap a leaf tag. +If CHANGE is fully encompassed in a tag that has children, and +this change occurs between those children, this returns non-nil. +See `semantic-edits-change-leaf-tag' for details on parents." + (let* ((start (semantic-edits-os change)) + (end (semantic-edits-oe change)) + (tags (nreverse + (semantic-find-tag-by-overlay-in-region + start end))) + (list-to-search nil) + (found nil)) + (if (not tags) + (setq list-to-search semantic--buffer-cache) + ;; A leaf is always first in this list + (if (and (< (semantic-tag-start (car tags)) start) + (> (semantic-tag-end (car tags)) end)) + ;; We are completely encompassed in a tag. + (if (setq list-to-search + (semantic-tag-components (car tags))) + ;; Ok, we are completely encompassed within the first tag + ;; entry, AND that tag has children. This means that change + ;; occured outside of all children, but inside some tag + ;; with children. + (if (or (not (semantic-tag-with-position-p (car list-to-search))) + (> start (semantic-tag-end + (nth (1- (length list-to-search)) + list-to-search))) + (< end (semantic-tag-start (car list-to-search)))) + ;; We have modifications to the definition of this parent + ;; and not between it's children. Clear the search list. + (setq list-to-search nil))) + ;; Search list is nil. + )) + ;; If we have a search list, lets go. Otherwise nothing. + (while (and list-to-search (not found)) + (if (cdr list-to-search) + ;; We end when the start of the CDR is after the end of our + ;; asked change. + (if (< (semantic-tag-start (cadr list-to-search)) end) + (setq list-to-search (cdr list-to-search)) + (setq found t)) + (setq list-to-search nil))) + ;; Return it. If it is nil, there is a logic bug, and we need + ;; to avoid this bit of logic anyway. + list-to-search + )) + +(defun semantic-edits-change-over-tags (change) + "Return a cache list of tags surrounding a CHANGE encompassing tags. +CHANGE must not only include all overlapped tags (excepting possible +parent tags) in their entirety. In this case, the change may be deleting +or moving whole tags. +The return value is a vector. +Cell 0 is a list of all tags completely encompassed in change. +Cell 1 is the cons cell into a master parser cache starting with +the cell which occurs BEFORE the first position of CHANGE. +Cell 2 is the parent of cell 1, or nil for the buffer cache. +This function returns nil if any tag covered by change is not +completely encompassed. +See `semantic-edits-change-leaf-tag' for details on parents." + (let* ((start (semantic-edits-os change)) + (end (semantic-edits-oe change)) + (tags (nreverse + (semantic-find-tag-by-overlay-in-region + start end))) + (parent nil) + (overlapped-tags nil) + inner-start inner-end + (list-to-search nil)) + ;; By the time this is already called, we know that it is + ;; not a leaf change, nor a between tag change. That leaves + ;; an overlap, and this condition. + + ;; A leaf is always first in this list. + ;; Is the leaf encompassed in this change? + (if (and tags + (>= (semantic-tag-start (car tags)) start) + (<= (semantic-tag-end (car tags)) end)) + (progn + ;; We encompass one whole change. + (setq overlapped-tags (list (car tags)) + inner-start (semantic-tag-start (car tags)) + inner-end (semantic-tag-end (car tags)) + tags (cdr tags)) + ;; Keep looping while tags are inside the change. + (while (and tags + (>= (semantic-tag-start (car tags)) start) + (<= (semantic-tag-end (car tags)) end)) + + ;; Check if this new all-encompassing tag is a parent + ;; of that which went before. Only check end because + ;; we know that start is less than inner-start since + ;; tags was sorted on that. + (if (> (semantic-tag-end (car tags)) inner-end) + ;; This is a parent. Drop the children found + ;; so far. + (setq overlapped-tags (list (car tags)) + inner-start (semantic-tag-start (car tags)) + inner-end (semantic-tag-end (car tags)) + ) + ;; It is not a parent encompassing tag + (setq overlapped-tags (cons (car tags) + overlapped-tags) + inner-start (semantic-tag-start (car tags)))) + (setq tags (cdr tags))) + (if (not tags) + ;; There are no tags left, and all tags originally + ;; found are encompassed by the change. Setup our list + ;; from the cache + (setq list-to-search semantic--buffer-cache);; We have a tag ouside the list. Check for + ;; We know we have a parent because it would + ;; completely cover the change. A tag can only + ;; do that if it is a parent after we get here. + (when (and tags + (< (semantic-tag-start (car tags)) start) + (> (semantic-tag-end (car tags)) end)) + ;; We have a parent. Stuff in the search list. + (setq parent (car tags) + list-to-search (semantic-tag-components parent)) + ;; If the first of TAGS is a parent (see above) + ;; then clear out the list. All other tags in + ;; here must therefore be parents of the car. + (setq tags nil) + ;; One last check, If start is before the first + ;; tag or after the last, we may have overlap into + ;; the characters that make up the definition of + ;; the tag we are parsing. + (when (or (semantic-tag-with-position-p (car list-to-search)) + (< start (semantic-tag-start + (car list-to-search))) + (> end (semantic-tag-end + (nth (1- (length list-to-search)) + list-to-search)))) + ;; We have a problem + (setq list-to-search nil + parent nil)))) + + (when list-to-search + + ;; Ok, return the vector only if all TAGS are + ;; confirmed as the lineage of `overlapped-tags' + ;; which must have a value by now. + + ;; Loop over the search list to find the preceeding CDR. + ;; Fortunatly, (car overlapped-tags) happens to be + ;; the first tag positionally. + (let ((tokstart (semantic-tag-start (car overlapped-tags)))) + (while (and list-to-search + ;; Assume always (car (cdr list-to-search)). + ;; A thrown error will be captured nicely, but + ;; that case shouldn't happen. + + ;; We end when the start of the CDR is after the + ;; end of our asked change. + (cdr list-to-search) + (< (semantic-tag-start (car (cdr list-to-search))) + tokstart) + (setq list-to-search (cdr list-to-search))))) + ;; Create the return vector + (vector overlapped-tags + list-to-search + parent) + )) + nil))) + +;;; Default Incremental Parser +;; +;; Logic about how to group changes for effective reparsing and splicing. + +(defun semantic-parse-changes-failed (&rest args) + "Signal that Semantic failed to parse changes. +That is, display a message by passing all ARGS to `format', then throw +a 'semantic-parse-changes-failed exception with value t." + (when semantic-edits-verbose-flag + (message "Semantic parse changes failed: %S" + (apply 'format args))) + (throw 'semantic-parse-changes-failed t)) + +(defsubst semantic-edits-incremental-fail () + "When the incremental parser fails, we mark that we need a full reparse." + ;;(debug) + (semantic-parse-tree-set-needs-rebuild) + (when semantic-edits-verbose-flag + (message "Force full reparse (%s)" + (buffer-name (current-buffer)))) + (run-hooks 'semantic-edits-incremental-reparse-failed-hook)) + +(defun semantic-edits-incremental-parser () + "Incrementally reparse the current buffer. +Incremental parser allows semantic to only reparse those sections of +the buffer that have changed. This function depends on +`semantic-edits-change-function-handle-changes' setting up change +overlays in the current buffer. Those overlays are analyzed against +the semantic cache to see what needs to be changed." + (let ((changed-tags + ;; Don't use `semantic-safe' here to explicitly catch errors + ;; and reset the parse tree. + (catch 'semantic-parse-changes-failed + (if debug-on-error + (semantic-edits-incremental-parser-1) + (condition-case err + (semantic-edits-incremental-parser-1) + (error + (message "incremental parser error: %S" + (error-message-string err)) + t)))))) + (when (eq changed-tags t) + ;; Force a full reparse. + (semantic-edits-incremental-fail) + (setq changed-tags nil)) + changed-tags)) + +(defmacro semantic-edits-assert-valid-region () + "Asert that parse-start and parse-end are sorted correctly." +;;; (if (> parse-start parse-end) +;;; (error "Bug is %s !> %d! Buff min/max = [ %d %d ]" +;;; parse-start parse-end +;;; (point-min) (point-max))) + ) + +(defun semantic-edits-incremental-parser-1 () + "Incrementally reparse the current buffer. +Return the list of tags that changed. +If the incremental parse fails, throw a 'semantic-parse-changes-failed +exception with value t, that can be caught to schedule a full reparse. +This function is for internal use by `semantic-edits-incremental-parser'." + (let* ((changed-tags nil) + (debug-on-quit t) ; try to find this annoying bug! + (changes (semantic-changes-in-region + (point-min) (point-max))) + (tags nil) ;tags found at changes + (newf-tags nil) ;newfound tags in change + (parse-start nil) ;location to start parsing + (parse-end nil) ;location to end parsing + (parent-tag nil) ;parent of the cache list. + (cache-list nil) ;list of children within which + ;we incrementally reparse. + (reparse-symbol nil) ;The ruled we start at for reparse. + (change-group nil) ;changes grouped in this reparse + (last-cond nil) ;track the last case used. + ;query this when debugging to find + ;source of bugs. + ) + (or changes + ;; If we were called, and there are no changes, then we + ;; don't know what to do. Force a full reparse. + (semantic-parse-changes-failed "Don't know what to do")) + ;; Else, we have some changes. Loop over them attempting to + ;; patch things up. + (while changes + ;; Calculate the reparse boundary. + ;; We want to take some set of changes, and group them + ;; together into a small change group. One change forces + ;; a reparse of a larger region (the size of some set of + ;; tags it encompases.) It may contain several tags. + ;; That region may have other changes in it (several small + ;; changes in one function, for example.) + ;; Optimize for the simple cases here, but try to handle + ;; complex ones too. + + (while (and changes ; we still have changes + (or (not parse-start) + ;; Below, if the change we are looking at + ;; is not the first change for this + ;; iteration, and it starts before the end + ;; of current parse region, then it is + ;; encompased within the bounds of tags + ;; modified by the previous iteration's + ;; change. + (< (semantic-overlay-start (car changes)) + parse-end))) + + ;; REMOVE LATER + (if (eq (car changes) (car change-group)) + (semantic-parse-changes-failed + "Possible infinite loop detected")) + + ;; Store this change in this change group. + (setq change-group (cons (car changes) change-group)) + + (cond + ;; Is this is a new parse group? + ((not parse-start) + (setq last-cond "new group") + (let (tmp) + (cond + +;;;; Are we encompassed all in one tag? + ((setq tmp (semantic-edits-change-leaf-tag (car changes))) + (setq last-cond "Encompassed in tag") + (setq tags (list tmp) + parse-start (semantic-tag-start tmp) + parse-end (semantic-tag-end tmp) + ) + (semantic-edits-assert-valid-region)) + +;;;; Did the change occur between some tags? + ((setq cache-list (semantic-edits-change-between-tags + (car changes))) + (setq last-cond "Between and not overlapping tags") + ;; The CAR of cache-list is the tag just before + ;; our change, but wasn't modified. Hmmm. + ;; Bound our reparse between these two tags + (setq tags nil + parent-tag + (car (semantic-find-tag-by-overlay + parse-start))) + (cond + ;; A change at the beginning of the buffer. + ;; Feb 06 - + ;; IDed when the first cache-list tag is after + ;; our change, meaning there is nothing before + ;; the chnge. + ((> (semantic-tag-start (car cache-list)) + (semantic-overlay-end (car changes))) + (setq last-cond "Beginning of buffer") + (setq parse-start + ;; Don't worry about parents since + ;; there there would be an exact + ;; match in the tag list otherwise + ;; and the routine would fail. + (point-min) + parse-end + (semantic-tag-start (car cache-list))) + (semantic-edits-assert-valid-region) + ) + ;; A change stuck on the first surrounding tag. + ((= (semantic-tag-end (car cache-list)) + (semantic-overlay-start (car changes))) + (setq last-cond "Beginning of Tag") + ;; Reparse that first tag. + (setq parse-start + (semantic-tag-start (car cache-list)) + parse-end + (semantic-overlay-end (car changes)) + tags + (list (car cache-list))) + (semantic-edits-assert-valid-region) + ) + ;; A change at the end of the buffer. + ((not (car (cdr cache-list))) + (setq last-cond "End of buffer") + (setq parse-start (semantic-tag-end + (car cache-list)) + parse-end (point-max)) + (semantic-edits-assert-valid-region) + ) + (t + (setq last-cond "Default") + (setq parse-start + (semantic-tag-end (car cache-list)) + parse-end + (semantic-tag-start (car (cdr cache-list))) + ) + (semantic-edits-assert-valid-region)))) + +;;;; Did the change completely overlap some number of tags? + ((setq tmp (semantic-edits-change-over-tags + (car changes))) + (setq last-cond "Overlap multiple tags") + ;; Extract the information + (setq tags (aref tmp 0) + cache-list (aref tmp 1) + parent-tag (aref tmp 2)) + ;; We can calculate parse begin/end by checking + ;; out what is in TAGS. The one near start is + ;; always first. Make sure the reprase includes + ;; the `whitespace' around the snarfed tags. + ;; Since cache-list is positioned properly, use it + ;; to find that boundary. + (if (eq (car tags) (car cache-list)) + ;; Beginning of the buffer! + (let ((end-marker (nth (length tags) + cache-list))) + (setq parse-start (point-min)) + (if end-marker + (setq parse-end + (semantic-tag-start end-marker)) + (setq parse-end (semantic-overlay-end + (car changes)))) + (semantic-edits-assert-valid-region) + ) + ;; Middle of the buffer. + (setq parse-start + (semantic-tag-end (car cache-list))) + ;; For the end, we need to scoot down some + ;; number of tags. We 1+ the length of tags + ;; because we want to skip the first tag + ;; (remove 1-) then want the tag after the end + ;; of the list (1+) + (let ((end-marker (nth (1+ (length tags)) cache-list))) + (if end-marker + (setq parse-end (semantic-tag-start end-marker)) + ;; No marker. It is the last tag in our + ;; list of tags. Only possible if END + ;; already matches the end of that tag. + (setq parse-end + (semantic-overlay-end (car changes))))) + (semantic-edits-assert-valid-region) + )) + +;;;; Unhandled case. + ;; Throw error, and force full reparse. + ((semantic-parse-changes-failed "Unhandled change group"))) + )) + ;; Is this change inside the previous parse group? + ;; We already checked start. + ((< (semantic-overlay-end (car changes)) parse-end) + (setq last-cond "in bounds") + nil) + ;; This change extends the current parse group. + ;; Find any new tags, and see how to append them. + ((semantic-parse-changes-failed + (setq last-cond "overlap boundary") + "Unhandled secondary change overlapping boundary")) + ) + ;; Prepare for the next iteration. + (setq changes (cdr changes))) + + ;; By the time we get here, all TAGS are children of + ;; some parent. They should all have the same start symbol + ;; since that is how the multi-tag parser works. Grab + ;; the reparse symbol from the first of the returned tags. + ;; + ;; Feb '06 - If repase-symbol is nil, then they are top level + ;; tags. (I'm guessing.) Is this right? + (setq reparse-symbol + (semantic--tag-get-property (car (or tags cache-list)) + 'reparse-symbol)) + ;; Find a parent if not provided. + (and (not parent-tag) tags + (setq parent-tag + (semantic-find-tag-parent-by-overlay + (car tags)))) + ;; We can do the same trick for our parent and resulting + ;; cache list. + (unless cache-list + (if parent-tag + (setq cache-list + ;; We need to get all children in case we happen + ;; to have a mix of positioned and non-positioned + ;; children. + (semantic-tag-components parent-tag)) + ;; Else, all the tags since there is no parent. + ;; It sucks to have to use the full buffer cache in + ;; this case because it can be big. Failure to provide + ;; however results in a crash. + (setq cache-list semantic--buffer-cache) + )) + ;; Use the boundary to calculate the new tags found. + (setq newf-tags (semantic-parse-region + parse-start parse-end reparse-symbol)) + ;; Make sure all these tags are given overlays. + ;; They have already been cooked by the parser and just + ;; need the overlays. + (let ((tmp newf-tags)) + (while tmp + (semantic--tag-link-to-buffer (car tmp)) + (setq tmp (cdr tmp)))) + + ;; See how this change lays out. + (cond + +;;;; Whitespace change + ((and (not tags) (not newf-tags)) + ;; A change that occured outside of any existing tags + ;; and there are no new tags to replace it. + (when semantic-edits-verbose-flag + (message "White space changes")) + nil + ) + +;;;; New tags in old whitespace area. + ((and (not tags) newf-tags) + ;; A change occured outside existing tags which added + ;; a new tag. We need to splice these tags back + ;; into the cache at the right place. + (semantic-edits-splice-insert newf-tags parent-tag cache-list) + + (setq changed-tags + (append newf-tags changed-tags)) + + (when semantic-edits-verbose-flag + (message "Inserted tags: (%s)" + (semantic-format-tag-name (car newf-tags)))) + ) + +;;;; Old tags removed + ((and tags (not newf-tags)) + ;; A change occured where pre-existing tags were + ;; deleted! Remove the tag from the cache. + (semantic-edits-splice-remove tags parent-tag cache-list) + + (setq changed-tags + (append tags changed-tags)) + + (when semantic-edits-verbose-flag + (message "Deleted tags: (%s)" + (semantic-format-tag-name (car tags)))) + ) + +;;;; One tag was updated. + ((and (= (length tags) 1) (= (length newf-tags) 1)) + ;; One old tag was modified, and it is replaced by + ;; One newfound tag. Splice the new tag into the + ;; position of the old tag. + ;; Do the splice. + (semantic-edits-splice-replace (car tags) (car newf-tags)) + ;; Add this tag to our list of changed toksns + (setq changed-tags (cons (car tags) changed-tags)) + ;; Debug + (when semantic-edits-verbose-flag + (message "Update Tag Table: %s" + (semantic-format-tag-name (car tags) nil t))) + ;; Flush change regardless of above if statement. + ) + +;;;; Some unhandled case. + ((semantic-parse-changes-failed "Don't know what to do"))) + + ;; We got this far, and we didn't flag a full reparse. + ;; Clear out this change group. + (while change-group + (semantic-edits-flush-change (car change-group)) + (setq change-group (cdr change-group))) + + ;; Don't increment change here because an earlier loop + ;; created change-groups. + (setq parse-start nil) + ) + ;; Mark that we are done with this glop + (semantic-parse-tree-set-up-to-date) + ;; Return the list of tags that changed. The caller will + ;; use this information to call hooks which can fix themselves. + changed-tags)) + +;; Make it the default changes parser +;;;###autoload +(defalias 'semantic-parse-changes-default + 'semantic-edits-incremental-parser) + +;;; Cache Splicing +;; +;; The incremental parser depends on the ability to parse up sections +;; of the file, and splice the results back into the cache. There are +;; three types of splices. A REPLACE, an ADD, and a REMOVE. REPLACE +;; is one of the simpler cases, as the starting cons cell representing +;; the old tag can be used to auto-splice in. ADD and REMOVE +;; require scanning the cache to find the correct location so that the +;; list can be fiddled. +(defun semantic-edits-splice-remove (oldtags parent cachelist) + "Remove OLDTAGS from PARENT's CACHELIST. +OLDTAGS are tags in the currenet buffer, preferably linked +together also in CACHELIST. +PARENT is the parent tag containing OLDTAGS. +CACHELIST should be the children from PARENT, but may be +pre-positioned to a convenient location." + (let* ((first (car oldtags)) + (last (nth (1- (length oldtags)) oldtags)) + (chil (if parent + (semantic-tag-components parent) + semantic--buffer-cache)) + (cachestart cachelist) + (cacheend nil) + ) + ;; First in child list? + (if (eq first (car chil)) + ;; First tags in the cache are being deleted. + (progn + (when semantic-edits-verbose-flag + (message "To Remove First Tag: (%s)" + (semantic-format-tag-name first))) + ;; Find the last tag + (setq cacheend chil) + (while (and cacheend (not (eq last (car cacheend)))) + (setq cacheend (cdr cacheend))) + ;; The splicable part is after cacheend.. so move cacheend + ;; one more tag. + (setq cacheend (cdr cacheend)) + ;; Splice the found end tag into the cons cell + ;; owned by the current top child. + (setcar chil (car cacheend)) + (setcdr chil (cdr cacheend)) + (when (not cacheend) + ;; No cacheend.. then the whole system is empty. + ;; The best way to deal with that is to do a full + ;; reparse + (semantic-parse-changes-failed "Splice-remove failed. Empty buffer?") + )) + (message "To Remove Middle Tag: (%s)" + (semantic-format-tag-name first))) + ;; Find in the cache the preceeding tag + (while (and cachestart (not (eq first (car (cdr cachestart))))) + (setq cachestart (cdr cachestart))) + ;; Find the last tag + (setq cacheend cachestart) + (while (and cacheend (not (eq last (car cacheend)))) + (setq cacheend (cdr cacheend))) + ;; Splice the end position into the start position. + ;; If there is no start, then this whole section is probably + ;; gone. + (if cachestart + (setcdr cachestart (cdr cacheend)) + (semantic-parse-changes-failed "Splice-remove failed.")) + + ;; Remove old overlays of these deleted tags + (while oldtags + (semantic--tag-unlink-from-buffer (car oldtags)) + (setq oldtags (cdr oldtags))) + )) + +(defun semantic-edits-splice-insert (newtags parent cachelist) + "Insert NEWTAGS into PARENT using CACHELIST. +PARENT could be nil, in which case CACHLIST is the buffer cache +which must be updated. +CACHELIST must be searched to find where NEWTAGS are to be inserted. +The positions of NEWTAGS must be synchronized with those in +CACHELIST for this to work. Some routines pre-position CACHLIST at a +convenient location, so use that." + (let* ((start (semantic-tag-start (car newtags))) + (newtagendcell (nthcdr (1- (length newtags)) newtags)) + (end (semantic-tag-end (car newtagendcell))) + ) + (if (> (semantic-tag-start (car cachelist)) start) + ;; We are at the beginning. + (let* ((pc (if parent + (semantic-tag-components parent) + semantic--buffer-cache)) + (nc (cons (car pc) (cdr pc))) ; new cons cell. + ) + ;; Splice the new cache cons cell onto the end of our list. + (setcdr newtagendcell nc) + ;; Set our list into parent. + (setcar pc (car newtags)) + (setcdr pc (cdr newtags))) + ;; We are at the end, or in the middle. Find our match first. + (while (and (cdr cachelist) + (> end (semantic-tag-start (car (cdr cachelist))))) + (setq cachelist (cdr cachelist))) + ;; Now splice into the list! + (setcdr newtagendcell (cdr cachelist)) + (setcdr cachelist newtags)))) + +(defun semantic-edits-splice-replace (oldtag newtag) + "Replace OLDTAG with NEWTAG in the current cache. +Do this by recycling OLDTAG's first CONS cell. This effectivly +causes the new tag to completely replace the old one. +Make sure that all information in the overlay is transferred. +It is presumed that OLDTAG and NEWTAG are both cooked. +When this routine returns, OLDTAG is raw, and the data will be +lost if not transferred into NEWTAG." + (let* ((oo (semantic-tag-overlay oldtag)) + (o (semantic-tag-overlay newtag)) + (oo-props (semantic-overlay-properties oo))) + (while oo-props + (semantic-overlay-put o (car oo-props) (car (cdr oo-props))) + (setq oo-props (cdr (cdr oo-props))) + ) + ;; Free the old overlay(s) + (semantic--tag-unlink-from-buffer oldtag) + ;; Recover properties + (semantic--tag-copy-properties oldtag newtag) + ;; Splice into the main list. + (setcdr oldtag (cdr newtag)) + (setcar oldtag (car newtag)) + ;; This important bit is because the CONS cell representing + ;; OLDTAG is now pointing to NEWTAG, but the NEWTAG + ;; cell is about to be abandoned. Here we update our overlay + ;; to point at the updated state of the world. + (semantic-overlay-put o 'semantic oldtag) + )) + +(add-hook 'semantic-before-toplevel-cache-flush-hook + #'semantic-edits-flush-changes) + +(provide 'semantic/edit) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/edit" +;; End: + +;;; semantic/edit.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/find.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/find.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,705 @@ +;;; 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 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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") + +;;; 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))) + +;;; 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))) + +(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 + +(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)) + +;; +;; ************************** 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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/format.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/format.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,724 @@ +;;; 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 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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'.") + +(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.") + +(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.") + + +;;; Coloring Functions +;; +(defun semantic--format-colorize-text (text face-class) + "Apply onto TEXT a color associated with FACE-CLASS. +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)) + +(defun semantic--format-colorize-merge-text (precoloredtext face-class) + "Apply onto PRECOLOREDTEXT a color associated with FACE-CLASS. +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) + )) + + +;;; 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)) + +;;;###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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/fw.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/fw.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,387 @@ +;;; 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 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; Semantic 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 + +(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))) + +;;; 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) + )))) + +;;; 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 'define-mode-overload-implementation + 'define-mode-local-override) + +(defun semantic-install-function-overrides (overrides &optional transient mode) + "Install the function OVERRIDES in the specified environment. +OVERRIDES must be an alist ((OVERLOAD . FUNCTION) ...) where OVERLOAD +is a symbol identifying an overloadable entry, and FUNCTION is the +function to override it with. +If optional argument TRANSIENT is non-nil, installed overrides can in +turn be overridden by next installation. +If optional argument MODE is non-nil, it must be a major mode symbol. +OVERRIDES will be installed globally for this major mode. If MODE is +nil, OVERRIDES will be installed locally in the current buffer. This +later installation should be done in MODE hook." + (mode-local-bind + ;; Add the semantic- prefix to OVERLOAD short names. + (mapcar + #'(lambda (e) + (let ((name (symbol-name (car e)))) + (if (string-match "^semantic-" name) + e + (cons (intern (format "semantic-%s" name)) (cdr e))))) + overrides) + (list 'constant-flag (not transient) + 'override-flag t) + mode)) + +;;; User Interrupt handling +;; +(defvar semantic-current-input-throw-symbol nil + "The current throw symbol for `semantic-exit-on-input'.") + +(defmacro semantic-exit-on-input (symbol &rest forms) + "Using SYMBOL as an argument to `throw', execute FORMS. +If FORMS includes a call to `semantic-thow-on-input', then +if a user presses any key during execution, this form macro +will exit with the value passed to `semantic-throw-on-input'. +If FORMS completes, then the return value is the same as `progn'." + `(let ((semantic-current-input-throw-symbol ,symbol)) + (catch ,symbol + ,@forms))) +(put 'semantic-exit-on-input 'lisp-indent-function 1) + +(defmacro semantic-throw-on-input (from) + "Exit with `throw' when in `semantic-exit-on-input' on user input. +FROM is an indication of where this function is called from as a value +to pass to `throw'. It is recommended to use the name of the function +calling this one." + `(when (and semantic-current-input-throw-symbol + (or (input-pending-p) (accept-process-output))) + (throw semantic-current-input-throw-symbol ,from))) + + +;;; 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))) + )) + + +;; ;;; Editor goodies ;-) +;; ;; +;; (defconst semantic-fw-font-lock-keywords +;; (eval-when-compile +;; (let* ( +;; ;; Variable declarations +;; (vl nil) +;; (kv (if vl (regexp-opt vl t) "")) +;; ;; Function declarations +;; (vf '( +;; "define-lex" +;; "define-lex-analyzer" +;; "define-lex-block-analyzer" +;; "define-lex-regex-analyzer" +;; "define-lex-spp-macro-declaration-analyzer" +;; "define-lex-spp-macro-undeclaration-analyzer" +;; "define-lex-spp-include-analyzer" +;; "define-lex-simple-regex-analyzer" +;; "define-lex-keyword-type-analyzer" +;; "define-lex-sexp-type-analyzer" +;; "define-lex-regex-type-analyzer" +;; "define-lex-string-type-analyzer" +;; "define-lex-block-type-analyzer" +;; ;;"define-mode-overload-implementation" +;; ;;"define-semantic-child-mode" +;; "define-semantic-idle-service" +;; "define-semantic-decoration-style" +;; "define-wisent-lexer" +;; "semantic-alias-obsolete" +;; "semantic-varalias-obsolete" +;; "semantic-make-obsolete-overload" +;; "defcustom-mode-local-semantic-dependency-system-include-path" +;; )) +;; (kf (if vf (regexp-opt vf t) "")) +;; ;; Regexp depths +;; (kv-depth (if kv (regexp-opt-depth kv) nil)) +;; (kf-depth (if kf (regexp-opt-depth kf) nil)) +;; ) +;; `((,(concat +;; ;; Declarative things +;; "(\\(" kv "\\|" kf "\\)" +;; ;; Whitespaces & names +;; "\\>[ \t]*\\(\\sw+\\)?[ \t]*\\(\\sw+\\)?" +;; ) +;; (1 font-lock-keyword-face) +;; (,(+ 1 kv-depth kf-depth 1) +;; (cond ((match-beginning 2) +;; font-lock-type-face) +;; ((match-beginning ,(+ 1 kv-depth 1)) +;; font-lock-function-name-face) +;; ) +;; nil t) +;; (,(+ 1 kv-depth kf-depth 1 1) +;; (cond ((match-beginning 2) +;; font-lock-variable-name-face) +;; ) +;; nil t))) +;; )) +;; "Highlighted Semantic keywords.") + +;; (when (fboundp 'font-lock-add-keywords) +;; (font-lock-add-keywords 'emacs-lisp-mode +;; semantic-fw-font-lock-keywords)) + +;;; Interfacing with edebug +;; +(defun semantic-fw-add-edebug-spec () + (def-edebug-spec semantic-exit-on-input 'def-body)) + +(add-hook 'edebug-setup-hook 'semantic-fw-add-edebug-spec) + +(provide 'semantic/fw) + +;;; semantic/fw.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/grammar-wy.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/grammar-wy.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,478 @@ +;;; semantic/grammar-wy.el --- Generated parser support file + +;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. + +;; Author: David Ponce +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; This file is generated from the grammar file semantic-grammar.wy in +;; the upstream CEDET repository. + +;;; Code: + +(require 'semantic/lex) +(defvar semantic-grammar-lex-c-char-re) + +;; Current parsed nonterminal name. +(defvar semantic-grammar-wy--nterm nil) +;; Index of rule in a nonterminal clause. +(defvar semantic-grammar-wy--rindx nil) + +;;; Declarations +;; +(defconst semantic-grammar-wy--keyword-table + (semantic-lex-make-keyword-table + '(("%default-prec" . DEFAULT-PREC) + ("%no-default-prec" . NO-DEFAULT-PREC) + ("%keyword" . KEYWORD) + ("%languagemode" . LANGUAGEMODE) + ("%left" . LEFT) + ("%nonassoc" . NONASSOC) + ("%package" . PACKAGE) + ("%prec" . PREC) + ("%put" . PUT) + ("%quotemode" . QUOTEMODE) + ("%right" . RIGHT) + ("%scopestart" . SCOPESTART) + ("%start" . START) + ("%token" . TOKEN) + ("%type" . TYPE) + ("%use-macros" . USE-MACROS)) + 'nil) + "Table of language keywords.") + +(defconst semantic-grammar-wy--token-table + (semantic-lex-make-type-table + '(("punctuation" + (GT . ">") + (LT . "<") + (OR . "|") + (SEMI . ";") + (COLON . ":")) + ("close-paren" + (RBRACE . "}") + (RPAREN . ")")) + ("open-paren" + (LBRACE . "{") + (LPAREN . "(")) + ("block" + (BRACE_BLOCK . "(LBRACE RBRACE)") + (PAREN_BLOCK . "(LPAREN RPAREN)")) + ("code" + (EPILOGUE . "%%...EOF") + (PROLOGUE . "%{...%}")) + ("sexp" + (SEXP)) + ("qlist" + (PREFIXED_LIST)) + ("char" + (CHARACTER)) + ("symbol" + (PERCENT_PERCENT . "\\`%%\\'") + (SYMBOL)) + ("string" + (STRING))) + '(("punctuation" :declared t) + ("block" :declared t) + ("sexp" matchdatatype sexp) + ("sexp" syntax "\\=") + ("sexp" :declared t) + ("qlist" matchdatatype sexp) + ("qlist" syntax "\\s'\\s-*(") + ("qlist" :declared t) + ("char" syntax semantic-grammar-lex-c-char-re) + ("char" :declared t) + ("symbol" syntax ":?\\(\\sw\\|\\s_\\)+") + ("symbol" :declared t) + ("string" :declared t) + ("keyword" :declared t))) + "Table of lexical tokens.") + +(defconst semantic-grammar-wy--parse-table + (progn + (eval-when-compile + (require 'semantic/wisent/comp)) + (wisent-compile-grammar + '((DEFAULT-PREC NO-DEFAULT-PREC KEYWORD LANGUAGEMODE LEFT NONASSOC PACKAGE PREC PUT QUOTEMODE RIGHT SCOPESTART START TOKEN TYPE USE-MACROS STRING SYMBOL PERCENT_PERCENT CHARACTER PREFIXED_LIST SEXP PROLOGUE EPILOGUE PAREN_BLOCK BRACE_BLOCK LPAREN RPAREN LBRACE RBRACE COLON SEMI OR LT GT) + nil + (grammar + ((prologue)) + ((epilogue)) + ((declaration)) + ((nonterminal)) + ((PERCENT_PERCENT))) + (prologue + ((PROLOGUE) + (wisent-raw-tag + (semantic-tag-new-code "prologue" nil)))) + (epilogue + ((EPILOGUE) + (wisent-raw-tag + (semantic-tag-new-code "epilogue" nil)))) + (declaration + ((decl) + (eval $1))) + (decl + ((default_prec_decl)) + ((no_default_prec_decl)) + ((languagemode_decl)) + ((package_decl)) + ((precedence_decl)) + ((put_decl)) + ((quotemode_decl)) + ((scopestart_decl)) + ((start_decl)) + ((keyword_decl)) + ((token_decl)) + ((type_decl)) + ((use_macros_decl))) + (default_prec_decl + ((DEFAULT-PREC) + `(wisent-raw-tag + (semantic-tag "default-prec" 'assoc :value + '("t"))))) + (no_default_prec_decl + ((NO-DEFAULT-PREC) + `(wisent-raw-tag + (semantic-tag "default-prec" 'assoc :value + '("nil"))))) + (languagemode_decl + ((LANGUAGEMODE symbols) + `(wisent-raw-tag + (semantic-tag ',(car $2) + 'languagemode :rest ',(cdr $2))))) + (package_decl + ((PACKAGE SYMBOL) + `(wisent-raw-tag + (semantic-tag-new-package ',$2 nil)))) + (precedence_decl + ((associativity token_type_opt items) + `(wisent-raw-tag + (semantic-tag ',$1 'assoc :type ',$2 :value ',$3)))) + (associativity + ((LEFT) + (progn "left")) + ((RIGHT) + (progn "right")) + ((NONASSOC) + (progn "nonassoc"))) + (put_decl + ((PUT put_name put_value) + `(wisent-raw-tag + (semantic-tag ',$2 'put :value ',(list $3)))) + ((PUT put_name put_value_list) + `(wisent-raw-tag + (semantic-tag ',$2 'put :value ',$3))) + ((PUT put_name_list put_value) + `(wisent-raw-tag + (semantic-tag ',(car $2) + 'put :rest ',(cdr $2) + :value ',(list $3)))) + ((PUT put_name_list put_value_list) + `(wisent-raw-tag + (semantic-tag ',(car $2) + 'put :rest ',(cdr $2) + :value ',$3)))) + (put_name_list + ((BRACE_BLOCK) + (mapcar 'semantic-tag-name + (semantic-parse-region + (car $region1) + (cdr $region1) + 'put_names 1)))) + (put_names + ((LBRACE) + nil) + ((RBRACE) + nil) + ((put_name) + (wisent-raw-tag + (semantic-tag $1 'put-name)))) + (put_name + ((SYMBOL)) + ((token_type))) + (put_value_list + ((BRACE_BLOCK) + (mapcar 'semantic-tag-code-detail + (semantic-parse-region + (car $region1) + (cdr $region1) + 'put_values 1)))) + (put_values + ((LBRACE) + nil) + ((RBRACE) + nil) + ((put_value) + (wisent-raw-tag + (semantic-tag-new-code "put-value" $1)))) + (put_value + ((SYMBOL any_value) + (cons $1 $2))) + (scopestart_decl + ((SCOPESTART SYMBOL) + `(wisent-raw-tag + (semantic-tag ',$2 'scopestart)))) + (quotemode_decl + ((QUOTEMODE SYMBOL) + `(wisent-raw-tag + (semantic-tag ',$2 'quotemode)))) + (start_decl + ((START symbols) + `(wisent-raw-tag + (semantic-tag ',(car $2) + 'start :rest ',(cdr $2))))) + (keyword_decl + ((KEYWORD SYMBOL string_value) + `(wisent-raw-tag + (semantic-tag ',$2 'keyword :value ',$3)))) + (token_decl + ((TOKEN token_type_opt SYMBOL string_value) + `(wisent-raw-tag + (semantic-tag ',$3 ',(if $2 'token 'keyword) + :type ',$2 :value ',$4))) + ((TOKEN token_type_opt symbols) + `(wisent-raw-tag + (semantic-tag ',(car $3) + 'token :type ',$2 :rest ',(cdr $3))))) + (token_type_opt + (nil) + ((token_type))) + (token_type + ((LT SYMBOL GT) + (progn $2))) + (type_decl + ((TYPE token_type plist_opt) + `(wisent-raw-tag + (semantic-tag ',$2 'type :value ',$3)))) + (plist_opt + (nil) + ((plist))) + (plist + ((plist put_value) + (append + (list $2) + $1)) + ((put_value) + (list $1))) + (use_name_list + ((BRACE_BLOCK) + (mapcar 'semantic-tag-name + (semantic-parse-region + (car $region1) + (cdr $region1) + 'use_names 1)))) + (use_names + ((LBRACE) + nil) + ((RBRACE) + nil) + ((SYMBOL) + (wisent-raw-tag + (semantic-tag $1 'use-name)))) + (use_macros_decl + ((USE-MACROS SYMBOL use_name_list) + `(wisent-raw-tag + (semantic-tag "macro" 'macro :type ',$2 :value ',$3)))) + (string_value + ((STRING) + (read $1))) + (any_value + ((SYMBOL)) + ((STRING)) + ((PAREN_BLOCK)) + ((PREFIXED_LIST)) + ((SEXP))) + (symbols + ((lifo_symbols) + (nreverse $1))) + (lifo_symbols + ((lifo_symbols SYMBOL) + (cons $2 $1)) + ((SYMBOL) + (list $1))) + (nonterminal + ((SYMBOL + (setq semantic-grammar-wy--nterm $1 semantic-grammar-wy--rindx 0) + COLON rules SEMI) + (wisent-raw-tag + (semantic-tag $1 'nonterminal :children $4)))) + (rules + ((lifo_rules) + (apply 'nconc + (nreverse $1)))) + (lifo_rules + ((lifo_rules OR rule) + (cons $3 $1)) + ((rule) + (list $1))) + (rule + ((rhs) + (let* + ((nterm semantic-grammar-wy--nterm) + (rindx semantic-grammar-wy--rindx) + (rhs $1) + comps prec action elt) + (setq semantic-grammar-wy--rindx + (1+ semantic-grammar-wy--rindx)) + (while rhs + (setq elt + (car rhs) + rhs + (cdr rhs)) + (cond + ((vectorp elt) + (if prec + (error "duplicate %%prec in `%s:%d' rule" nterm rindx)) + (setq prec + (aref elt 0))) + ((consp elt) + (if + (or action comps) + (setq comps + (cons elt comps) + semantic-grammar-wy--rindx + (1+ semantic-grammar-wy--rindx)) + (setq action + (car elt)))) + (t + (setq comps + (cons elt comps))))) + (wisent-cook-tag + (wisent-raw-tag + (semantic-tag + (format "%s:%d" nterm rindx) + 'rule :type + (if comps "group" "empty") + :value comps :prec prec :expr action)))))) + (rhs + (nil) + ((rhs item) + (cons $2 $1)) + ((rhs action) + (cons + (list $2) + $1)) + ((rhs PREC item) + (cons + (vector $3) + $1))) + (action + ((PAREN_BLOCK)) + ((PREFIXED_LIST)) + ((BRACE_BLOCK) + (format "(progn\n%s)" + (let + ((s $1)) + (if + (string-match "^{[ \n ]*" s) + (setq s + (substring s + (match-end 0)))) + (if + (string-match "[ \n ]*}$" s) + (setq s + (substring s 0 + (match-beginning 0)))) + s)))) + (items + ((lifo_items) + (nreverse $1))) + (lifo_items + ((lifo_items item) + (cons $2 $1)) + ((item) + (list $1))) + (item + ((SYMBOL)) + ((CHARACTER)))) + '(grammar prologue epilogue declaration nonterminal rule put_names put_values use_names))) + "Parser table.") + +(defun semantic-grammar-wy--install-parser () + "Setup the Semantic Parser." + (semantic-install-function-overrides + '((parse-stream . wisent-parse-stream))) + (setq semantic-parser-name "LALR" + semantic--parse-table semantic-grammar-wy--parse-table + semantic-debug-parser-source "semantic-grammar.wy" + semantic-flex-keywords-obarray semantic-grammar-wy--keyword-table + semantic-lex-types-obarray semantic-grammar-wy--token-table) + ;; Collect unmatched syntax lexical tokens + (semantic-make-local-hook 'wisent-discarding-token-functions) + (add-hook 'wisent-discarding-token-functions + 'wisent-collect-unmatched-syntax nil t)) + + +;;; Analyzers + +(define-lex-sexp-type-analyzer semantic-grammar-wy---sexp-analyzer + "sexp analyzer for tokens." + "\\=" + 'SEXP) + +(define-lex-sexp-type-analyzer semantic-grammar-wy---sexp-analyzer + "sexp analyzer for tokens." + "\\s'\\s-*(" + 'PREFIXED_LIST) + +(define-lex-keyword-type-analyzer semantic-grammar-wy---keyword-analyzer + "keyword analyzer for tokens." + "\\(\\sw\\|\\s_\\)+") + +(define-lex-block-type-analyzer semantic-grammar-wy---block-analyzer + "block analyzer for tokens." + "\\s(\\|\\s)" + '((("(" LPAREN PAREN_BLOCK) + ("{" LBRACE BRACE_BLOCK)) + (")" RPAREN) + ("}" RBRACE)) + ) + +(define-lex-regex-type-analyzer semantic-grammar-wy---regexp-analyzer + "regexp analyzer for tokens." + semantic-grammar-lex-c-char-re + nil + 'CHARACTER) + +(define-lex-sexp-type-analyzer semantic-grammar-wy---sexp-analyzer + "sexp analyzer for tokens." + "\\s\"" + 'STRING) + +(define-lex-regex-type-analyzer semantic-grammar-wy---regexp-analyzer + "regexp analyzer for tokens." + ":?\\(\\sw\\|\\s_\\)+" + '((PERCENT_PERCENT . "\\`%%\\'")) + 'SYMBOL) + +(define-lex-string-type-analyzer semantic-grammar-wy---string-analyzer + "string analyzer for tokens." + "\\(\\s.\\|\\s$\\|\\s'\\)+" + '((GT . ">") + (LT . "<") + (OR . "|") + (SEMI . ";") + (COLON . ":")) + 'punctuation) + +(provide 'semantic/grammar-wy) + +;;; semantic/grammar-wy.el ends here diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/grammar.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/grammar.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,1897 @@ +;;; 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 +;; Maintainer: David Ponce + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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") + +(eval-when-compile + (require 'eldoc) + (require 'semantic/edit) + (require 'semantic/find)) + + +;;;; +;;;; 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-analyzer + semantic-grammar-wy---regexp-analyzer + semantic-grammar-wy---regexp-analyzer + semantic-grammar-wy---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---sexp-analyzer + ;; Must detect punctuations after comments because the semicolon can + ;; be a punctuation or a comment start! + semantic-grammar-wy---string-analyzer + semantic-grammar-wy---block-analyzer + semantic-grammar-wy---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))))) + +;;;; +;;;; 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))) + +;;;; +;;;; 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 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 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) "") + 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 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)) + +;;;; +;;;; 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.") + +;;;; +;;;; 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))) + +;;; 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)))) + +;;; 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 + " \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 " \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 " \n;;; Analyzers\n;;\n") + + (semantic-grammar-insert-defanalyzers) + +;;;; Epilogue & Footer + + (insert " \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) + )) + +;;;; +;;;; 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))))) + +;;;; +;;;; 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)) + ("\\" + 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)) + +;;;; +;;;; 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 )") + ("EXPANDFULL" . "Lambda Key: (EXPANDFULL )") + ;; Tag Generator Macros + ("TAG" . "Generic Tag Generation: (TAG [ :key value ]*)") + ("VARIABLE-TAG" . "(VARIABLE-TAG [ :key value ]*)") + ("FUNCTION-TAG" . "(FUNCTION-TAG [ :key value ]*)") + ("TYPE-TAG" . "(TYPE-TAG [ :key value ]*)") + ("INCLUDE-TAG" . "(INCLUDE-TAG [ :key value ]*)") + ("PACKAGE-TAG" . "(PACKAGE-TAG [ :key value ]*)") + ("CODE-TAG" . "(CODE-TAG [ :key value ]*)") + ("ALIAS-TAG" . "(ALIAS-TAG [: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 diff -r 5707f7454ab5 -r bbd7017a25d9 lisp/cedet/semantic/html.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/cedet/semantic/html.el Mon Sep 28 15:15:00 2009 +0000 @@ -0,0 +1,260 @@ +;;; semantic/html.el --- Semantic details for html files + +;;; Copyright (C) 2004, 2005, 2007, 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: +;; +;; 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