diff options
133 files changed, 64499 insertions, 0 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog index bea9900d56d..2cbbc7e00f1 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2009-09-28 Eric Ludlam <zappo@gnu.org> + + CEDET (development tools) package merged. + + * cedet/*.el: + * cedet/ede/*.el: + * cedet/semantic/*.el: + * cedet/srecode/*.el: New files. + 2009-09-28 Michael Albinus <michael.albinus@gmx.de> * Makefile.in (ELCFILES): Add net/tramp-imap.elc. diff --git a/lisp/cedet/cedet.el b/lisp/cedet/cedet.el new file mode 100644 index 00000000000..c98dc9b8893 --- /dev/null +++ b/lisp/cedet/cedet.el @@ -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 <david@dponce.com> +;; Maintainer: Eric M. Ludlam <zappo@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; 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 --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el new file mode 100644 index 00000000000..54c0c933739 --- /dev/null +++ b/lisp/cedet/ede.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; EDE is the top level Lisp interface to a project management scheme +;; for Emacs. Emacs does many things well, including editing, +;; building, and debugging. Folks migrating from other IDEs don't +;; seem to think this qualifies, however, because they still have to +;; write the makefiles, and specify parameters to programs. +;; +;; This EDE mode will attempt to link these diverse programs together +;; into a comprehensive single interface, instead of a bunch of +;; different ones. + +;;; Install +;; +;; This command enables project mode on all files. +;; +;; (global-ede-mode t) + +(require 'cedet) +(require 'eieio) +(require 'eieio-speedbar) +(require 'ede/source) +(require 'ede/loaddefs) + +(declare-function ede-convert-path "ede/files") +(declare-function ede-directory-get-open-project "ede/files") +(declare-function ede-directory-get-toplevel-open-project "ede/files") +(declare-function ede-directory-project-p "ede/files") +(declare-function ede-find-subproject-for-directory "ede/files") +(declare-function ede-project-directory-remove-hash "ede/files") +(declare-function ede-project-root "ede/files") +(declare-function ede-project-root-directory "ede/files") +(declare-function ede-toplevel "ede/files") +(declare-function ede-toplevel-project "ede/files") +(declare-function ede-up-directory "ede/files") +(declare-function data-debug-new-buffer "data-debug") +(declare-function data-debug-insert-object-slots "eieio-datadebug") +(declare-function semantic-lex-make-spp-table "semantic/lex-spp") + +(defconst ede-version "1.0pre7" + "Current version of the Emacs EDE.") + +;;; Code: +(defun ede-version () + "Display the current running version of EDE." + (interactive) (message "EDE %s" ede-version)) + +(defgroup ede nil + "Emacs Development Environment gloss." + :group 'tools + :group 'convenience + ) + +(defcustom ede-auto-add-method 'ask + "Whether a new source file shoud be automatically added to a target. +Whenever a new file is encountered in a directory controlled by a +project file, all targets are queried to see if it should be added. +If the value is 'always, then the new file is added to the first +target encountered. If the value is 'multi-ask, then if more than one +target wants the file, the user is asked. If only one target wants +the file, then then it is automatically added to that target. If the +value is 'ask, then the user is always asked, unless there is no +target willing to take the file. 'never means never perform the check." + :group 'ede + :type '(choice (const always) + (const multi-ask) + (const ask) + (const never))) + +(defcustom ede-debug-program-function 'gdb + "Default Emacs command used to debug a target." + :group 'ede + :type 'sexp) ; make this be a list of options some day + + +;;; Top level classes for projects and targets + +(defclass ede-project-autoload () + ((name :initarg :name + :documentation "Name of this project type") + (file :initarg :file + :documentation "The lisp file belonging to this class.") + (proj-file :initarg :proj-file + :documentation "Name of a project file of this type.") + (proj-root :initarg :proj-root + :type function + :documentation "A function symbol to call for the project root. +This function takes no arguments, and returns the current directories +root, if available. Leave blank to use the EDE directory walking +routine instead.") + (initializers :initarg :initializers + :initform nil + :documentation + "Initializers passed to the project object. +These are used so there can be multiple types of projects +associated with a single object class, based on the initilizeres used.") + (load-type :initarg :load-type + :documentation "Fn symbol used to load this project file.") + (class-sym :initarg :class-sym + :documentation "Symbol representing the project class to use.") + (new-p :initarg :new-p + :initform t + :documentation + "Non-nil if this is an option when a user creates a project.") + ) + "Class representing minimal knowledge set to run preliminary EDE functions. +When more advanced functionality is needed from a project type, that projects +type is required and the load function used.") + +(defvar ede-project-class-files + (list + (ede-project-autoload "edeproject-makefile" + :name "Make" :file 'ede/proj + :proj-file "Project.ede" + :load-type 'ede-proj-load + :class-sym 'ede-proj-project) + (ede-project-autoload "edeproject-automake" + :name "Automake" :file 'ede/proj + :proj-file "Project.ede" + :initializers '(:makefile-type Makefile.am) + :load-type 'ede-proj-load + :class-sym 'ede-proj-project) + (ede-project-autoload "automake" + :name "automake" :file 'ede/project-am + :proj-file "Makefile.am" + :load-type 'project-am-load + :class-sym 'project-am-makefile + :new-p nil) + (ede-project-autoload "cpp-root" + :name "CPP ROOT" :file 'ede/cpp-root + :proj-file 'ede-cpp-root-project-file-for-dir + :proj-root 'ede-cpp-root-project-root + :load-type 'ede-cpp-root-load + :class-sym 'ede-cpp-root + :new-p nil) + (ede-project-autoload "emacs" + :name "EMACS ROOT" :file 'ede/emacs + :proj-file "src/emacs.c" + :proj-root 'ede-emacs-project-root + :load-type 'ede-emacs-load + :class-sym 'ede-emacs-project + :new-p nil) + (ede-project-autoload "linux" + :name "LINUX ROOT" :file 'ede/linux + :proj-file "scripts/ver_linux" + :proj-root 'ede-linux-project-root + :load-type 'ede-linux-load + :class-sym 'ede-linux-project + :new-p nil) + (ede-project-autoload "simple-overlay" + :name "Simple" :file 'ede/simple + :proj-file 'ede-simple-projectfile-for-dir + :load-type 'ede-simple-load + :class-sym 'ede-simple-project)) + "List of vectos defining how to determine what type of projects exist.") + +;;; Generic project information manager objects + +(defclass ede-target (eieio-speedbar-directory-button) + ((buttonface :initform speedbar-file-face) ;override for superclass + (name :initarg :name + :type string + :custom string + :label "Name" + :group (default name) + :documentation "Name of this target.") + ;; @todo - I think this should be "dir", and not "path". + (path :initarg :path + :type string + ;:custom string + ;:label "Path to target" + ;:group (default name) + :documentation "The path to the sources of this target. +Relative to the path of the project it belongs to.") + (source :initarg :source + :initform nil + ;; I'd prefer a list of strings. + :type list + :custom (repeat (string :tag "File")) + :label "Source Files" + :group (default source) + :documentation "Source files in this target.") + (versionsource :initarg :versionsource + :initform nil + :type list + :custom (repeat (string :tag "File")) + :label "Source Files with Version String" + :group (source) + :documentation + "Source files with a version string in them. +These files are checked for a version string whenever the EDE version +of the master project is changed. When strings are found, the version +previously there is updated.") + ;; Class level slots + ;; +; (takes-compile-command :allocation :class +; :initarg :takes-compile-command +; :type boolean +; :initform nil +; :documentation +; "Non-nil if this target requires a user approved command.") + (sourcetype :allocation :class + :type list ;; list of symbols + :documentation + "A list of `ede-sourcecode' objects this class will handle. +This is used to match target objects with the compilers they can use, and +which files this object is interested in." + :accessor ede-object-sourcecode) + (keybindings :allocation :class + :initform (("D" . ede-debug-target)) + :documentation +"Keybindings specialized to this type of target." + :accessor ede-object-keybindings) + (menu :allocation :class + :initform ( [ "Debug target" ede-debug-target + (and ede-object + (obj-of-class-p ede-object ede-target)) ] + ) + :documentation "Menu specialized to this type of target." + :accessor ede-object-menu) + ) + "A top level target to build.") + +(defclass ede-project-placeholder (eieio-speedbar-directory-button) + ((name :initarg :name + :initform "Untitled" + :type string + :custom string + :label "Name" + :group (default name) + :documentation "The name used when generating distribution files.") + (version :initarg :version + :initform "1.0" + :type string + :custom string + :label "Version" + :group (default name) + :documentation "The version number used when distributing files.") + (directory :type string + :initarg :directory + :documentation "Directory this project is associated with.") + (dirinode :documentation "The inode id for :directory.") + (file :type string + :initarg :file + :documentation "File name where this project is stored.") + (rootproject ; :initarg - no initarg, don't save this slot! + :initform nil + :type (or null ede-project-placeholder-child) + :documentation "Pointer to our root project.") + ) + "Placeholder object for projects not loaded into memory. +Projects placeholders will be stored in a user specific location +and querying them will cause the actual project to get loaded.") + +(defclass ede-project (ede-project-placeholder) + ((subproj :initform nil + :type list + :documentation "Sub projects controlled by this project. +For Automake based projects, each directory is treated as a project.") + (targets :initarg :targets + :type list + :custom (repeat (object :objectcreatefcn ede-new-target-custom)) + :label "Local Targets" + :group (targets) + :documentation "List of top level targets in this project.") + (locate-obj :type (or null ede-locate-base-child) + :documentation + "A locate object to use as a backup to `ede-expand-filename'.") + (tool-cache :initarg :tool-cache + :type list + :custom (repeat object) + :label "Tool: " + :group tools + :documentation "List of tool cache configurations in this project. +This allows any tool to create, manage, and persist project-specific settings.") + (mailinglist :initarg :mailinglist + :initform "" + :type string + :custom string + :label "Mailing List Address" + :group name + :documentation + "An email address where users might send email for help.") + (web-site-url :initarg :web-site-url + :initform "" + :type string + :custom string + :label "Web Site URL" + :group name + :documentation "URL to this projects web site. +This is a URL to be sent to a web site for documentation.") + (web-site-directory :initarg :web-site-directory + :initform "" + :custom string + :label "Web Page Directory" + :group name + :documentation + "A directory where web pages can be found by Emacs. +For remote locations use a path compatible with ange-ftp or EFS. +You can also use TRAMP for use with rcp & scp.") + (web-site-file :initarg :web-site-file + :initform "" + :custom string + :label "Web Page File" + :group name + :documentation + "A file which contains the home page for this project. +This file can be relative to slot `web-site-directory'. +This can be a local file, use ange-ftp, EFS, or TRAMP.") + (ftp-site :initarg :ftp-site + :initform "" + :type string + :custom string + :label "FTP site" + :group name + :documentation + "FTP site where this project's distribution can be found. +This FTP site should be in Emacs form, as needed by `ange-ftp', but can +also be of a form used by TRAMP for use with scp, or rcp.") + (ftp-upload-site :initarg :ftp-upload-site + :initform "" + :type string + :custom string + :label "FTP Upload site" + :group name + :documentation + "FTP Site to upload new distributions to. +This FTP site should be in Emacs form as needed by `ange-ftp'. +If this slot is nil, then use `ftp-site' instead.") + (configurations :initarg :configurations + :initform ("debug" "release") + :type list + :custom (repeat string) + :label "Configuration Options" + :group (settings) + :documentation "List of available configuration types. +Individual target/project types can form associations between a configuration, +and target specific elements such as build variables.") + (configuration-default :initarg :configuration-default + :initform "debug" + :custom string + :label "Current Configuration" + :group (settings) + :documentation "The default configuration.") + (local-variables :initarg :local-variables + :initform nil + :custom (repeat (cons (sexp :tag "Variable") + (sexp :tag "Value"))) + :label "Project Local Variables" + :group (settings) + :documentation "Project local variables") + (keybindings :allocation :class + :initform (("D" . ede-debug-target)) + :documentation "Keybindings specialized to this type of target." + :accessor ede-object-keybindings) + (menu :allocation :class + :initform + ( + [ "Update Version" ede-update-version ede-object ] + [ "Version Control Status" ede-vc-project-directory ede-object ] + [ "Edit Project Homepage" ede-edit-web-page + (and ede-object (oref (ede-toplevel) web-site-file)) ] + [ "Browse Project URL" ede-web-browse-home + (and ede-object + (not (string= "" (oref (ede-toplevel) web-site-url)))) ] + "--" + [ "Rescan Project Files" ede-rescan-toplevel t ] + [ "Edit Projectfile" ede-edit-file-target + (and ede-object + (or (listp ede-object) + (not (obj-of-class-p ede-object ede-project)))) ] + ) + :documentation "Menu specialized to this type of target." + :accessor ede-object-menu) + ) + "Top level EDE project specification. +All specific project types must derive from this project." + :method-invocation-order :depth-first) + +;;; 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 --git a/lisp/cedet/ede/autoconf-edit.el b/lisp/cedet/ede/autoconf-edit.el new file mode 100644 index 00000000000..a59512da3e0 --- /dev/null +++ b/lisp/cedet/ede/autoconf-edit.el @@ -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 <zappo@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; 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 --git a/lisp/cedet/ede/cpp-root.el b/lisp/cedet/ede/cpp-root.el new file mode 100644 index 00000000000..a922cc15782 --- /dev/null +++ b/lisp/cedet/ede/cpp-root.el @@ -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 <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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." +;; <write your code here, or return nil> +;; ) +;; +;; (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 --git a/lisp/cedet/ede/dired.el b/lisp/cedet/ede/dired.el new file mode 100644 index 00000000000..6be3750297c --- /dev/null +++ b/lisp/cedet/ede/dired.el @@ -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 <zappo@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; 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 --git a/lisp/cedet/ede/emacs.el b/lisp/cedet/ede/emacs.el new file mode 100644 index 00000000000..7f071708f3f --- /dev/null +++ b/lisp/cedet/ede/emacs.el @@ -0,0 +1,257 @@ +;;; ede/emacs.el --- Special project for Emacs + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/ede/files.el b/lisp/cedet/ede/files.el new file mode 100644 index 00000000000..148ebb382da --- /dev/null +++ b/lisp/cedet/ede/files.el @@ -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 <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/ede/linux.el b/lisp/cedet/ede/linux.el new file mode 100644 index 00000000000..e95dce6d1f5 --- /dev/null +++ b/lisp/cedet/ede/linux.el @@ -0,0 +1,237 @@ +;;; ede/linux.el --- Special project for Linux + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/ede/locate.el b/lisp/cedet/ede/locate.el new file mode 100644 index 00000000000..100618a86c6 --- /dev/null +++ b/lisp/cedet/ede/locate.el @@ -0,0 +1,328 @@ +;;; ede/locate.el --- Locate support + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 <foo.h>, and without knowing how to +;; read a Makefile, find it in <root>/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 --git a/lisp/cedet/ede/make.el b/lisp/cedet/ede/make.el new file mode 100644 index 00000000000..08598d08161 --- /dev/null +++ b/lisp/cedet/ede/make.el @@ -0,0 +1,110 @@ +;;; ede/make.el --- General information about "make" + +;;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/ede/makefile-edit.el b/lisp/cedet/ede/makefile-edit.el new file mode 100644 index 00000000000..7810657a3af --- /dev/null +++ b/lisp/cedet/ede/makefile-edit.el @@ -0,0 +1,129 @@ +;;; makefile-edit.el --- Makefile editing/scanning commands. + +;;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/ede/pconf.el b/lisp/cedet/ede/pconf.el new file mode 100644 index 00000000000..62adf076f10 --- /dev/null +++ b/lisp/cedet/ede/pconf.el @@ -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 <zappo@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; 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 --git a/lisp/cedet/ede/pmake.el b/lisp/cedet/ede/pmake.el new file mode 100644 index 00000000000..420ae77e4b4 --- /dev/null +++ b/lisp/cedet/ede/pmake.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Code generator for Makefiles. +;; +;; Here is how it should work: +;; 1) Collect information about the project and targets +;; 2) Insert header into the Makefile +;; 3) Insert basic variables (target/source) +;; 4) Conditional +;; a) Makefile +;; 1) Insert support variables (compiler variables, etc) +;; 2) Insert VERSION and DISTDIR +;; 3) Specify top build dir if necessary +;; 4) Specify compile/link commands (c, etc) +;; 5) Specify dependency files +;; 6) Specify all: target +;; 7) Include dependency files +;; 8) Insert commonized target specify rules +;; 9) Insert clean: and dist: rules +;; b) Automake file +;; 1) Insert distribution source variables for targets +;; 2) Insert user requested rules + +(require 'ede/proj) +(require 'ede/proj-obj) +(require 'ede/proj-comp) + +(declare-function ede-srecode-setup "ede/srecode") +(declare-function ede-srecode-insert "ede/srecode") + +;;; Code: +(defmethod ede-proj-makefile-create ((this ede-proj-project) mfilename) + "Create a Makefile for all Makefile targets in THIS. +MFILENAME is the makefile to generate." + (require 'ede/srecode) + (let ((mt nil) + (isdist (string= mfilename (ede-proj-dist-makefile this))) + (depth 0) + (orig-buffer nil) + (buff-to-kill nil) + ) + ;; Find out how deep this project is. + (let ((tmp this)) + (while (setq tmp (ede-parent-project tmp)) + (setq depth (1+ depth)))) + ;; Collect the targets that belong in a makefile. + (mapc + (lambda (obj) + (if (and (obj-of-class-p obj 'ede-proj-target-makefile) + (string= (oref obj makefile) mfilename)) + (setq mt (cons obj mt)))) + (oref this targets)) + ;; Fix the order so things compile in the right direction. + (setq mt (nreverse mt)) + ;; Add in the header part of the Makefile* + (save-excursion + (setq orig-buffer (get-file-buffer mfilename)) + (set-buffer (setq buff-to-kill (find-file-noselect mfilename))) + (goto-char (point-min)) + (if (and + (not (eobp)) + (not (looking-at "# Automatically Generated \\w+ by EDE."))) + (if (not (y-or-n-p (format "Really replace %s? " mfilename))) + (error "Not replacing Makefile")) + (message "Replace EDE Makefile")) + (erase-buffer) + (ede-srecode-setup) + ;; Insert a giant pile of stuff that is common between + ;; one of our Makefiles, and a Makefile.in + (ede-srecode-insert + "file:ede-empty" + "MAKETYPE" + (with-slots (makefile-type) this + (cond ((eq makefile-type 'Makefile) "make") + ((eq makefile-type 'Makefile.in) "autoconf") + ((eq makefile-type 'Makefile.am) "automake") + (t (error ":makefile-type in project invalid"))))) + + ;; Just this project's variables + (ede-proj-makefile-insert-variables this) + + ;; Space + (insert "\n") + + (cond + ((eq (oref this makefile-type) 'Makefile) + ;; Make sure the user has the right kind of make + (ede-make-check-version) + + (let* ((targ (if isdist (oref this targets) mt)) + (sp (oref this subproj)) + (df (apply 'append + (mapcar (lambda (tg) + (ede-proj-makefile-dependency-files tg)) + targ)))) + ;; Distribution variables + (ede-compiler-begin-unique + (mapc 'ede-proj-makefile-insert-variables targ)) + ;; Only add the distribution stuff in when depth != 0 + (let ((top (ede-toplevel this)) + (tmp this) + (subdir "")) + (insert "VERSION=" (oref top version) "\n" + "DISTDIR=$(top)" (oref top name) "-$(VERSION)") + (while (ede-parent-project tmp) + (setq subdir + (concat + "/" + (file-name-nondirectory + (directory-file-name + (file-name-directory (oref tmp file)))) + subdir) + tmp (ede-parent-project tmp))) + (insert subdir "\n")) + ;; Some built in variables for C code + (if df + (let ((tc depth)) + (insert "top_builddir = ") + (while (/= 0 tc) + (setq tc (1- tc)) + (insert "..") + (if (/= tc 0) (insert "/"))) + (insert "\n"))) + (insert "\n") + ;; Create a variable with all the dependency files to include + ;; These methods borrowed from automake. + (if (and (oref this automatic-dependencies) df) + (progn + (insert "DEP_FILES=" + (mapconcat (lambda (f) + (concat ".deps/" + (file-name-nondirectory + (file-name-sans-extension + f)) ".P")) + df " ")))) + ;; + ;; Insert ALL Rule + ;; + (insert "\n\nall:") + (mapc (lambda (c) + (if (and (slot-exists-p c 'partofall) (oref c partofall)) + ;; Only insert this rule if it is a part of ALL. + (insert " " (ede-proj-makefile-target-name c)))) + targ) + (mapc (lambda (c) + (insert " " (ede-name c)) + ) + sp) + (insert "\n\n") + ;; + ;; Add in the include files + ;; + (mapc (lambda (c) + (insert "include " c "\n\n")) + (oref this include-file)) + ;; Some C inference rules + ;; Dependency rules borrowed from automake. + ;; + ;; NOTE: This is GNU Make specific. + (if (and (oref this automatic-dependencies) df) + (insert "DEPS_MAGIC := $(shell mkdir .deps > /dev/null " + "2>&1 || :)\n" + "-include $(DEP_FILES)\n\n")) + ;; + ;; General makefile rules stored in the individual targets + ;; + (ede-compiler-begin-unique + (ede-proj-makefile-insert-rules this) + (mapc 'ede-proj-makefile-insert-rules targ)) + ;; + ;; phony targets for sub projects + ;; + (mapc 'ede-proj-makefile-insert-subproj-rules sp) + ;; + ;; Distribution rules such as CLEAN and DIST + ;; + (when isdist + (ede-proj-makefile-tags this mt) + (ede-proj-makefile-insert-dist-rules this))) + (save-buffer)) + ((eq (oref this makefile-type) 'Makefile.in) + (error "Makefile.in is not supported")) + ((eq (oref this makefile-type) 'Makefile.am) + (require 'ede/pconf) + ;; Distribution variables + (let ((targ (if isdist (oref this targets) mt))) + (ede-compiler-begin-unique + (mapc 'ede-proj-makefile-insert-automake-pre-variables targ)) + (ede-compiler-begin-unique + (mapc 'ede-proj-makefile-insert-source-variables targ)) + (ede-compiler-begin-unique + (mapc 'ede-proj-makefile-insert-automake-post-variables targ)) + (ede-compiler-begin-unique + (ede-proj-makefile-insert-user-rules this)) + (insert "\n# End of Makefile.am\n") + (save-buffer)) + ) + (t (error "Unknown makefile type when generating Makefile"))) + ;; Put the cursor in a nice place + (goto-char (point-min))) + ;; If we have an original buffer, then don't kill it. + (when (not orig-buffer) + (kill-buffer buff-to-kill)) + )) + +;;; VARIABLE insertion +;; +(defun ede-pmake-end-of-variable () + "Move to the end of the variable declaration under point." + (end-of-line) + (while (= (preceding-char) ?\\) + (forward-char 1) + (end-of-line)) + ) + +(defmacro ede-pmake-insert-variable-shared (varname &rest body) + "Add VARNAME into the current Makefile. +Execute BODY in a location where a value can be placed." + `(let ((addcr t) (v ,varname)) + (if (re-search-backward (concat "^" v "\\s-*=") nil t) + (progn + (ede-pmake-end-of-variable) + (if (< (current-column) 40) + (if (and (/= (preceding-char) ?=) + (/= (preceding-char) ? )) + (insert " ")) + (insert "\\\n ")) + (setq addcr nil)) + (insert v "=")) + ,@body + (if addcr (insert "\n")) + (goto-char (point-max)))) +(put 'ede-pmake-insert-variable-shared 'lisp-indent-function 1) + +;;; SOURCE VARIABLE NAME CONSTRUCTION + +(defsubst ede-pmake-varname (obj) + "Convert OBJ into a variable name name. +Change . to _ in the variable name." + (let ((name (oref obj name))) + (while (string-match "\\." name) + (setq name (replace-match "_" nil t name))) + name)) + +(defmethod ede-proj-makefile-sourcevar ((this ede-proj-target)) + "Return the variable name for THIS's sources." + (concat (ede-pmake-varname this) "_YOU_FOUND_A_BUG")) + +;;; DEPENDENCY FILE GENERATOR LISTS +;; +(defmethod ede-proj-makefile-dependency-files ((this ede-proj-target)) + "Return a list of source files to convert to dependencies. +Argument THIS is the target to get sources from." + nil) + +;;; GENERIC VARIABLES +;; +(defmethod ede-proj-makefile-configuration-variables ((this ede-proj-project) + configuration) + "Return a list of configuration variables from THIS. +Use CONFIGURATION as the current configuration to query." + (cdr (assoc configuration (oref this configuration-variables)))) + +(defmethod ede-proj-makefile-insert-variables-new ((this ede-proj-project)) + "Insert variables needed by target THIS. + +NOTE: Not yet in use! This is part of an SRecode conversion of + EDE that is in progress." +; (let ((conf-table (ede-proj-makefile-configuration-variables +; this (oref this configuration-default))) +; (conf-done nil)) +; +; (ede-srecode-insert-with-dictionary +; "declaration:ede-vars" +; +; ;; Insert all variables, and augment them with details from +; ;; the current configuration. +; (mapc (lambda (c) +; +; (let ((ldict (srecode-dictionary-add-section-dictionary +; dict "VARIABLE")) +; ) +; (srecode-dictionary-set-value ldict "NAME" (car c)) +; (if (assoc (car c) conf-table) +; (let ((vdict (srecode-dictionary-add-section-dictionary +; ldict "VALUE"))) +; (srecode-dictionary-set-value +; vdict "VAL" (cdr (assoc (car c) conf-table))) +; (setq conf-done (cons (car c) conf-done)))) +; (let ((vdict (srecode-dictionary-add-section-dictionary +; ldict "VALUE"))) +; (srecode-dictionary-set-value vdict "VAL" (cdr c)))) +; ) +; +; (oref this variables)) +; +; ;; Add in all variables from the configuration not allready covered. +; (mapc (lambda (c) +; +; (if (member (car c) conf-done) +; nil +; (let* ((ldict (srecode-dictionary-add-section-dictionary +; dict "VARIABLE")) +; (vdict (srecode-dictionary-add-section-dictionary +; ldict "VALUE")) +; ) +; (srecode-dictionary-set-value ldict "NAME" (car c)) +; (srecode-dictionary-set-value vdict "VAL" (cdr c)))) +; ) +; +; conf-table) +; + + ;; @TODO - finish off this function, and replace the below fcn + +; )) + ) + +(defmethod ede-proj-makefile-insert-variables ((this ede-proj-project)) + "Insert variables needed by target THIS." + (let ((conf-table (ede-proj-makefile-configuration-variables + this (oref this configuration-default))) + (conf-done nil)) + ;; Insert all variables, and augment them with details from + ;; the current configuration. + (mapc (lambda (c) + (insert (car c) "=") + (if (assoc (car c) conf-table) + (progn + (insert (cdr (assoc (car c) conf-table)) " ") + (setq conf-done (cons (car c) conf-done)))) + (insert (cdr c) "\n")) + (oref this variables)) + ;; Add in all variables from the configuration not allready covered. + (mapc (lambda (c) + (if (member (car c) conf-done) + nil + (insert (car c) "=" (cdr c) "\n"))) + conf-table)) + (let* ((top "") + (tmp this)) + (while (ede-parent-project tmp) + (setq tmp (ede-parent-project tmp) + top (concat "../" top))) + (insert "\ntop=" top)) + (insert "\nede_FILES=" (file-name-nondirectory (oref this file)) " " + (file-name-nondirectory (ede-proj-dist-makefile this)) "\n")) + +(defmethod ede-proj-makefile-insert-source-variables ((this ede-proj-target) + &optional + moresource) + "Insert the source variables needed by THIS. +Optional argument MORESOURCE is a list of additional sources to add to the +sources variable." + (let ((sv (ede-proj-makefile-sourcevar this))) + ;; This variable may be shared between targets + (ede-pmake-insert-variable-shared (cond ((listp sv) (car sv)) + (t sv)) + (insert (mapconcat (lambda (a) a) (oref this source) " ")) + (if moresource + (insert " \\\n " (mapconcat (lambda (a) a) moresource " ") ""))))) + +(defmethod ede-proj-makefile-insert-variables ((this ede-proj-target) &optional + moresource) + "Insert variables needed by target THIS. +Optional argument MORESOURCE is a list of additional sources to add to the +sources variable." + (ede-proj-makefile-insert-source-variables this moresource) + ) + +(defmethod ede-proj-makefile-configuration-variables ((this ede-proj-target-makefile) + configuration) + "Return a list of configuration variables from THIS. +Use CONFIGURATION as the current configuration to query." + (cdr (assoc configuration (oref this configuration-variables)))) + +(defmethod ede-proj-makefile-insert-variables ((this ede-proj-target-makefile) + &optional moresource) + "Insert variables needed by target THIS. +Optional argument MORESOURCE is a list of additional sources to add to the +sources variable." + (call-next-method) + (let* ((proj (ede-target-parent this)) + (conf-table (ede-proj-makefile-configuration-variables + this (oref proj configuration-default))) + (conf-done nil) + ) + ;; Add in all variables from the configuration not allready covered. + (mapc (lambda (c) + (if (member (car c) conf-done) + nil + (insert (car c) "=" (cdr c) "\n"))) + conf-table)) + (let ((comp (ede-proj-compilers this)) + (link (ede-proj-linkers this)) + (name (ede-proj-makefile-target-name this)) + (src (oref this source))) + (while comp + (ede-compiler-only-once (car comp) + (ede-proj-makefile-insert-object-variables (car comp) name src) + (ede-proj-makefile-insert-variables (car comp))) + (setq comp (cdr comp))) + (while link + (ede-linker-only-once (car link) + (ede-proj-makefile-insert-variables (car link))) + (setq link (cdr link))))) + +(defmethod ede-proj-makefile-insert-automake-pre-variables + ((this ede-proj-target)) + "Insert variables needed by target THIS in Makefile.am before SOURCES." + nil) + +(defmethod ede-proj-makefile-insert-automake-post-variables + ((this ede-proj-target)) + "Insert variables needed by target THIS in Makefile.am after SOURCES." + nil) + +;;; GARBAGE PATTERNS +;; +(defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-project)) + "Return a list of patterns that are considered garbage to THIS. +These are removed with make clean." + (let ((mc (ede-map-targets + this (lambda (c) (ede-proj-makefile-garbage-patterns c)))) + (uniq nil)) + (setq mc (sort (apply 'append mc) 'string<)) + ;; Filter out duplicates from the targets. + (while mc + (if (and (car uniq) (string= (car uniq) (car mc))) + nil + (setq uniq (cons (car mc) uniq))) + (setq mc (cdr mc))) + (nreverse uniq))) + +(defmethod ede-proj-makefile-garbage-patterns ((this ede-proj-target)) + "Return a list of patterns that are considered garbage to THIS. +These are removed with make clean." + ;; Get the the source object from THIS, and use the specified garbage. + (let ((src (ede-target-sourcecode this)) + (garb nil)) + (while src + (setq garb (append (oref (car src) garbagepattern) garb) + src (cdr src))) + garb)) + + +;;; RULES +;; +(defmethod ede-proj-makefile-insert-subproj-rules ((this ede-proj-project)) + "Insert a rule for the project THIS which should be a subproject." + (insert ".PHONY:" (ede-name this)) + (newline) + (insert (ede-name this) ":") + (newline) + (insert "\t$(MAKE) -C " (directory-file-name (ede-subproject-relative-path this))) + (newline) + (newline) + ) + +(defmethod ede-proj-makefile-insert-rules ((this ede-proj-project)) + "Insert rules needed by THIS target." + (mapc 'ede-proj-makefile-insert-rules (oref this inference-rules)) + ) + +(defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-project)) + "Insert any symbols that the DIST rule should depend on. +Argument THIS is the project that should insert stuff." + (mapc 'ede-proj-makefile-insert-dist-dependencies (oref this targets)) + ) + +(defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target)) + "Insert any symbols that the DIST rule should depend on. +Argument THIS is the target that should insert stuff." + nil) + +(defmethod ede-proj-makefile-insert-dist-filepatterns ((this ede-proj-target)) + "Insert any symbols that the DIST rule should depend on. +Argument THIS is the target that should insert stuff." + (ede-proj-makefile-insert-dist-dependencies this) + ) + +(defmethod ede-proj-makefile-insert-dist-rules ((this ede-proj-project)) + "Insert distribution rules for THIS in a Makefile, such as CLEAN and DIST." + (let ((junk (ede-proj-makefile-garbage-patterns this)) + tmp) + ;; Build CLEAN, DIST, TAG, and other rules here. + (if junk + (insert "\nclean:\n" + "\trm -f " + (mapconcat (lambda (c) c) junk " ") + "\n\n")) + ;; @TODO: ^^^ Clean should also recurse. ^^^ + + (insert ".PHONY: dist\n") + (insert "\ndist:") + (ede-proj-makefile-insert-dist-dependencies this) + (insert "\n") + (unless (or (ede-subproject-p this) + (oref this metasubproject)) + ;; Only delete if we are the toplevel project. + (insert "\trm -rf $(DISTDIR)\n")) + (insert "\tmkdir $(DISTDIR)\n") ;We may need a -p, but I think not. + (setq tmp (oref this targets)) + (insert "\tcp") + (while tmp + (let ((sv (ede-proj-makefile-sourcevar (car tmp)))) + (if (listp sv) + ;; Handle special case variables. + (cond ((eq (cdr sv) 'share) + ;; This variable may be shared between multiple targets. + (if (re-search-backward (concat "\\$(" (car sv) ")") + (save-excursion + (beginning-of-line) + (point)) + t) + ;; If its already in the dist target, then skip it. + nil + (setq sv (car sv)))) + (t (setq sv (car sv))))) + (if (stringp sv) + (insert " $(" sv ")")) + (ede-proj-makefile-insert-dist-filepatterns (car tmp)) + (setq tmp (cdr tmp)))) + (insert " $(ede_FILES) $(DISTDIR)\n") + + ;; Call our sub projects. + (ede-map-subprojects + this (lambda (sproj) + (let ((rp (directory-file-name (ede-subproject-relative-path sproj)))) + (insert "\t$(MAKE) -C " rp " $(MFLAGS) DISTDIR=$(DISTDIR)/" rp + " dist" + "\n")))) + + ;; Tar up the stuff. + (unless (or (ede-subproject-p this) + (oref this metasubproject)) + (insert "\ttar -cvzf $(DISTDIR).tar.gz $(DISTDIR)\n" + "\trm -rf $(DISTDIR)\n")) + + ;; Make sure the Makefile is ok. + (insert "\n" + (file-name-nondirectory (buffer-file-name)) ": " + (file-name-nondirectory (oref this file)) "\n" +;; "$(EMACS) -batch Project.ede -l ede -f ede-proj-regenerate" + "\t@echo Makefile is out of date! " + "It needs to be regenerated by EDE.\n" + "\t@echo If you have not modified Project.ede, you can" + " use 'touch' to update the Makefile time stamp.\n" + "\t@false\n\n" + "\n\n# End of Makefile\n"))) + +(defmethod ede-proj-makefile-insert-rules ((this ede-proj-target)) + "Insert rules needed by THIS target." + nil) + +(defmethod ede-proj-makefile-insert-rules ((this ede-proj-target-makefile)) + "Insert rules needed by THIS target." + (mapc 'ede-proj-makefile-insert-rules (oref this rules)) + (let ((c (ede-proj-compilers this))) + (when c + (mapc 'ede-proj-makefile-insert-rules c) + (if (oref this phony) + (insert ".PHONY: " (ede-proj-makefile-target-name this) "\n")) + (insert (ede-proj-makefile-target-name this) ": " + (ede-proj-makefile-dependencies this) "\n") + (ede-proj-makefile-insert-commands this) + ))) + +(defmethod ede-proj-makefile-insert-commands ((this ede-proj-target-makefile)) + "Insert the commands needed by target THIS. +For targets, insert the commands needed by the chosen compiler." + (mapc 'ede-proj-makefile-insert-commands (ede-proj-compilers this)) + (when (object-assoc t :uselinker (ede-proj-compilers this)) + (mapc 'ede-proj-makefile-insert-commands (ede-proj-linkers this)))) + + +(defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-project)) + "Insert user specified rules needed by THIS target. +This is different from `ede-proj-makefile-insert-rules' in that this +function won't create the building rules which are auto created with +automake." + (mapc 'ede-proj-makefile-insert-user-rules (oref this inference-rules))) + +(defmethod ede-proj-makefile-insert-user-rules ((this ede-proj-target)) + "Insert user specified rules needed by THIS target." + (mapc 'ede-proj-makefile-insert-rules (oref this rules))) + +(defmethod ede-proj-makefile-dependencies ((this ede-proj-target-makefile)) + "Return a string representing the dependencies for THIS. +Some compilers only use the first element in the dependencies, others +have a list of intermediates (object files), and others don't care. +This allows customization of how these elements appear." + (let* ((c (ede-proj-compilers this)) + (io (eval (cons 'or (mapcar 'ede-compiler-intermediate-objects-p c)))) + (out nil)) + (if io + (progn + (while c + (setq out + (concat out "$(" (ede-compiler-intermediate-object-variable + (car c) + (ede-proj-makefile-target-name this)) ")") + c (cdr c))) + out) + (let ((sv (ede-proj-makefile-sourcevar this)) + (aux (oref this auxsource))) + (setq out + (if (and (stringp sv) (not (string= sv ""))) + (concat "$(" sv ")") + "")) + (while aux + (setq out (concat out " " (car aux))) + (setq aux (cdr aux))) + out)))) + +;; Tags +(defmethod ede-proj-makefile-tags ((this ede-proj-project) targets) + "Insert into the current location rules to make recursive TAGS files. +Argument THIS is the project to create tags for. +Argument TARGETS are the targets we should depend on for TAGS." + (insert "tags: ") + (let ((tg targets)) + ;; Loop over all source variables and insert them + (while tg + (insert "$(" (ede-proj-makefile-sourcevar (car tg)) ") ") + (setq tg (cdr tg))) + (insert "\n") + (if targets + (insert "\tetags $^\n")) + ;; Now recurse into all subprojects + (setq tg (oref this subproj)) + (while tg + (insert "\t$(MAKE) -C " (ede-subproject-relative-path (car tg)) " $(MFLAGS) $@\n") + (setq tg (cdr tg))) + (insert "\n"))) + + +(provide 'ede/pmake) + +;;; ede/pmake.el ends here diff --git a/lisp/cedet/ede/proj-archive.el b/lisp/cedet/ede/proj-archive.el new file mode 100644 index 00000000000..b19fc3015df --- /dev/null +++ b/lisp/cedet/ede/proj-archive.el @@ -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 <zappo@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; 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 --git a/lisp/cedet/ede/proj-aux.el b/lisp/cedet/ede/proj-aux.el new file mode 100644 index 00000000000..3cb0b7c029d --- /dev/null +++ b/lisp/cedet/ede/proj-aux.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Handle 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 --git a/lisp/cedet/ede/proj-comp.el b/lisp/cedet/ede/proj-comp.el new file mode 100644 index 00000000000..4c94b18f8f6 --- /dev/null +++ b/lisp/cedet/ede/proj-comp.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This software handles the maintenance of compiler and rule definitions +;; for different object types. +;; +;; The `ede-compiler' class lets different types of project objects create +;; definitions of compilers that can be swapped in and out for compiling +;; source code. Users can also define new compiler types whenever they +;; some customized behavior. +;; +;; The `ede-makefile-rule' class lets users add customized rules into thier +;; objects, and also lets different compilers add chaining rules to their +;; behaviors. +;; +;; It is important that all new compiler types be registered once. That +;; way the chaining rules and variables are inserted into any given Makefile +;; only once. +;; +;; To insert many compiler elements, wrap them in `ede-compiler-begin-unique' +;; before calling their insert methods. +;; To write a method that inserts a variable or rule for a compiler +;; based object, wrap the body of your call in `ede-compiler-only-once' + +(require 'ede) ;source object +(require 'ede/autoconf-edit) + +;;; Types: +(defclass ede-compilation-program (eieio-instance-inheritor) + ((name :initarg :name + :type string + :custom string + :documentation "Name of this type of compiler.") + (variables :initarg :variables + :type list + :custom (repeat (cons (string :tag "Variable") + (string :tag "Value"))) + :documentation + "Variables needed in the Makefile for this compiler. +An assoc list where each element is (VARNAME . VALUE) where VARNAME +is a string, and VALUE is either a string, or a list of strings. +For example, GCC would define CC=gcc, and emacs would define EMACS=emacs.") + (sourcetype :initarg :sourcetype + :type list ;; of symbols + :documentation + "A list of `ede-sourcecode' objects this class will handle. +This is used to match target objects with the compilers and linkers +they can use, and which files this object is interested in." + :accessor ede-object-sourcecode) + (rules :initarg :rules + :initform nil + :type list + :custom (repeat (object :objecttype ede-makefile-rule)) + :documentation + "Auxiliary rules needed for this compiler to run. +For example, yacc/lex files need additional chain rules, or inferences.") + (commands :initarg :commands + :type list + :custom (repeat string) + :documentation + "The commands used to execute this compiler. +The object which uses this compiler will place these commands after +it's rule definition.") + (autoconf :initarg :autoconf + :initform nil + :type list + :custom (repeat string) + :documentation + "Autoconf function to call if this type of compiler is used. +When a project is in Automake mode, this defines the autoconf function to +call to initialize automake to use this compiler. +For example, there may be multiple C compilers, but they all probably +use the same autoconf form.") + (objectextention :initarg :objectextention + :type string + :documentation + "A string which is the extention used for object files. +For example, C code uses .o on unix, and Emacs Lisp uses .elc.") + ) + "A program used to compile or link a program via a Makefile. +Contains everything needed to output code into a Makefile, or autoconf +file.") + +(defclass ede-compiler (ede-compilation-program) + ((makedepends :initarg :makedepends + :initform nil + :type boolean + :documentation + "Non-nil if this compiler can make dependencies.") + (uselinker :initarg :uselinker + :initform nil + :type boolean + :documentation + "Non-nil if this compiler creates code that can be linked. +This requires that the containing target also define a list of available +linkers that can be used.") + ) + "Definition for a compiler. +Different types of objects will provide different compilers for +different situations.") + +(defclass ede-linker (ede-compilation-program) + () + "Contains information needed to link many generated object files together.") + +(defclass ede-makefile-rule () + ((target :initarg :target + :initform "" + :type string + :custom string + :documentation "The target pattern. +A pattern of \"%.o\" is used for inference rules, and would match object files. +A target of \"foo.o\" explicitly matches the file foo.o.") + (dependencies :initarg :dependencies + :initform "" + :type string + :custom string + :documentation "Dependencies on this target. +A pattern of \"%.o\" would match a file of the same prefix as the target +if that target is also an inference rule pattern. +A dependency of \"foo.c\" explicitly lists foo.c as a dependency. +A variable such as $(name_SOURCES) will list all the source files +belonging to the target name.") + (rules :initarg :rules + :initform nil + :type list + :custom (repeat string) + :documentation "Scripts to execute. +These scripst will be executed in sh (Unless the SHELL variable is overriden). +Do not prefix with TAB. +Each individual element of this list can be either a string, or +a lambda function. (The custom element does not yet express that.") + (phony :initarg :phony + :initform nil + :type boolean + :custom boolean + :documentation "Is this a phony rule? +Adds this rule to a .PHONY list.")) + "A single rule for building some target.") + +;;; Code: +(defvar ede-compiler-list nil + "The master list of all EDE compilers.") + +(defvar ede-linker-list nil + "The master list of all EDE compilers.") + +(defvar ede-current-build-list nil + "List of EDE compilers that have already inserted parts of themselves. +This is used when creating a Makefile to prevend duplicate variables and +rules from being created.") + +(defmethod initialize-instance :AFTER ((this ede-compiler) &rest fields) + "Make sure that all ede compiler objects are cached in +`ede-compiler-list'." + (add-to-list 'ede-compiler-list this)) + +(defmethod initialize-instance :AFTER ((this ede-linker) &rest fields) + "Make sure that all ede compiler objects are cached in +`ede-linker-list'." + (add-to-list 'ede-linker-list this)) + +(defmacro ede-compiler-begin-unique (&rest body) + "Execute BODY, making sure that `ede-current-build-list' is maintained. +This will prevent rules from creating duplicate variables or rules." + `(let ((ede-current-build-list nil)) + ,@body)) + +(defmacro ede-compiler-only-once (object &rest body) + "Using OBJECT, execute BODY only once per Makefile generation." + `(if (not (member ,object ede-current-build-list)) + (progn + (add-to-list 'ede-current-build-list ,object) + ,@body))) + +(defmacro ede-linker-begin-unique (&rest body) + "Execute BODY, making sure that `ede-current-build-list' is maintained. +This will prevent rules from creating duplicate variables or rules." + `(let ((ede-current-build-list nil)) + ,@body)) + +(defmacro ede-linker-only-once (object &rest body) + "Using OBJECT, execute BODY only once per Makefile generation." + `(if (not (member ,object ede-current-build-list)) + (progn + (add-to-list 'ede-current-build-list ,object) + ,@body))) + +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec ede-compiler-begin-unique def-body) + (def-edebug-spec ede-compiler-only-once (form def-body)) + (def-edebug-spec ede-linker-begin-unique def-body) + (def-edebug-spec ede-linker-only-once (form def-body)) + (def-edebug-spec ede-pmake-insert-variable-shared (form def-body)) + )) + +;;; Querys +(defun ede-proj-find-compiler (compilers sourcetype) + "Return a compiler from the list COMPILERS that will compile SOURCETYPE." + (while (and compilers + (not (member sourcetype (oref (car compilers) sourcetype)))) + (setq compilers (cdr compilers))) + (car-safe compilers)) + +(defun ede-proj-find-linker (linkers sourcetype) + "Return a compiler from the list LINKERS to be used with SOURCETYPE." + (while (and linkers + (slot-boundp (car linkers) 'sourcetype) + (not (member sourcetype (oref (car linkers) sourcetype)))) + (setq linkers (cdr linkers))) + (car-safe linkers)) + +;;; Methods: +(defmethod ede-proj-tweak-autoconf ((this ede-compilation-program)) + "Tweak the configure file (current buffer) to accomodate THIS." + (mapcar + (lambda (obj) + (cond ((stringp obj) + (autoconf-insert-new-macro obj)) + ((consp obj) + (autoconf-insert-new-macro (car obj) (cdr obj))) + (t (error "Autoconf directives must be a string, or cons cell"))) + ) + (oref this autoconf))) + +(defmethod ede-proj-flush-autoconf ((this ede-compilation-program)) + "Flush the configure file (current buffer) to accomodate THIS." + nil) + +(defmethod ede-proj-makefile-insert-variables ((this ede-compilation-program)) + "Insert variables needed by the compiler THIS." + (if (eieio-instance-inheritor-slot-boundp this 'variables) + (with-slots (variables) this + (mapcar + (lambda (var) + (insert (car var) "=") + (let ((cd (cdr var))) + (if (listp cd) + (mapc (lambda (c) (insert " " c)) cd) + (insert cd))) + (insert "\n")) + variables)))) + +(defmethod ede-compiler-intermediate-objects-p ((this ede-compiler)) + "Return non-nil if THIS has intermediate object files. +If this compiler creates code that can be linked together, +then the object files created by the compiler are considered intermediate." + (oref this uselinker)) + +(defmethod ede-compiler-intermediate-object-variable ((this ede-compiler) + targetname) + "Return a string based on THIS representing a make object variable. +TARGETNAME is the name of the target that these objects belong to." + (concat targetname "_OBJ")) + +(defmethod ede-proj-makefile-insert-object-variables ((this ede-compiler) + targetname sourcefiles) + "Insert an OBJ variable to specify object code to be generated for THIS. +The name of the target is TARGETNAME as a string. SOURCEFILES is the list of +files to be objectified. +Not all compilers do this." + (if (ede-compiler-intermediate-objects-p this) + (progn + (insert (ede-compiler-intermediate-object-variable this targetname) + "=") + (let ((src (oref this sourcetype))) + (mapc (lambda (s) + (let ((ts src)) + (while (and ts (not (ede-want-file-source-p + (symbol-value (car ts)) s))) + (setq ts (cdr ts))) + ;; Only insert the object if the given file is a major + ;; source-code type. + (if ts;; a match as a source file. + (insert " " (file-name-sans-extension s) + (oref this objectextention))))) + sourcefiles) + (insert "\n"))))) + +(defmethod ede-proj-makefile-insert-rules ((this ede-compilation-program)) + "Insert rules needed for THIS compiler object." + (ede-compiler-only-once this + (mapc 'ede-proj-makefile-insert-rules (oref this rules)))) + +(defmethod ede-proj-makefile-insert-rules ((this ede-makefile-rule)) + "Insert rules needed for THIS rule object." + (if (oref this phony) (insert ".PHONY: (oref this target)\n")) + (insert (oref this target) ": " (oref this dependencies) "\n\t" + (mapconcat (lambda (c) c) (oref this rules) "\n\t") + "\n\n")) + +(defmethod ede-proj-makefile-insert-commands ((this ede-compilation-program)) + "Insert the commands needed to use compiler THIS. +The object creating makefile rules must call this method for the +compiler it decides to use after inserting in the rule." + (when (slot-boundp this 'commands) + (with-slots (commands) this + (mapc + (lambda (obj) (insert "\t" + (cond ((stringp obj) + obj) + ((and (listp obj) + (eq (car obj) 'lambda)) + (funcall obj)) + (t + (format "%S" obj))) + "\n")) + commands)) + (insert "\n"))) + +;;; Some details about our new macro +;; +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec ede-compiler-begin-unique def-body))) +(put 'ede-compiler-begin-unique 'lisp-indent-function 0) +(put 'ede-compiler-only-once 'lisp-indent-function 1) +(put 'ede-linker-begin-unique 'lisp-indent-function 0) +(put 'ede-linker-only-once 'lisp-indent-function 1) + +(provide 'ede/proj-comp) + +;;; ede/proj-comp.el ends here diff --git a/lisp/cedet/ede/proj-elisp.el b/lisp/cedet/ede/proj-elisp.el new file mode 100644 index 00000000000..b2ec7124605 --- /dev/null +++ b/lisp/cedet/ede/proj-elisp.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Handle Emacs Lisp in an EDE Project file. + +(require 'ede/proj) +(require 'ede/pmake) +(require 'ede/pconf) + +(autoload 'semantic-ede-proj-target-grammar "semantic/ede-grammar") + +;;; Code: +(defclass ede-proj-target-elisp (ede-proj-target-makefile) + ((menu :initform nil) + (keybindings :initform nil) + (phony :initform t) + (sourcetype :initform (ede-source-emacs)) + (availablecompilers :initform (ede-emacs-compiler ede-xemacs-compiler)) + (aux-packages :initarg :aux-packages + :initform nil + :type list + :custom (repeat string) + :documentation "Additional packages needed. +There should only be one toplevel package per auxiliary tool needed. +These packages location is found, and added to the compile time +load path." + )) + "This target consists of a group of lisp files. +A lisp target may be one general program with many separate lisp files in it.") + +(defvar ede-source-emacs + (ede-sourcecode "ede-emacs-source" + :name "Emacs Lisp" + :sourcepattern "\\.el$" + :garbagepattern '("*.elc")) + "Emacs Lisp source code definition.") + +(defvar ede-emacs-compiler + (ede-compiler + "ede-emacs-compiler" + :name "emacs" + :variables '(("EMACS" . "emacs") + ("EMACSFLAGS" . "-batch --no-site-file")) + :commands + '("@echo \"(add-to-list 'load-path nil)\" > $@-compile-script" + "for loadpath in . ${LOADPATH}; do \\" + " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> $@-compile-script; \\" + "done;" + "@echo \"(setq debug-on-error t)\" >> $@-compile-script" + "\"$(EMACS)\" $(EMACSFLAGS) -l $@-compile-script -f batch-byte-compile $^" + ) + :autoconf '("AM_PATH_LISPDIR") + :sourcetype '(ede-source-emacs) +; :objectextention ".elc" + ) + "Compile Emacs Lisp programs.") + +(defvar ede-xemacs-compiler + (clone ede-emacs-compiler "ede-xemacs-compiler" + :name "xemacs" + :variables '(("EMACS" . "xemacs"))) + "Compile Emacs Lisp programs with XEmacs.") + +;;; Claiming files +(defmethod ede-buffer-mine ((this ede-proj-target-elisp) buffer) + "Return t if object THIS lays claim to the file in BUFFER. +Lays claim to all .elc files that match .el files in this target." + (if (string-match "\\.elc$" (buffer-file-name buffer)) + (let ((fname + (concat + (file-name-sans-extension (buffer-file-name buffer)) + ".el") + )) + ;; Is this in our list. + (member fname (oref this auxsource)) + ) + (call-next-method) ; The usual thing. + )) + +;;; Emacs Lisp Compiler +;;; Emacs Lisp Target +(defun ede-proj-elisp-packages-to-loadpath (packages) + "Convert a list of PACKAGES, to a list of load path." + (let ((paths nil) + (ldir nil)) + (while packages + (or (setq ldir (locate-library (car packages))) + (error "Cannot find package %s" (car packages))) + (let* ((fnd (file-name-directory ldir)) + (rel (file-relative-name fnd)) + (full nil) + ) + ;; Make sure the relative name isn't to far off + (when (string-match "^\\.\\./\\.\\./\\.\\./\\.\\." rel) + (setq full fnd)) + ;; Do the setup. + (setq paths (cons (or full rel) paths) + packages (cdr packages)))) + paths)) + +(defmethod project-compile-target ((obj ede-proj-target-elisp)) + "Compile all sources in a Lisp target OBJ. +Bonus: Return a cons cell: (COMPILED . UPTODATE)." + (let* ((proj (ede-target-parent obj)) + (dir (oref proj directory)) + (comp 0) + (utd 0)) + (mapc (lambda (src) + (let* ((fsrc (expand-file-name src dir)) + (elc (concat (file-name-sans-extension fsrc) ".elc")) + ) + (if (or (not (file-exists-p elc)) + (file-newer-than-file-p fsrc elc)) + (progn + (setq comp (1+ comp)) + (byte-compile-file fsrc)) + (setq utd (1+ utd))))) + (oref obj source)) + (message "All Emacs Lisp sources are up to date in %s" (object-name obj)) + (cons comp utd) + )) + +(defmethod ede-update-version-in-source ((this ede-proj-target-elisp) version) + "In a Lisp file, updated a version string for THIS to VERSION. +There are standards in Elisp files specifying how the version string +is found, such as a `-version' variable, or the standard header." + (if (and (slot-boundp this 'versionsource) + (oref this versionsource)) + (let ((vs (oref this versionsource)) + (match nil)) + (while vs + (save-excursion + (set-buffer (find-file-noselect + (ede-expand-filename this (car vs)))) + (goto-char (point-min)) + (let ((case-fold-search t)) + (if (re-search-forward "-version\\s-+\"\\([^\"]+\\)\"" nil t) + (progn + (setq match t) + (delete-region (match-beginning 1) + (match-end 1)) + (goto-char (match-beginning 1)) + (insert version))))) + (setq vs (cdr vs))) + (if (not match) (call-next-method))))) + + +;;; Makefile generation functions +;; +(defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-elisp)) + "Return the variable name for THIS's sources." + (cond ((ede-proj-automake-p) '("lisp_LISP" . share)) + (t (concat (ede-pmake-varname this) "_LISP")))) + +(defun ede-proj-makefile-insert-loadpath-items (items) + "Insert a sequence of ITEMS into the Makefile LOADPATH variable." + (when items + (ede-pmake-insert-variable-shared "LOADPATH" + (let ((begin (save-excursion (re-search-backward "\\s-*=")))) + (while items + (when (not (save-excursion + (re-search-backward + (concat "\\s-" (regexp-quote (car items)) "[ \n\t\\]") + begin t))) + (insert " " (car items))) + (setq items (cdr items))))) + )) + +(defmethod ede-proj-makefile-insert-variables :AFTER ((this ede-proj-target-elisp)) + "Insert variables needed by target THIS." + (let ((newitems (if (oref this aux-packages) + (ede-proj-elisp-packages-to-loadpath + (oref this aux-packages)))) + ) + (ede-proj-makefile-insert-loadpath-items newitems))) + +(defun ede-proj-elisp-add-path (path) + "Add path PATH into the file if it isn't already there." + (goto-char (point-min)) + (if (re-search-forward (concat "(cons \\\"" + (regexp-quote path)) + nil t) + nil;; We have it already + (if (re-search-forward "(cons nil" nil t) + (progn + ;; insert stuff here + (end-of-line) + (insert "\n" + " echo \"(setq load-path (cons \\\"" + path + "\\\" load-path))\" >> script") + ) + (error "Don't know how to update load path")))) + +(defmethod ede-proj-tweak-autoconf ((this ede-proj-target-elisp)) + "Tweak the configure file (current buffer) to accomodate THIS." + (call-next-method) + ;; Ok, now we have to tweak the autoconf provided `elisp-comp' program. + (let ((ec (ede-expand-filename this "elisp-comp" 'newfile))) + (if (or (not ec) (not (file-exists-p ec))) + (message "No elisp-comp file. There may be compile errors? Rerun a second time.") + (save-excursion + (if (file-symlink-p ec) + (progn + ;; Desymlinkafy + (rename-file ec (concat ec ".tmp")) + (copy-file (concat ec ".tmp") ec) + (delete-file (concat ec ".tmp")))) + (set-buffer (find-file-noselect ec t)) + (ede-proj-elisp-add-path "..") + (let ((paths (ede-proj-elisp-packages-to-loadpath + (oref this aux-packages)))) + ;; Add in the current list of paths + (while paths + (ede-proj-elisp-add-path (car paths)) + (setq paths (cdr paths)))) + (save-buffer)) ))) + +(defmethod ede-proj-flush-autoconf ((this ede-proj-target-elisp)) + "Flush the configure file (current buffer) to accomodate THIS." + ;; Remove crufty old paths from elisp-compile + (let ((ec (ede-expand-filename this "elisp-comp" 'newfile)) + ) + (if (and ec (file-exists-p ec)) + (save-excursion + (set-buffer (find-file-noselect ec t)) + (goto-char (point-min)) + (while (re-search-forward "(cons \\([^ ]+\\) load-path)" + nil t) + (let ((path (match-string 1))) + (if (string= path "nil") + nil + (delete-region (save-excursion (beginning-of-line) (point)) + (save-excursion (end-of-line) + (forward-char 1) + (point)))))))))) + +;;; +;; Autoload generators +;; +(defclass ede-proj-target-elisp-autoloads (ede-proj-target-elisp) + ((availablecompilers :initform (ede-emacs-cedet-autogen-compiler)) + (aux-packages :initform ("cedet-autogen")) + (phony :initform t) + (autoload-file :initarg :autoload-file + :initform "loaddefs.el" + :type string + :custom string + :documentation "The file that autoload definitions are placed in. +There should be one load defs file for a given package. The load defs are created +for all Emacs Lisp sources that exist in the directory of the created target.") + (autoload-dirs :initarg :autoload-dirs + :initform nil + :type list + :custom (repeat string) + :documentation "The directories to scan for autoload definitions. +If nil defaults to the current directory.") + ) + "Target that builds an autoload file. +Files do not need to be added to this target.") + + +;;; Claiming files +(defmethod ede-buffer-mine ((this ede-proj-target-elisp-autoloads) buffer) + "Return t if object THIS lays claim to the file in BUFFER. +Lays claim to all .elc files that match .el files in this target." + (if (string-match + (concat (regexp-quote (oref this autoload-file)) "$") + (buffer-file-name buffer)) + t + (call-next-method) ; The usual thing. + )) + +;; Compilers +(defvar ede-emacs-cedet-autogen-compiler + (ede-compiler + "ede-emacs-autogen-compiler" + :name "emacs" + :variables '(("EMACS" . "emacs")) + :commands + '("@echo \"(add-to-list 'load-path nil)\" > $@-compile-script" + "for loadpath in . ${LOADPATH}; do \\" + " echo \"(add-to-list 'load-path \\\"$$loadpath\\\")\" >> $@-compile-script; \\" + "done;" + "@echo \"(require 'cedet-autogen)\" >> $@-compile-script" + "\"$(EMACS)\" -batch --no-site-file -l $@-compile-script -f cedet-batch-update-autoloads $(LOADDEFS) $(LOADDIRS)" + ) + :sourcetype '(ede-source-emacs) + ) + "Build an autoloads file.") + +(defmethod ede-proj-compilers ((obj ede-proj-target-elisp-autoloads)) + "List of compilers being used by OBJ. +If the `compiler' slot is empty, get the car of the compilers list." + (let ((comp (oref obj compiler))) + (if comp + (if (listp comp) + (setq comp (mapcar 'symbol-value comp)) + (setq comp (list (symbol-value comp)))) + ;; Get the first element from our list of compilers. + (let ((avail (mapcar 'symbol-value (oref obj availablecompilers)))) + (setq comp (list (car avail))))) + comp)) + +(defmethod ede-proj-makefile-insert-source-variables ((this ede-proj-target-elisp-autoloads) + &optional + moresource) + "Insert the source variables needed by THIS. +Optional argument MORESOURCE is a list of additional sources to add to the +sources variable." + nil) + +(defmethod ede-proj-makefile-sourcevar ((this ede-proj-target-elisp-autoloads)) + "Return the variable name for THIS's sources." + nil) ; "LOADDEFS") + +(defmethod ede-proj-makefile-dependencies ((this ede-proj-target-elisp-autoloads)) + "Return a string representing the dependencies for THIS. +Always return an empty string for an autoloads generator." + "") + +(defmethod ede-proj-makefile-insert-variables :AFTER ((this ede-proj-target-elisp-autoloads)) + "Insert variables needed by target THIS." + (ede-pmake-insert-variable-shared "LOADDEFS" + (insert (oref this autoload-file))) + (ede-pmake-insert-variable-shared "LOADDIRS" + (insert (mapconcat 'identity + (or (oref this autoload-dirs) '(".")) + " "))) + ) + +(defmethod project-compile-target ((obj ede-proj-target-elisp-autoloads)) + "Create or update the autoload target." + (require 'cedet-autogen) + (let ((default-directory (ede-expand-filename obj "."))) + (apply 'cedet-update-autoloads + (oref obj autoload-file) + (oref obj autoload-dirs)) + )) + +(defmethod ede-update-version-in-source ((this ede-proj-target-elisp-autoloads) version) + "In a Lisp file, updated a version string for THIS to VERSION. +There are standards in Elisp files specifying how the version string +is found, such as a `-version' variable, or the standard header." + nil) + +(defmethod ede-proj-makefile-insert-dist-dependencies ((this ede-proj-target-elisp-autoloads)) + "Insert any symbols that the DIST rule should depend on. +Emacs Lisp autoload files ship the generated .el files. +Argument THIS is the target which needs to insert an info file." + ;; In some cases, this is ONLY the index file. That should generally + ;; be ok. + (insert " " (ede-proj-makefile-target-name this)) + ) + +(defmethod ede-proj-makefile-insert-dist-filepatterns ((this ede-proj-target-elisp-autoloads)) + "Insert any symbols that the DIST rule should distribute. +Emacs Lisp autoload files ship the generated .el files. +Argument THIS is the target which needs to insert an info file." + (insert " " (oref this autoload-file)) + ) + +(defmethod ede-proj-tweak-autoconf ((this ede-proj-target-elisp-autoloads)) + "Tweak the configure file (current buffer) to accomodate THIS." + (error "Autoloads not supported in autoconf yet.")) + +(defmethod ede-proj-flush-autoconf ((this ede-proj-target-elisp-autoloads)) + "Flush the configure file (current buffer) to accomodate THIS." + nil) + +(provide 'ede/proj-elisp) + +;;; ede/proj-elisp.el ends here diff --git a/lisp/cedet/ede/proj-info.el b/lisp/cedet/ede/proj-info.el new file mode 100644 index 00000000000..215f98e09e2 --- /dev/null +++ b/lisp/cedet/ede/proj-info.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Handle 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 --git a/lisp/cedet/ede/proj-misc.el b/lisp/cedet/ede/proj-misc.el new file mode 100644 index 00000000000..0674989e221 --- /dev/null +++ b/lisp/cedet/ede/proj-misc.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Handle 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 --git a/lisp/cedet/ede/proj-obj.el b/lisp/cedet/ede/proj-obj.el new file mode 100644 index 00000000000..a42646a5f31 --- /dev/null +++ b/lisp/cedet/ede/proj-obj.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/ede/proj-prog.el b/lisp/cedet/ede/proj-prog.el new file mode 100644 index 00000000000..929004209b2 --- /dev/null +++ b/lisp/cedet/ede/proj-prog.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Handle 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 --git a/lisp/cedet/ede/proj-scheme.el b/lisp/cedet/ede/proj-scheme.el new file mode 100644 index 00000000000..09d79fc22c0 --- /dev/null +++ b/lisp/cedet/ede/proj-scheme.el @@ -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 <zappo@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; 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 --git a/lisp/cedet/ede/proj-shared.el b/lisp/cedet/ede/proj-shared.el new file mode 100644 index 00000000000..45051032d9c --- /dev/null +++ b/lisp/cedet/ede/proj-shared.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Handle 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 --git a/lisp/cedet/ede/proj.el b/lisp/cedet/ede/proj.el new file mode 100644 index 00000000000..185af9cf389 --- /dev/null +++ b/lisp/cedet/ede/proj.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; EDE defines a method for managing a project. EDE-PROJ aims to be a +;; generic project file format based on the EIEIO object stream +;; methods. Changes in the project structure will require Makefile +;; rebuild. The targets provided in ede-proj can be augmented with +;; additional target types inherited directly from `ede-proj-target'. + +;; (eval-and-compile '(require 'ede)) +(require 'ede/proj-comp) +(require 'ede/make) + +(declare-function ede-proj-makefile-create "ede/pmake") +(declare-function ede-proj-configure-synchronize "ede/pconf") + +(autoload 'ede-proj-target-aux "ede/proj-aux" + "Target class for a group of lisp files." nil nil) +(autoload 'ede-proj-target-elisp "ede/proj-elisp" + "Target class for a group of lisp files." nil nil) +(autoload 'ede-proj-target-elisp-autoloads "ede/proj-elisp" + "Target class for generating autoload files." nil nil) +(autoload 'ede-proj-target-scheme "ede/proj-scheme" + "Target class for a group of lisp files." nil nil) +(autoload 'ede-proj-target-makefile-miscelaneous "ede/proj-misc" + "Target class for a group of miscelaneous w/ a special makefile." nil nil) +(autoload 'ede-proj-target-makefile-program "ede/proj-prog" + "Target class for building a program." nil nil) +(autoload 'ede-proj-target-makefile-archive "ede/proj-archive" + "Target class for building an archive of object code." nil nil) +(autoload 'ede-proj-target-makefile-shared-object "ede/proj-shared" + "Target class for building a shared object." nil nil) +(autoload 'ede-proj-target-makefile-info "ede/proj-info" + "Target class for info files." nil nil) + +;;; Class Definitions: +(defclass ede-proj-target (ede-target) + ((auxsource :initarg :auxsource + :initform nil + :type list + :custom (repeat (string :tag "File")) + :label "Auxiliary Source Files" + :group (default source) + :documentation "Auxilliary source files included in this target. +Each of these is considered equivalent to a source file, but it is not +distributed, and each should have a corresponding rule to build it.") + (dirty :initform nil + :type boolean + :documentation "Non-nil when generated files needs updating.") + (compiler :initarg :compiler + :initform nil + :type (or null symbol) + :custom (choice (const :tag "None" nil) + :slotofchoices availablecompilers) + :label "Compiler for building sources" + :group make + :documentation + "The compiler to be used to compile this object. +This should be a symbol, which contains the object defining the compiler. +This enables save/restore to do so by name, permitting the sharing +of these compiler resources, and global customization thereof.") + (linker :initarg :linker + :initform nil + :type (or null symbol) + :custom (choice (const :tag "None" nil) + :slotofchoices availablelinkers) + :label "Linker for combining intermediate object files." + :group make + :documentation + "The linker to be used to link compiled sources for this object. +This should be a symbol, which contains the object defining the linker. +This enables save/restore to do so by name, permitting the sharing +of these linker resources, and global customization thereof.") + ;; Class allocated slots + (phony :allocation :class + :initform nil + :type boolean + :documentation + "A phony target is one where the build target does not relate to a file. +Such targets are always built, but make knows how to deal with them..") + (availablecompilers :allocation :class + :initform nil + :type (or null list) + :documentation + "A list of `ede-compiler' objects. +These are the compilers the user can choose from when setting the +`compiler' slot.") + (availablelinkers :allocation :class + :initform nil + :type (or null list) + :documentation + "A list of `ede-linker' objects. +These are the linkers the user can choose from when setting the +`linker' slot.") + ) + "Abstract class for ede-proj targets.") + +(defclass ede-proj-target-makefile (ede-proj-target) + ((makefile :initarg :makefile + :initform "Makefile" + :type string + :custom string + :label "Parent Makefile" + :group make + :documentation "File name of generated Makefile.") + (partofall :initarg :partofall + :initform t + :type boolean + :custom boolean + :label "Part of `all:' target" + :group make + :documentation + "Non nil means the rule created is part of the all target. +Setting this to nil creates the rule to build this item, but does not +include it in the ALL`all:' rule.") + (configuration-variables + :initarg :configuration-variables + :initform nil + :type list + :custom (repeat (cons (string :tag "Configuration") + (repeat + (cons (string :tag "Name") + (string :tag "Value"))))) + :label "Environment Variables for configurations" + :group make + :documentation "Makefile variables appended to use in different configurations. +These variables are used in the makefile when a configuration becomes active. +Target variables are always renamed such as foo_CFLAGS, then included into +commands where the variable would usually appear.") + (rules :initarg :rules + :initform nil + :type list + :custom (repeat (object :objecttype ede-makefile-rule)) + :label "Additional Rules" + :group (make) + :documentation + "Arbitrary rules and dependencies needed to make this target. +It is safe to leave this blank.") + ) + "Abstract class for Makefile based targets.") + +(defvar ede-proj-target-alist + '(("program" . ede-proj-target-makefile-program) + ("archive" . ede-proj-target-makefile-archive) + ("sharedobject" . ede-proj-target-makefile-shared-object) + ("emacs lisp" . ede-proj-target-elisp) + ("emacs lisp autoloads" . ede-proj-target-elisp-autoloads) + ("info" . ede-proj-target-makefile-info) + ("auxiliary" . ede-proj-target-aux) + ("scheme" . ede-proj-target-scheme) + ("miscellaneous" . ede-proj-target-makefile-miscelaneous) + ) + "Alist of names to class types for available project target classes.") + +(defun ede-proj-register-target (name class) + "Register a new target class with NAME and class symbol CLASS. +This enables the creation of your target type." + (let ((a (assoc name ede-proj-target-alist))) + (if a + (setcdr a class) + (setq ede-proj-target-alist + (cons (cons name class) ede-proj-target-alist))))) + +(defclass ede-proj-project (ede-project) + ((makefile-type :initarg :makefile-type + :initform Makefile + :type symbol + :custom (choice (const Makefile) + ;(const Makefile.in) + (const Makefile.am) + ;(const cook) + ) + :documentation "The type of Makefile to generate. +Can be one of 'Makefile, 'Makefile.in, or 'Makefile.am. +If this value is NOT 'Makefile, then that overrides the :makefile slot +in targets.") + (variables :initarg :variables + :initform nil + :type list + :custom (repeat (cons (string :tag "Name") + (string :tag "Value"))) + :group (settings) + :documentation "Variables to set in this Makefile.") + (configuration-variables + :initarg :configuration-variables + :initform ("debug" (("DEBUG" . "1"))) + :type list + :custom (repeat (cons (string :tag "Configuration") + (repeat + (cons (string :tag "Name") + (string :tag "Value"))))) + :group (settings) + :documentation "Makefile variables to use in different configurations. +These variables are used in the makefile when a configuration becomes active.") + (inference-rules :initarg :inference-rules + :initform nil + :custom (repeat + (object :objecttype ede-makefile-rule)) + :documentation "Inference rules to add to the makefile.") + (include-file :initarg :include-file + :initform nil + :custom (repeat + (string :tag "Include File")) + :documentation "Additional files to include. +These files can contain additional rules, variables, and customizations.") + (automatic-dependencies + :initarg :automatic-dependencies + :initform t + :type boolean + :custom boolean + :group (default settings) + :documentation + "Non-nil to do implement automatic dependencies in the Makefile.") + (menu :initform + ( + [ "Regenerate Makefiles" ede-proj-regenerate t ] + [ "Upload Distribution" ede-upload-distribution t ] + ) + ) + (metasubproject + :initarg :metasubproject + :initform nil + :type boolean + :custom boolean + :group (default settings) + :documentation + "Non-nil if this is a metasubproject. +Usually, a subproject is determined by a parent project. If multiple top level +projects are grouped into a large project not maintained by EDE, then you need +to set this to non-nil. The only effect is that the `dist' rule will then avoid +making a tar file.") + ) + "The EDE-PROJ project definition class.") + +;;; Code: +(defun ede-proj-load (project &optional rootproj) + "Load a project file from PROJECT directory. +If optional ROOTPROJ is provided then ROOTPROJ is the root project +for the tree being read in. If ROOTPROJ is nil, then assume that +the PROJECT being read in is the root project." + (save-excursion + (let ((ret nil) + (subdirs (directory-files project nil "[^.].*" nil))) + (set-buffer (get-buffer-create " *tmp proj read*")) + (unwind-protect + (progn + (insert-file-contents (concat project "Project.ede") + nil nil nil t) + (goto-char (point-min)) + (setq ret (read (current-buffer))) + (if (not (eq (car ret) 'ede-proj-project)) + (error "Corrupt project file")) + (setq ret (eval ret)) + (oset ret file (concat project "Project.ede")) + (oset ret directory project) + (oset ret rootproject rootproj) + ) + (kill-buffer " *tmp proj read*")) + (while subdirs + (let ((sd (file-name-as-directory + (expand-file-name (car subdirs) project)))) + (if (and (file-directory-p sd) + (ede-directory-project-p sd)) + (oset ret subproj + (cons (ede-proj-load sd (or rootproj ret)) + (oref ret subproj)))) + (setq subdirs (cdr subdirs)))) + ret))) + +(defun ede-proj-save (&optional project) + "Write out object PROJECT into its file." + (save-excursion + (if (not project) (setq project (ede-current-project))) + (let ((b (set-buffer (get-buffer-create " *tmp proj write*"))) + (cfn (oref project file)) + (cdir (oref project directory))) + (unwind-protect + (save-excursion + (erase-buffer) + (let ((standard-output (current-buffer))) + (oset project file (file-name-nondirectory cfn)) + (slot-makeunbound project :directory) + (object-write project ";; EDE project file.")) + (write-file cfn nil) + ) + ;; Restore the :file on exit. + (oset project file cfn) + (oset project directory cdir) + (kill-buffer b))))) + +(defmethod ede-commit-local-variables ((proj ede-proj-project)) + "Commit change to local variables in PROJ." + (ede-proj-save proj)) + +(defmethod eieio-done-customizing ((proj ede-proj-project)) + "Call this when a user finishes customizing this object. +Argument PROJ is the project to save." + (call-next-method) + (ede-proj-save proj)) + +(defmethod eieio-done-customizing ((target ede-proj-target)) + "Call this when a user finishes customizing this object. +Argument TARGET is the project we are completing customization on." + (call-next-method) + (ede-proj-save (ede-current-project))) + +(defmethod ede-commit-project ((proj ede-proj-project)) + "Commit any change to PROJ to its file." + (ede-proj-save proj)) + +(defmethod ede-buffer-mine ((this ede-proj-project) buffer) + "Return t if object THIS lays claim to the file in BUFFER." + (let ((f (ede-convert-path this (buffer-file-name buffer)))) + (or (string= (file-name-nondirectory (oref this file)) f) + (string= (ede-proj-dist-makefile this) f) + (string-match "Makefile\\(\\.\\(in\\|am\\)\\)?$" f) + (string-match "config\\(ure\\.in\\|\\.stutus\\)?$" f) + ))) + +(defmethod ede-buffer-mine ((this ede-proj-target) buffer) + "Return t if object THIS lays claim to the file in BUFFER." + (or (call-next-method) + (ede-target-buffer-in-sourcelist this buffer (oref this auxsource)))) + + +;;; 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 --git a/lisp/cedet/ede/project-am.el b/lisp/cedet/ede/project-am.el new file mode 100644 index 00000000000..c7045dc69df --- /dev/null +++ b/lisp/cedet/ede/project-am.el @@ -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 <zappo@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; 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 --git a/lisp/cedet/ede/simple.el b/lisp/cedet/ede/simple.el new file mode 100644 index 00000000000..b36a942f3f2 --- /dev/null +++ b/lisp/cedet/ede/simple.el @@ -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 <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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: + <STORAGE ROOT>/<PROJ DIR AS FILE>/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 --git a/lisp/cedet/ede/source.el b/lisp/cedet/ede/source.el new file mode 100644 index 00000000000..ca566d0225c --- /dev/null +++ b/lisp/cedet/ede/source.el @@ -0,0 +1,170 @@ +;; ede/source.el --- EDE source code object + +;;; Copyright (C) 2000, 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; 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 --git a/lisp/cedet/ede/speedbar.el b/lisp/cedet/ede/speedbar.el new file mode 100644 index 00000000000..0a14c7ea45d --- /dev/null +++ b/lisp/cedet/ede/speedbar.el @@ -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 <zappo@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; 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 --git a/lisp/cedet/ede/srecode.el b/lisp/cedet/ede/srecode.el new file mode 100644 index 00000000000..c53fe99239f --- /dev/null +++ b/lisp/cedet/ede/srecode.el @@ -0,0 +1,106 @@ +;;; ede-srecode.el --- EDE utilities on top of SRecoder + +;; Copyright (C) 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/ede/system.el b/lisp/cedet/ede/system.el new file mode 100644 index 00000000000..db2b9a2c9a4 --- /dev/null +++ b/lisp/cedet/ede/system.el @@ -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 <zappo@gnu.org> +;; 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 <http://www.gnu.org/licenses/>. + +;;; 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 --git a/lisp/cedet/ede/util.el b/lisp/cedet/ede/util.el new file mode 100644 index 00000000000..efe0c0008f1 --- /dev/null +++ b/lisp/cedet/ede/util.el @@ -0,0 +1,106 @@ +;;; ede/util.el --- EDE utilities + +;;; Copyright (C) 2000, 2005 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic.el b/lisp/cedet/semantic.el new file mode 100644 index 00000000000..5e78513b0ad --- /dev/null +++ b/lisp/cedet/semantic.el @@ -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 <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; API for providing the semantic content of a buffer. +;; +;; The semantic API provides an interface to a series of different parser +;; implementations. Each parser outputs a parse tree in a similar format +;; designed to handle typical functional and object oriented languages. + +(require 'cedet) +(require 'semantic/tag) +(require 'semantic/lex) + +(defvar semantic-version "2.0pre7" + "Current version of Semantic.") + +(declare-function inversion-test "inversion") +(declare-function semanticdb-load-ebrowse-caches "semantic/db-ebrowse") + +(defun semantic-require-version (major minor &optional beta) + "Non-nil if this version of semantic does not satisfy a specific version. +Arguments can be: + + (MAJOR MINOR &optional BETA) + + Values MAJOR and MINOR must be integers. BETA can be an integer, or +excluded if a released version is required. + +It is assumed that if the current version is newer than that specified, +everything passes. Exceptions occur when known incompatibilities are +introduced." + (require 'inversion) + (inversion-test 'semantic + (concat major "." minor + (when beta (concat "beta" beta))))) + +(defgroup semantic nil + "Parser Generator and parser framework." + :group 'lisp) + +(defgroup semantic-faces nil + "Faces used for Semantic enabled tools." + :group 'semantic) + +(require 'semantic/fw) + +;;; Code: +;; + +;;; Variables and Configuration +;; +(defvar semantic--parse-table nil + "Variable that defines how to parse top level items in a buffer. +This variable is for internal use only, and its content depends on the +external parser used.") +(make-variable-buffer-local 'semantic--parse-table) +(semantic-varalias-obsolete 'semantic-toplevel-bovine-table + 'semantic--parse-table) + +(defvar semantic-symbol->name-assoc-list + '((type . "Types") + (variable . "Variables") + (function . "Functions") + (include . "Dependencies") + (package . "Provides")) + "Association between symbols returned, and a string. +The string is used to represent a group of objects of the given type. +It is sometimes useful for a language to use a different string +in place of the default, even though that language will still +return a symbol. For example, Java return's includes, but the +string can be replaced with `Imports'.") +(make-variable-buffer-local 'semantic-symbol->name-assoc-list) + +(defvar semantic-symbol->name-assoc-list-for-type-parts nil + "Like `semantic-symbol->name-assoc-list' for type parts. +Some tags that have children (see `semantic-tag-children-compatibility') +will want to define the names of classes of tags differently than at +the top level. For example, in C++, a Function may be called a +Method. In addition, there may be new types of tags that exist only +in classes, such as protection labels.") +(make-variable-buffer-local 'semantic-symbol->name-assoc-list-for-type-parts) + +(defvar semantic-case-fold nil + "Value for `case-fold-search' when parsing.") +(make-variable-buffer-local 'semantic-case-fold) + +(defvar semantic-expand-nonterminal nil + "Function to call for each nonterminal production. +Return a list of non-terminals derived from the first argument, or nil +if it does not need to be expanded. +Languages with compound definitions should use this function to expand +from one compound symbol into several. For example, in C the definition + int a, b; +is easily parsed into one tag. This function should take this +compound tag and turn it into two tags, one for A, and the other for B.") +(make-variable-buffer-local 'semantic-expand-nonterminal) + +(defvar semantic--buffer-cache nil + "A cache of the fully parsed buffer. +If no significant changes have been made (based on the state) then +this is returned instead of re-parsing the buffer. + + DO NOT USE THIS VARIABLE IN PROGRAMS. + +If you need a tag list, use `semantic-fetch-tags'. If you need the +cached values for some reason, chances are you can, add a hook to +`semantic-after-toplevel-cache-change-hook'.") +(make-variable-buffer-local 'semantic--buffer-cache) +(semantic-varalias-obsolete 'semantic-toplevel-bovine-cache + 'semantic--buffer-cache) + +(defvar semantic-unmatched-syntax-cache nil + "A cached copy of unmatched syntax tokens.") +(make-variable-buffer-local 'semantic-unmatched-syntax-cache) + +(defvar semantic-unmatched-syntax-cache-check nil + "Non nil if the unmatched syntax cache is out of date. +This is tracked with `semantic-change-function'.") +(make-variable-buffer-local 'semantic-unmatched-syntax-cache-check) + +(defvar semantic-edits-are-safe nil + "When non-nil, modifications do not require a reparse. +This prevents tags from being marked dirty, and it prevents top level +edits from causing a cache check. +Use this when writing programs that could cause a full reparse, but +will not change the tag structure, such as adding or updating +`top-level' comments.") + +(defvar semantic-unmatched-syntax-hook nil + "Hooks run when semantic detects syntax not matched in a grammar. +Each individual piece of syntax (such as a symbol or punctuation +character) is called with this hook when it doesn't match in the +grammar, and multiple unmatched syntax elements are not grouped +together. Each hook is called with one argument, which is a list of +syntax tokens created by the semantic lexer. Use the functions +`semantic-lex-token-start', `semantic-lex-token-end' and +`semantic-lex-token-text' to get information about these tokens. The +current buffer is the buffer these tokens are derived from.") + +(defvar semantic--before-fetch-tags-hook nil + "Hooks run before a buffer is parses for tags. +It is called before any request for tags is made via the function +`semantic-fetch-tags' by an application. +If any hook returns a nil value, the cached value is returned +immediately, even if it is empty.") +(semantic-varalias-obsolete 'semantic-before-toplevel-bovination-hook + 'semantic--before-fetch-tags-hook) + +(defvar semantic-after-toplevel-bovinate-hook nil + "Hooks run after a toplevel parse. +It is not run if the toplevel parse command is called, and buffer does +not need to be fully reparsed. +For language specific hooks, make sure you define this as a local hook. + +This hook should not be used any more. +Use `semantic-after-toplevel-cache-change-hook' instead.") +(make-obsolete-variable 'semantic-after-toplevel-bovinate-hook nil) + +(defvar semantic-after-toplevel-cache-change-hook nil + "Hooks run after the buffer tag list has changed. +This list will change when a buffer is reparsed, or when the tag list +in a buffer is cleared. It is *NOT* called if the current tag list is +partially reparsed. + +Hook functions must take one argument, which is the new list of tags +associated with this buffer. + +For language specific hooks, make sure you define this as a local hook.") + +(defvar semantic-before-toplevel-cache-flush-hook nil + "Hooks run before the toplevel tag cache is flushed. +For language specific hooks, make sure you define this as a local +hook. This hook is called before a corresponding +`semantic-after-toplevel-cache-change-hook' which is also called +during a flush when the cache is given a new value of nil.") + +(defcustom semantic-dump-parse nil + "When non-nil, dump parsing information." + :group 'semantic + :type 'boolean) + +(defvar semantic-parser-name "LL" + "Optional name of the parser used to parse input stream.") +(make-variable-buffer-local 'semantic-parser-name) + +(defvar semantic--completion-cache nil + "Internal variable used by `semantic-complete-symbol'.") +(make-variable-buffer-local 'semantic--completion-cache) + +;;; 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 --git a/lisp/cedet/semantic/analyze.el b/lisp/cedet/semantic/analyze.el new file mode 100644 index 00000000000..4948bba794e --- /dev/null +++ b/lisp/cedet/semantic/analyze.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic, as a tool, provides a nice list of searchable tags. +;; That information can provide some very accurate answers if the current +;; context of a position is known. +;; +;; Semantic-ctxt provides ways of analyzing, and manipulating the +;; semantic context of a language in code. +;; +;; This library provides routines for finding intelligent answers to +;; tough problems, such as if an argument to a function has the correct +;; return type, or all possible tags that fit in a given local context. +;; + +;;; Vocabulary: +;; +;; Here are some words used to describe different things in the analyzer: +;; +;; tag - A single entity +;; prefix - The beginning of a symbol, usually used to look up something +;; incomplete. +;; type - The name of a datatype in the langauge. +;; metatype - If a type is named in a declaration like: +;; struct moose somevariable; +;; that name "moose" can be turned into a concrete type. +;; tag sequence - In C code, a list of dereferences, such as: +;; this.that.theother(); +;; parent - For a datatype in an OO language, another datatype +;; inherited from. This excludes interfaces. +;; scope - A list of tags that can be dereferenced that cannot +;; be found from the global namespace. +;; scopetypes - A list of tags which are datatype that contain +;; the scope. The scopetypes need to have the scope extracted +;; in a way that honors the type of inheritance. +;; nest/nested - When one tag is contained entirely in another. +;; +;; context - A semantic datatype representing a point in a buffer. +;; +;; constriant - If a context specifies a specific datatype is needed, +;; that is a constraint. +;; constants - Some datatypes define elements of themselves as a +;; constant. These need to be returned as there would be no +;; other possible completions. + +(require 'semantic) +(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 --git a/lisp/cedet/semantic/analyze/complete.el b/lisp/cedet/semantic/analyze/complete.el new file mode 100644 index 00000000000..5d858e59949 --- /dev/null +++ b/lisp/cedet/semantic/analyze/complete.el @@ -0,0 +1,263 @@ +;;; semantic/analyze/complete.el --- Smart Completions + +;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Caclulate smart completions. +;; +;; Uses the analyzer context routine to determine the best possible +;; list of completions. +;; +;;; History: +;; +;; Code was moved here from semantic-analyze.el + +(require 'semantic/analyze) + +;; For semantic-find-* macros: +(eval-when-compile (require 'semantic/find)) + +;;; Code: + +;;; Helper Fcns +;; +;; +;;;###autoload +(define-overloadable-function semantic-analyze-type-constants (type) + "For the tag TYPE, return any constant symbols of TYPE. +Used as options when completing.") + +(defun semantic-analyze-type-constants-default (type) + "Do nothing with TYPE." + nil) + +(defun semantic-analyze-tags-of-class-list (tags classlist) + "Return the tags in TAGS that are of classes in CLASSLIST." + (let ((origc tags)) + ;; Accept only tags that are of the datatype specified by + ;; the desired classes. + (setq tags (apply 'nconc ;; All input lists are permutable. + (mapcar (lambda (class) + (semantic-find-tags-by-class class origc)) + classlist))) + tags)) + +;;; MAIN completion calculator +;; +;;;###autoload +(define-overloadable-function semantic-analyze-possible-completions (context) + "Return a list of semantic tags which are possible completions. +CONTEXT is either a position (such as point), or a precalculated +context. Passing in a context is useful if the caller also needs +to access parts of the analysis. +Completions run through the following filters: + * Elements currently in scope + * Constants currently in scope + * Elements match the :prefix in the CONTEXT. + * Type of the completion matches the type of the context. +Context type matching can identify the following: + * No specific type + * Assignment into a variable of some type. + * Argument to a function with type constraints. +When called interactively, displays the list of possible completions +in a buffer." + (interactive "d") + ;; In theory, we don't need the below since the context will + ;; do it for us. + ;;(semantic-refresh-tags-safe) + (with-syntax-table semantic-lex-syntax-table + (let* ((context (if (semantic-analyze-context-child-p context) + context + (semantic-analyze-current-context context))) + (ans (if (not context) + (error "Nothing to Complete.") + (:override)))) + ;; If interactive, display them. + (when (interactive-p) + (with-output-to-temp-buffer "*Possible Completions*" + (semantic-analyze-princ-sequence ans "" (current-buffer))) + (shrink-window-if-larger-than-buffer + (get-buffer-window "*Possible Completions*"))) + ans))) + +(defun semantic-analyze-possible-completions-default (context) + "Default method for producing smart completions. +Argument CONTEXT is an object specifying the locally derived context." + (let* ((a context) + (desired-type (semantic-analyze-type-constraint a)) + (desired-class (oref a prefixclass)) + (prefix (oref a prefix)) + (prefixtypes (oref a prefixtypes)) + (completetext nil) + (completetexttype nil) + (scope (oref a scope)) + (localvar (oref scope localvar)) + (c nil)) + + ;; Calculate what our prefix string is so that we can + ;; find all our matching text. + (setq completetext (car (reverse prefix))) + (if (semantic-tag-p completetext) + (setq completetext (semantic-tag-name completetext))) + + (if (and (not completetext) (not desired-type)) + (error "Nothing to complete")) + + (if (not completetext) (setq completetext "")) + + ;; This better be a reasonable type, or we should fry it. + ;; The prefixtypes should always be at least 1 less than + ;; the prefix since the type is never looked up for the last + ;; item when calculating a sequence. + (setq completetexttype (car (reverse prefixtypes))) + (when (or (not completetexttype) + (not (and (semantic-tag-p completetexttype) + (eq (semantic-tag-class completetexttype) 'type)))) + ;; What should I do here? I think this is an error condition. + (setq completetexttype nil) + ;; If we had something that was a completetexttype but it wasn't + ;; valid, then express our dismay! + (when (> (length prefix) 1) + (let* ((errprefix (car (cdr (reverse prefix))))) + (error "Cannot find types for `%s'" + (cond ((semantic-tag-p errprefix) + (semantic-format-tag-prototype errprefix)) + (t + (format "%S" errprefix))))) + )) + + ;; There are many places to get our completion stream for. + ;; Here we go. + (if completetexttype + + (setq c (semantic-find-tags-for-completion + completetext + (semantic-analyze-scoped-type-parts completetexttype scope) + )) + + ;; No type based on the completetext. This is a free-range + ;; var or function. We need to expand our search beyond this + ;; scope into semanticdb, etc. + (setq c (nconc + ;; Argument list and local variables + (semantic-find-tags-for-completion completetext localvar) + ;; The current scope + (semantic-find-tags-for-completion completetext (oref scope fullscope)) + ;; The world + (semantic-analyze-find-tags-by-prefix completetext)) + ) + ) + + (let ((origc c) + (dtname (semantic-tag-name desired-type))) + + ;; Reset c. + (setq c nil) + + ;; Loop over all the found matches, and catagorize them + ;; as being possible features. + (while origc + + (cond + ;; Strip operators + ((semantic-tag-get-attribute (car origc) :operator-flag) + nil + ) + + ;; If we are completing from within some prefix, + ;; then we want to exclude constructors and destructors + ((and completetexttype + (or (semantic-tag-get-attribute (car origc) :constructor-flag) + (semantic-tag-get-attribute (car origc) :destructor-flag))) + nil + ) + + ;; If there is a desired type, we need a pair of restrictions + (desired-type + + (cond + ;; Ok, we now have a completion list based on the text we found + ;; we want to complete on. Now filter that stream against the + ;; type we want to search for. + ((string= dtname (semantic-analyze-type-to-name (semantic-tag-type (car origc)))) + (setq c (cons (car origc) c)) + ) + + ;; Now anything that is a compound type which could contain + ;; additional things which are of the desired type + ((semantic-tag-type (car origc)) + (let ((att (semantic-analyze-tag-type (car origc) scope)) + ) + (if (and att (semantic-tag-type-members att)) + (setq c (cons (car origc) c)))) + ) + + ) ; cond + ); desired type + + ;; No desired type, no other restrictions. Just add. + (t + (setq c (cons (car origc) c))) + + ); cond + + (setq origc (cdr origc))) + + (when desired-type + ;; Some types, like the enum in C, have special constant values that + ;; we could complete with. Thus, if the target is an enum, we can + ;; find possible symbol values to fill in that value. + (let ((constants + (semantic-analyze-type-constants desired-type))) + (if constants + (progn + ;; Filter + (setq constants + (semantic-find-tags-for-completion + completetext constants)) + ;; Add to the list + (setq c (nconc c constants))) + ))) + ) + + (when desired-class + (setq c (semantic-analyze-tags-of-class-list c desired-class))) + + ;; Pull out trash. + ;; NOTE TO SELF: Is this too slow? + ;; OTHER NOTE: Do we not want to strip duplicates by name and + ;; only by position? When are duplicate by name but not by tag + ;; useful? + (setq c (semantic-unique-tag-table-by-name c)) + + ;; All done! + + c)) + +(provide 'semantic/analyze/complete) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/analyze/complete" +;; End: + +;;; semantic/analyze/complete.el ends here diff --git a/lisp/cedet/semantic/analyze/debug.el b/lisp/cedet/semantic/analyze/debug.el new file mode 100644 index 00000000000..e482f074b31 --- /dev/null +++ b/lisp/cedet/semantic/analyze/debug.el @@ -0,0 +1,624 @@ +;;; semantic/analyze/debug.el --- Debug the analyzer + +;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/analyze/fcn.el b/lisp/cedet/semantic/analyze/fcn.el new file mode 100644 index 00000000000..c86a79a226d --- /dev/null +++ b/lisp/cedet/semantic/analyze/fcn.el @@ -0,0 +1,337 @@ +;;; semantic/analyze/fcn.el --- Analyzer support functions. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Analyzer support functions. + +;;; Code: + +(require 'semantic) +(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 --git a/lisp/cedet/semantic/analyze/refs.el b/lisp/cedet/semantic/analyze/refs.el new file mode 100644 index 00000000000..8e2f2120d69 --- /dev/null +++ b/lisp/cedet/semantic/analyze/refs.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/bovine.el b/lisp/cedet/semantic/bovine.el new file mode 100644 index 00000000000..d11fc16e07c --- /dev/null +++ b/lisp/cedet/semantic/bovine.el @@ -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 <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantix 1.x uses an LL parser named the "bovinator". This parser +;; had several conveniences in it which made for parsing tags out of +;; languages with list characters easy. This parser lives on as one +;; of many available parsers for semantic the tool. +;; +;; This parser should be used when the language is simple, such as +;; makefiles or other data-declaritive langauges. + +;;; Code: +(require 'semantic) + +(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 --git a/lisp/cedet/semantic/bovine/c-by.el b/lisp/cedet/semantic/bovine/c-by.el new file mode 100644 index 00000000000..e6be8a6822e --- /dev/null +++ b/lisp/cedet/semantic/bovine/c-by.el @@ -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 <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file was generated from the grammar file semantic/bovine/c.by +;; in the CEDET repository. + +;;; Code: + +(require 'semantic/lex) +(eval-when-compile (require 'semantic/bovine)) + +(declare-function semantic-c-reconstitute-token "semantic/bovine/c") +(declare-function semantic-c-reconstitute-template "semantic/bovine/c") +(declare-function semantic-expand-c-tag "semantic/bovine/c") + +(defconst semantic-c-by--keyword-table + (semantic-lex-make-keyword-table + '(("extern" . EXTERN) + ("static" . STATIC) + ("const" . CONST) + ("volatile" . VOLATILE) + ("register" . REGISTER) + ("signed" . SIGNED) + ("unsigned" . UNSIGNED) + ("inline" . INLINE) + ("virtual" . VIRTUAL) + ("mutable" . MUTABLE) + ("struct" . STRUCT) + ("union" . UNION) + ("enum" . ENUM) + ("typedef" . TYPEDEF) + ("class" . CLASS) + ("typename" . TYPENAME) + ("namespace" . NAMESPACE) + ("using" . USING) + ("new" . NEW) + ("delete" . DELETE) + ("template" . TEMPLATE) + ("throw" . THROW) + ("reentrant" . REENTRANT) + ("try" . TRY) + ("catch" . CATCH) + ("operator" . OPERATOR) + ("public" . PUBLIC) + ("private" . PRIVATE) + ("protected" . PROTECTED) + ("friend" . FRIEND) + ("if" . IF) + ("else" . ELSE) + ("do" . DO) + ("while" . WHILE) + ("for" . FOR) + ("switch" . SWITCH) + ("case" . CASE) + ("default" . DEFAULT) + ("return" . RETURN) + ("break" . BREAK) + ("continue" . CONTINUE) + ("sizeof" . SIZEOF) + ("void" . VOID) + ("char" . CHAR) + ("wchar_t" . WCHAR) + ("short" . SHORT) + ("int" . INT) + ("long" . LONG) + ("float" . FLOAT) + ("double" . DOUBLE) + ("bool" . BOOL) + ("_P" . UNDERP) + ("__P" . UNDERUNDERP)) + '(("__P" summary "Common macro to eliminate prototype compatibility on some compilers") + ("_P" summary "Common macro to eliminate prototype compatibility on some compilers") + ("bool" summary "Primitive boolean type") + ("double" summary "Primitive floating-point type (double-precision 64-bit IEEE 754)") + ("float" summary "Primitive floating-point type (single-precision 32-bit IEEE 754)") + ("long" summary "Integral primitive type (-9223372036854775808 to 9223372036854775807)") + ("int" summary "Integral Primitive Type: (-2147483648 to 2147483647)") + ("short" summary "Integral Primitive Type: (-32768 to 32767)") + ("wchar_t" summary "Wide Character Type") + ("char" summary "Integral Character Type: (0 to 256)") + ("void" summary "Built in typeless type: void") + ("sizeof" summary "Compile time macro: sizeof(<type or variable>) // size in bytes") + ("continue" summary "Non-local continue within a loop (for, do/while): continue;") + ("break" summary "Non-local exit within a loop or switch (for, do/while, switch): break;") + ("return" summary "return <value>;") + ("default" summary "switch (<variable>) { case <constvalue>: code; ... default: code; }") + ("case" summary "switch (<variable>) { case <constvalue>: code; ... default: code; }") + ("switch" summary "switch (<variable>) { case <constvalue>: code; ... default: code; }") + ("for" summary "for(<init>; <condition>; <increment>) { code }") + ("while" summary "do { code } while (<condition>); or while (<condition>) { code };") + ("do" summary " do { code } while (<condition>);") + ("else" summary "if (<condition>) { code } [ else { code } ]") + ("if" summary "if (<condition>) { code } [ else { code } ]") + ("friend" summary "friend class <CLASSNAME>") + ("catch" summary "try { <body> } catch { <catch code> }") + ("try" summary "try { <body> } catch { <catch code> }") + ("reentrant" summary "<type> <methoddef> (<method args>) reentrant ...") + ("throw" summary "<type> <methoddef> (<method args>) throw (<exception>) ...") + ("template" summary "template <class TYPE ...> TYPE_OR_FUNCTION") + ("delete" summary "delete <object>;") + ("new" summary "new <classname>();") + ("using" summary "using <namespace>;") + ("namespace" summary "Namespace Declaration: namespace <name> { ... };") + ("typename" summary "typename is used to handle a qualified name as a typename;") + ("class" summary "Class Declaration: class <name>[:parents] { ... };") + ("typedef" summary "Arbitrary Type Declaration: typedef <typedeclaration> <name>;") + ("enum" summary "Enumeration Type Declaration: enum [name] { ... };") + ("union" summary "Union Type Declaration: union [name] { ... };") + ("struct" summary "Structure Type Declaration: struct [name] { ... };") + ("mutable" summary "Member Declaration Modifier: mutable <type> <name> ...") + ("virtual" summary "Method Modifier: virtual <type> <name>(...) ...") + ("inline" summary "Function Modifier: inline <return type> <name>(...) {...};") + ("unsigned" summary "Numeric Type Modifier: unsigned <numeric type> <name> ...") + ("signed" summary "Numeric Type Modifier: signed <numeric type> <name> ...") + ("register" summary "Declaration Modifier: register <type> <name> ...") + ("volatile" summary "Declaration Modifier: volatile <type> <name> ...") + ("const" summary "Declaration Modifier: const <type> <name> ...") + ("static" summary "Declaration Modifier: static <type> <name> ...") + ("extern" summary "Declaration Modifier: extern <type> <name> ..."))) + "Table of language keywords.") + +(defconst semantic-c-by--token-table + (semantic-lex-make-type-table + '(("semantic-list" + (BRACKETS . "\\[\\]") + (PARENS . "()") + (VOID_BLCK . "^(void)$") + (BRACE_BLCK . "^{") + (PAREN_BLCK . "^(") + (BRACK_BLCK . "\\[.*\\]$")) + ("close-paren" + (RBRACE . "}") + (RPAREN . ")")) + ("open-paren" + (LBRACE . "{") + (LPAREN . "(")) + ("symbol" + (RESTRICT . "\\<\\(__\\)?restrict\\>")) + ("number" + (ZERO . "^0$")) + ("string" + (CPP . "\"C\\+\\+\"") + (C . "\"C\"")) + ("punctuation" + (OR . "\\`[|]\\'") + (HAT . "\\`\\^\\'") + (MOD . "\\`[%]\\'") + (TILDE . "\\`[~]\\'") + (COMA . "\\`[,]\\'") + (GREATER . "\\`[>]\\'") + (LESS . "\\`[<]\\'") + (EQUAL . "\\`[=]\\'") + (BANG . "\\`[!]\\'") + (MINUS . "\\`[-]\\'") + (PLUS . "\\`[+]\\'") + (DIVIDE . "\\`[/]\\'") + (AMPERSAND . "\\`[&]\\'") + (STAR . "\\`[*]\\'") + (SEMICOLON . "\\`[;]\\'") + (COLON . "\\`[:]\\'") + (PERIOD . "\\`[.]\\'") + (HASH . "\\`[#]\\'"))) + 'nil) + "Table of lexical tokens.") + +(defconst semantic-c-by--parse-table + `( + (bovine-toplevel + (declaration) + ) ;; end bovine-toplevel + + (bovine-inner-scope + (codeblock) + ) ;; end bovine-inner-scope + + (declaration + (macro) + (type) + (define) + (var-or-fun) + (extern-c) + (template) + (using) + ) ;; end declaration + + (codeblock + (define) + (codeblock-var-or-fun) + (type) + (using) + ) ;; end codeblock + + (extern-c-contents + (open-paren + ,(semantic-lambda + (list nil)) + ) + (declaration) + (close-paren + ,(semantic-lambda + (list nil)) + ) + ) ;; end extern-c-contents + + (extern-c + (EXTERN + string + "\"C\"" + semantic-list + ,(semantic-lambda + (semantic-tag + "C" + 'extern :members + (semantic-parse-region + (car + (nth 2 vals)) + (cdr + (nth 2 vals)) + 'extern-c-contents + 1))) + ) + (EXTERN + string + "\"C\\+\\+\"" + semantic-list + ,(semantic-lambda + (semantic-tag + "C" + 'extern :members + (semantic-parse-region + (car + (nth 2 vals)) + (cdr + (nth 2 vals)) + 'extern-c-contents + 1))) + ) + (EXTERN + string + "\"C\"" + ,(semantic-lambda + (list nil)) + ) + (EXTERN + string + "\"C\\+\\+\"" + ,(semantic-lambda + (list nil)) + ) + ) ;; end extern-c + + (macro + (spp-macro-def + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) nil nil :constant-flag t)) + ) + (spp-system-include + ,(semantic-lambda + (semantic-tag-new-include + (nth 0 vals) t)) + ) + (spp-include + ,(semantic-lambda + (semantic-tag-new-include + (nth 0 vals) nil)) + ) + ) ;; end macro + + (define + (spp-macro-def + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) nil nil :constant-flag t)) + ) + (spp-macro-undef + ,(semantic-lambda + (list nil)) + ) + ) ;; end define + + (unionparts + (semantic-list + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'classsubparts + 1)) + ) + ) ;; end unionparts + + (opt-symbol + (symbol) + ( ;;EMPTY + ) + ) ;; end opt-symbol + + (classsubparts + (open-paren + "{" + ,(semantic-lambda + (list nil)) + ) + (close-paren + "}" + ,(semantic-lambda + (list nil)) + ) + (class-protection + opt-symbol + punctuation + "\\`[:]\\'" + ,(semantic-lambda + (semantic-tag + (car + (nth 0 vals)) + 'label)) + ) + (var-or-fun) + (FRIEND + func-decl + ,(semantic-lambda + (semantic-tag + (car + (nth 1 vals)) + 'friend)) + ) + (FRIEND + CLASS + symbol + ,(semantic-lambda + (semantic-tag + (nth 2 vals) + 'friend)) + ) + (type) + (define) + (template) + ( ;;EMPTY + ) + ) ;; end classsubparts + + (opt-class-parents + (punctuation + "\\`[:]\\'" + class-parents + opt-template-specifier + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-class-parents + + (one-class-parent + (opt-class-protection + opt-class-declmods + namespace-symbol + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + "class" nil nil :protection + (car + (nth 0 vals)))) + ) + (opt-class-declmods + opt-class-protection + namespace-symbol + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + "class" nil nil :protection + (car + (nth 1 vals)))) + ) + ) ;; end one-class-parent + + (class-parents + (one-class-parent + punctuation + "\\`[,]\\'" + class-parents + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 2 vals))) + ) + (one-class-parent + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end class-parents + + (opt-class-declmods + (class-declmods + opt-class-declmods + ,(semantic-lambda + (list nil)) + ) + ( ;;EMPTY + ) + ) ;; end opt-class-declmods + + (class-declmods + (VIRTUAL) + ) ;; end class-declmods + + (class-protection + (PUBLIC) + (PRIVATE) + (PROTECTED) + ) ;; end class-protection + + (opt-class-protection + (class-protection + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list + "unspecified")) + ) + ) ;; end opt-class-protection + + (namespaceparts + (semantic-list + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'namespacesubparts + 1)) + ) + ) ;; end namespaceparts + + (namespacesubparts + (open-paren + "{" + ,(semantic-lambda + (list nil)) + ) + (close-paren + "}" + ,(semantic-lambda + (list nil)) + ) + (type) + (var-or-fun) + (define) + (class-protection + punctuation + "\\`[:]\\'" + ,(semantic-lambda + (semantic-tag + (car + (nth 0 vals)) + 'label)) + ) + (template) + (using) + ( ;;EMPTY + ) + ) ;; end namespacesubparts + + (enumparts + (semantic-list + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'enumsubparts + 1)) + ) + ) ;; end enumparts + + (enumsubparts + (symbol + opt-assign + ,(semantic-lambda + (semantic-tag-new-variable + (nth 0 vals) + "int" + (car + (nth 1 vals)) :constant-flag t)) + ) + (open-paren + "{" + ,(semantic-lambda + (list nil)) + ) + (close-paren + "}" + ,(semantic-lambda + (list nil)) + ) + (punctuation + "\\`[,]\\'" + ,(semantic-lambda + (list nil)) + ) + ) ;; end enumsubparts + + (opt-name + (symbol) + ( ;;EMPTY + ,(semantic-lambda + (list + "")) + ) + ) ;; end opt-name + + (typesimple + (struct-or-class + opt-class + opt-name + opt-template-specifier + opt-class-parents + semantic-list + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (car + (nth 0 vals)) + (let + ( + (semantic-c-classname + (cons + (car + (nth 2 vals)) + (car + (nth 0 vals))))) + (semantic-parse-region + (car + (nth 5 vals)) + (cdr + (nth 5 vals)) + 'classsubparts + 1)) + (nth 4 vals) :template-specifier + (nth 3 vals) :parent + (car + (nth 1 vals)))) + ) + (struct-or-class + opt-class + opt-name + opt-template-specifier + opt-class-parents + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (car + (nth 0 vals)) nil + (nth 4 vals) :template-specifier + (nth 3 vals) :prototype t :parent + (car + (nth 1 vals)))) + ) + (UNION + opt-class + opt-name + unionparts + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (nth 0 vals) + (nth 3 vals) nil :parent + (car + (nth 1 vals)))) + ) + (ENUM + opt-class + opt-name + enumparts + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 2 vals)) + (nth 0 vals) + (nth 3 vals) nil :parent + (car + (nth 1 vals)))) + ) + (TYPEDEF + declmods + typeformbase + cv-declmods + typedef-symbol-list + ,(semantic-lambda + (semantic-tag-new-type + (nth 4 vals) + (nth 0 vals) nil + (list + (nth 2 vals)))) + ) + ) ;; end typesimple + + (typedef-symbol-list + (typedefname + punctuation + "\\`[,]\\'" + typedef-symbol-list + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 2 vals))) + ) + (typedefname + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end typedef-symbol-list + + (typedefname + (opt-stars + symbol + opt-bits + opt-array + ,(semantic-lambda + (list + (nth 0 vals) + (nth 1 vals))) + ) + ) ;; end typedefname + + (struct-or-class + (STRUCT) + (CLASS) + ) ;; end struct-or-class + + (type + (typesimple + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (nth 0 vals)) + ) + (NAMESPACE + symbol + namespaceparts + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) + (nth 2 vals) nil)) + ) + (NAMESPACE + namespaceparts + ,(semantic-lambda + (semantic-tag-new-type + "unnamed" + (nth 0 vals) + (nth 1 vals) nil)) + ) + (NAMESPACE + symbol + punctuation + "\\`[=]\\'" + typeformbase + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) + (list + (semantic-tag-new-type + (car + (nth 3 vals)) + (nth 0 vals) nil nil)) nil :kind + 'alias)) + ) + ) ;; end type + + (using + (USING + usingname + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (semantic-tag + (car + (nth 1 vals)) + 'using :type + (nth 1 vals))) + ) + ) ;; end using + + (usingname + (typeformbase + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 0 vals)) + "class" nil nil :prototype t)) + ) + (NAMESPACE + typeformbase + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 1 vals)) + "namespace" nil nil :prototype t)) + ) + ) ;; end usingname + + (template + (TEMPLATE + template-specifier + opt-friend + template-definition + ,(semantic-lambda + (semantic-c-reconstitute-template + (nth 3 vals) + (nth 1 vals))) + ) + ) ;; end template + + (opt-friend + (FRIEND) + ( ;;EMPTY + ) + ) ;; end opt-friend + + (opt-template-specifier + (template-specifier + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-template-specifier + + (template-specifier + (punctuation + "\\`[<]\\'" + template-specifier-types + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (nth 1 vals)) + ) + ) ;; end template-specifier + + (template-specifier-types + (template-var + template-specifier-type-list + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 1 vals))) + ) + ( ;;EMPTY + ) + ) ;; end template-specifier-types + + (template-specifier-type-list + (punctuation + "\\`[,]\\'" + template-specifier-types + ,(semantic-lambda + (nth 1 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end template-specifier-type-list + + (template-var + (template-type + opt-template-equal + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (cdr + (nth 0 vals)))) + ) + (string + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (number + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (opt-stars + opt-ref + namespace-symbol + ,(semantic-lambda + (nth 2 vals)) + ) + (semantic-list + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (SIZEOF + semantic-list + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ) ;; end template-var + + (opt-template-equal + (punctuation + "\\`[=]\\'" + symbol + punctuation + "\\`[<]\\'" + template-specifier-types + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (list + (nth 1 vals))) + ) + (punctuation + "\\`[=]\\'" + symbol + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-template-equal + + (template-type + (CLASS + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + "class" nil nil)) + ) + (STRUCT + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + "struct" nil nil)) + ) + (TYPENAME + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + "class" nil nil)) + ) + (declmods + typeformbase + cv-declmods + opt-stars + opt-ref + variablearg-opt-name + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 1 vals)) nil nil nil :constant-flag + (if + (member + "const" + (append + (nth 0 vals) + (nth 2 vals))) t nil) :typemodifiers + (delete + "const" + (append + (nth 0 vals) + (nth 2 vals))) :reference + (car + (nth 4 vals)) :pointer + (car + (nth 3 vals)))) + ) + ) ;; end template-type + + (template-definition + (type + ,(semantic-lambda + (nth 0 vals)) + ) + (var-or-fun + ,(semantic-lambda + (nth 0 vals)) + ) + ) ;; end template-definition + + (opt-stars + (punctuation + "\\`[*]\\'" + opt-starmod + opt-stars + ,(semantic-lambda + (list + (1+ + (car + (nth 2 vals))))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list + 0)) + ) + ) ;; end opt-stars + + (opt-starmod + (STARMOD + opt-starmod + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end opt-starmod + + (STARMOD + (CONST) + ) ;; end STARMOD + + (declmods + (DECLMOD + declmods + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 1 vals))) + ) + (DECLMOD + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end declmods + + (DECLMOD + (EXTERN) + (STATIC) + (CVDECLMOD) + (INLINE) + (REGISTER) + (FRIEND) + (TYPENAME) + (METADECLMOD) + (VIRTUAL) + ) ;; end DECLMOD + + (metadeclmod + (METADECLMOD + ,(semantic-lambda) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end metadeclmod + + (CVDECLMOD + (CONST) + (VOLATILE) + ) ;; end CVDECLMOD + + (cv-declmods + (CVDECLMOD + cv-declmods + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 1 vals))) + ) + (CVDECLMOD + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end cv-declmods + + (METADECLMOD + (VIRTUAL) + (MUTABLE) + ) ;; end METADECLMOD + + (opt-ref + (punctuation + "\\`[&]\\'" + ,(semantic-lambda + (list + 1)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list + 0)) + ) + ) ;; end opt-ref + + (typeformbase + (typesimple + ,(semantic-lambda + (nth 0 vals)) + ) + (STRUCT + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) nil nil)) + ) + (UNION + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) nil nil)) + ) + (ENUM + symbol + ,(semantic-lambda + (semantic-tag-new-type + (nth 1 vals) + (nth 0 vals) nil nil)) + ) + (builtintype + ,(semantic-lambda + (nth 0 vals)) + ) + (symbol + template-specifier + ,(semantic-lambda + (semantic-tag-new-type + (nth 0 vals) + "class" nil nil :template-specifier + (nth 1 vals))) + ) + (namespace-symbol-for-typeformbase + opt-template-specifier + ,(semantic-lambda + (semantic-tag-new-type + (car + (nth 0 vals)) + "class" nil nil :template-specifier + (nth 1 vals))) + ) + (symbol + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end typeformbase + + (signedmod + (UNSIGNED) + (SIGNED) + ) ;; end signedmod + + (builtintype-types + (VOID) + (CHAR) + (WCHAR) + (SHORT + INT + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (SHORT) + (INT) + (LONG + INT + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (FLOAT) + (DOUBLE) + (BOOL) + (LONG + DOUBLE + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (LONG + LONG + ,(semantic-lambda + (list + (concat + (nth 0 vals) + " " + (nth 1 vals)))) + ) + (LONG) + ) ;; end builtintype-types + + (builtintype + (signedmod + builtintype-types + ,(semantic-lambda + (list + (concat + (car + (nth 0 vals)) + " " + (car + (nth 1 vals))))) + ) + (builtintype-types + ,(semantic-lambda + (nth 0 vals)) + ) + (signedmod + ,(semantic-lambda + (list + (concat + (car + (nth 0 vals)) + " int"))) + ) + ) ;; end builtintype + + (codeblock-var-or-fun + (declmods + typeformbase + declmods + opt-ref + var-or-func-decl + ,(semantic-lambda + (semantic-c-reconstitute-token + (nth 4 vals) + (nth 0 vals) + (nth 1 vals))) + ) + ) ;; end codeblock-var-or-fun + + (var-or-fun + (codeblock-var-or-fun + ,(semantic-lambda + (nth 0 vals)) + ) + (declmods + var-or-func-decl + ,(semantic-lambda + (semantic-c-reconstitute-token + (nth 1 vals) + (nth 0 vals) nil)) + ) + ) ;; end var-or-fun + + (var-or-func-decl + (func-decl + ,(semantic-lambda + (nth 0 vals)) + ) + (var-decl + ,(semantic-lambda + (nth 0 vals)) + ) + ) ;; end var-or-func-decl + + (func-decl + (opt-stars + opt-class + opt-destructor + functionname + opt-template-specifier + opt-under-p + arg-list + opt-post-fcn-modifiers + opt-throw + opt-initializers + fun-or-proto-end + ,(semantic-lambda + (nth 3 vals) + (list + 'function + (nth 1 vals) + (nth 2 vals) + (nth 6 vals) + (nth 8 vals) + (nth 7 vals)) + (nth 0 vals) + (nth 10 vals) + (nth 4 vals)) + ) + (opt-stars + opt-class + opt-destructor + functionname + opt-template-specifier + opt-under-p + opt-post-fcn-modifiers + opt-throw + opt-initializers + fun-try-end + ,(semantic-lambda + (nth 3 vals) + (list + 'function + (nth 1 vals) + (nth 2 vals) nil + (nth 7 vals) + (nth 6 vals)) + (nth 0 vals) + (nth 9 vals) + (nth 4 vals)) + ) + ) ;; end func-decl + + (var-decl + (varnamelist + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (list + (nth 0 vals) + 'variable)) + ) + ) ;; end var-decl + + (opt-under-p + (UNDERP + ,(semantic-lambda + (list nil)) + ) + (UNDERUNDERP + ,(semantic-lambda + (list nil)) + ) + ( ;;EMPTY + ) + ) ;; end opt-under-p + + (opt-initializers + (punctuation + "\\`[:]\\'" + namespace-symbol + semantic-list + opt-initializers) + (punctuation + "\\`[,]\\'" + namespace-symbol + semantic-list + opt-initializers) + ( ;;EMPTY + ) + ) ;; end opt-initializers + + (opt-post-fcn-modifiers + (post-fcn-modifiers + opt-post-fcn-modifiers + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-post-fcn-modifiers + + (post-fcn-modifiers + (REENTRANT) + (CONST) + ) ;; end post-fcn-modifiers + + (opt-throw + (THROW + semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 1 vals)) + (cdr + (nth 1 vals)) + 'throw-exception-list)) + ) + ( ;;EMPTY + ) + ) ;; end opt-throw + + (throw-exception-list + (namespace-symbol + punctuation + "\\`[,]\\'" + throw-exception-list + ,(semantic-lambda + (cons + (car + (nth 0 vals)) + (nth 2 vals))) + ) + (namespace-symbol + close-paren + ")" + ,(semantic-lambda + (nth 0 vals)) + ) + (symbol + close-paren + ")" + ,(semantic-lambda + (list + (nth 0 vals))) + ) + (open-paren + "(" + throw-exception-list + ,(semantic-lambda + (nth 1 vals)) + ) + (close-paren + ")" + ,(semantic-lambda) + ) + ) ;; end throw-exception-list + + (opt-bits + (punctuation + "\\`[:]\\'" + number + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-bits + + (opt-array + (semantic-list + "\\[.*\\]$" + opt-array + ,(semantic-lambda + (list + (cons + 1 + (car + (nth 1 vals))))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-array + + (opt-assign + (punctuation + "\\`[=]\\'" + expression + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-assign + + (opt-restrict + (symbol + "\\<\\(__\\)?restrict\\>") + ( ;;EMPTY + ) + ) ;; end opt-restrict + + (varname + (opt-stars + opt-restrict + namespace-symbol + opt-bits + opt-array + opt-assign + ,(semantic-lambda + (nth 2 vals) + (nth 0 vals) + (nth 3 vals) + (nth 4 vals) + (nth 5 vals)) + ) + ) ;; end varname + + (variablearg + (declmods + typeformbase + cv-declmods + opt-ref + variablearg-opt-name + ,(semantic-lambda + (semantic-tag-new-variable + (list + (nth 4 vals)) + (nth 1 vals) nil :constant-flag + (if + (member + "const" + (append + (nth 0 vals) + (nth 2 vals))) t nil) :typemodifiers + (delete + "const" + (append + (nth 0 vals) + (nth 2 vals))) :reference + (car + (nth 3 vals)))) + ) + ) ;; end variablearg + + (variablearg-opt-name + (varname + ,(semantic-lambda + (nth 0 vals)) + ) + (opt-stars + ,(semantic-lambda + (list + "") + (nth 0 vals) + (list nil nil nil)) + ) + ) ;; end variablearg-opt-name + + (varnamelist + (opt-ref + varname + punctuation + "\\`[,]\\'" + varnamelist + ,(semantic-lambda + (cons + (nth 1 vals) + (nth 3 vals))) + ) + (opt-ref + varname + ,(semantic-lambda + (list + (nth 1 vals))) + ) + ) ;; end varnamelist + + (namespace-symbol + (symbol + opt-template-specifier + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + namespace-symbol + ,(semantic-lambda + (list + (concat + (nth 0 vals) + "::" + (car + (nth 4 vals))))) + ) + (symbol + opt-template-specifier + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end namespace-symbol + + (namespace-symbol-for-typeformbase + (symbol + opt-template-specifier + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + namespace-symbol-for-typeformbase + ,(semantic-lambda + (list + (concat + (nth 0 vals) + "::" + (car + (nth 4 vals))))) + ) + (symbol + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end namespace-symbol-for-typeformbase + + (namespace-opt-class + (symbol + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + namespace-opt-class + ,(semantic-lambda + (list + (concat + (nth 0 vals) + "::" + (car + (nth 3 vals))))) + ) + (symbol + opt-template-specifier + punctuation + "\\`[:]\\'" + punctuation + "\\`[:]\\'" + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end namespace-opt-class + + (opt-class + (namespace-opt-class + ,(semantic-lambda + (nth 0 vals)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-class + + (opt-destructor + (punctuation + "\\`[~]\\'" + ,(semantic-lambda + (list t)) + ) + ( ;;EMPTY + ,(semantic-lambda + (list nil)) + ) + ) ;; end opt-destructor + + (arg-list + (semantic-list + "^(" + knr-arguments + ,(semantic-lambda + (nth 1 vals)) + ) + (semantic-list + "^(" + ,(semantic-lambda + (semantic-parse-region + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'arg-sub-list + 1)) + ) + (semantic-list + "^(void)$" + ,(semantic-lambda) + ) + ) ;; end arg-list + + (knr-varnamelist + (varname + punctuation + "\\`[,]\\'" + knr-varnamelist + ,(semantic-lambda + (cons + (nth 0 vals) + (nth 2 vals))) + ) + (varname + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end knr-varnamelist + + (knr-one-variable-decl + (declmods + typeformbase + cv-declmods + knr-varnamelist + ,(semantic-lambda + (semantic-tag-new-variable + (nreverse + (nth 3 vals)) + (nth 1 vals) nil :constant-flag + (if + (member + "const" + (append + (nth 2 vals))) t nil) :typemodifiers + (delete + "const" + (nth 2 vals)))) + ) + ) ;; end knr-one-variable-decl + + (knr-arguments + (knr-one-variable-decl + punctuation + "\\`[;]\\'" + knr-arguments + ,(semantic-lambda + (append + (semantic-expand-c-tag + (nth 0 vals)) + (nth 2 vals))) + ) + (knr-one-variable-decl + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (semantic-expand-c-tag + (nth 0 vals))) + ) + ) ;; end knr-arguments + + (arg-sub-list + (variablearg + ,(semantic-lambda + (nth 0 vals)) + ) + (punctuation + "\\`[.]\\'" + punctuation + "\\`[.]\\'" + punctuation + "\\`[.]\\'" + close-paren + ")" + ,(semantic-lambda + (semantic-tag-new-variable + "..." + "vararg" nil)) + ) + (punctuation + "\\`[,]\\'" + ,(semantic-lambda + (list nil)) + ) + (open-paren + "(" + ,(semantic-lambda + (list nil)) + ) + (close-paren + ")" + ,(semantic-lambda + (list nil)) + ) + ) ;; end arg-sub-list + + (operatorsym + (punctuation + "\\`[<]\\'" + punctuation + "\\`[<]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "<<=")) + ) + (punctuation + "\\`[>]\\'" + punctuation + "\\`[>]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + ">>=")) + ) + (punctuation + "\\`[<]\\'" + punctuation + "\\`[<]\\'" + ,(semantic-lambda + (list + "<<")) + ) + (punctuation + "\\`[>]\\'" + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (list + ">>")) + ) + (punctuation + "\\`[=]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "==")) + ) + (punctuation + "\\`[<]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "<=")) + ) + (punctuation + "\\`[>]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + ">=")) + ) + (punctuation + "\\`[!]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "!=")) + ) + (punctuation + "\\`[+]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "+=")) + ) + (punctuation + "\\`[-]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "-=")) + ) + (punctuation + "\\`[*]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "*=")) + ) + (punctuation + "\\`[/]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "/=")) + ) + (punctuation + "\\`[%]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "%=")) + ) + (punctuation + "\\`[&]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "&=")) + ) + (punctuation + "\\`[|]\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "|=")) + ) + (punctuation + "\\`[-]\\'" + punctuation + "\\`[>]\\'" + punctuation + "\\`[*]\\'" + ,(semantic-lambda + (list + "->*")) + ) + (punctuation + "\\`[-]\\'" + punctuation + "\\`[>]\\'" + ,(semantic-lambda + (list + "->")) + ) + (semantic-list + "()" + ,(semantic-lambda + (list + "()")) + ) + (semantic-list + "\\[\\]" + ,(semantic-lambda + (list + "[]")) + ) + (punctuation + "\\`[<]\\'") + (punctuation + "\\`[>]\\'") + (punctuation + "\\`[*]\\'") + (punctuation + "\\`[+]\\'" + punctuation + "\\`[+]\\'" + ,(semantic-lambda + (list + "++")) + ) + (punctuation + "\\`[+]\\'") + (punctuation + "\\`[-]\\'" + punctuation + "\\`[-]\\'" + ,(semantic-lambda + (list + "--")) + ) + (punctuation + "\\`[-]\\'") + (punctuation + "\\`[&]\\'" + punctuation + "\\`[&]\\'" + ,(semantic-lambda + (list + "&&")) + ) + (punctuation + "\\`[&]\\'") + (punctuation + "\\`[|]\\'" + punctuation + "\\`[|]\\'" + ,(semantic-lambda + (list + "||")) + ) + (punctuation + "\\`[|]\\'") + (punctuation + "\\`[/]\\'") + (punctuation + "\\`[=]\\'") + (punctuation + "\\`[!]\\'") + (punctuation + "\\`[~]\\'") + (punctuation + "\\`[%]\\'") + (punctuation + "\\`[,]\\'") + (punctuation + "\\`\\^\\'" + punctuation + "\\`[=]\\'" + ,(semantic-lambda + (list + "^=")) + ) + (punctuation + "\\`\\^\\'") + ) ;; end operatorsym + + (functionname + (OPERATOR + operatorsym + ,(semantic-lambda + (nth 1 vals)) + ) + (semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'function-pointer)) + ) + (symbol + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end functionname + + (function-pointer + (open-paren + "(" + punctuation + "\\`[*]\\'" + symbol + close-paren + ")" + ,(semantic-lambda + (list + (concat + "*" + (nth 2 vals)))) + ) + ) ;; end function-pointer + + (fun-or-proto-end + (punctuation + "\\`[;]\\'" + ,(semantic-lambda + (list t)) + ) + (semantic-list + ,(semantic-lambda + (list nil)) + ) + (punctuation + "\\`[=]\\'" + number + "^0$" + punctuation + "\\`[;]\\'" + ,(semantic-lambda + (list ':pure-virtual-flag)) + ) + (fun-try-end + ,(semantic-lambda + (list nil)) + ) + ) ;; end fun-or-proto-end + + (fun-try-end + (TRY + opt-initializers + semantic-list + "^{" + fun-try-several-catches + ,(semantic-lambda + (list nil)) + ) + ) ;; end fun-try-end + + (fun-try-several-catches + (CATCH + semantic-list + "^(" + semantic-list + "^{" + fun-try-several-catches + ,(semantic-lambda) + ) + (CATCH + semantic-list + "^{" + fun-try-several-catches + ,(semantic-lambda) + ) + ( ;;EMPTY + ,(semantic-lambda) + ) + ) ;; end fun-try-several-catches + + (type-cast + (semantic-list + ,(lambda (vals start end) + (semantic-bovinate-from-nonterminal + (car + (nth 0 vals)) + (cdr + (nth 0 vals)) + 'type-cast-list)) + ) + ) ;; end type-cast + + (type-cast-list + (open-paren + typeformbase + close-paren) + ) ;; end type-cast-list + + (opt-stuff-after-symbol + (semantic-list + "^(") + (semantic-list + "\\[.*\\]$") + ( ;;EMPTY + ) + ) ;; end opt-stuff-after-symbol + + (multi-stage-dereference + (namespace-symbol + opt-stuff-after-symbol + punctuation + "\\`[.]\\'" + multi-stage-dereference) + (namespace-symbol + opt-stuff-after-symbol + punctuation + "\\`[-]\\'" + punctuation + "\\`[>]\\'" + multi-stage-dereference) + (namespace-symbol + opt-stuff-after-symbol) + ) ;; end multi-stage-dereference + + (string-seq + (string + string-seq + ,(semantic-lambda + (list + (concat + (nth 0 vals) + (car + (nth 1 vals))))) + ) + (string + ,(semantic-lambda + (list + (nth 0 vals))) + ) + ) ;; end string-seq + + (expr-start + (punctuation + "\\`[-]\\'") + (punctuation + "\\`[+]\\'") + (punctuation + "\\`[*]\\'") + (punctuation + "\\`[&]\\'") + ) ;; end expr-start + + (expression + (number + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (multi-stage-dereference + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (NEW + multi-stage-dereference + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (NEW + builtintype-types + semantic-list + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (namespace-symbol + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (string-seq + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (type-cast + expression + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (semantic-list + expression + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (semantic-list + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + (expr-start + expression + ,(semantic-lambda + (list + (identity start) + (identity end))) + ) + ) ;; end expression + ) + "Parser table.") + +(defun semantic-c-by--install-parser () + "Setup the Semantic Parser." + (setq semantic--parse-table semantic-c-by--parse-table + semantic-debug-parser-source "c.by" + semantic-debug-parser-class 'semantic-bovine-debug-parser + semantic-flex-keywords-obarray semantic-c-by--keyword-table + semantic-equivalent-major-modes '(c-mode c++-mode) + )) + +;;; Epilogue +;; + +(provide 'semantic/bovine/c-by) + +;;; semantic/bovine/c-by.el ends here diff --git a/lisp/cedet/semantic/bovine/c.el b/lisp/cedet/semantic/bovine/c.el new file mode 100644 index 00000000000..b9077a2ef0b --- /dev/null +++ b/lisp/cedet/semantic/bovine/c.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Support for the C/C++ bovine parser for Semantic. +;; +;; @todo - can I support c++-font-lock-extra-types ? + +(require 'semantic) +(require 'semantic/analyze) +(require 'semantic/bovine/gcc) +(require '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<Foo,Bar> it will return 'Foo,Bar'." + (when (car spec-list) + (let* ((endpart (semantic-c--template-name-1 (cdr spec-list))) + (separator (and endpart ","))) + (concat (semantic-tag-name (car spec-list)) separator endpart)))) + +(defun semantic-c--template-name (type spec-list) + "Return a template class name for TYPE based on SPEC-LIST. +For a type `ref' with a template specifier of (Foo Bar) it will +return 'ref<Foo,Bar>'." + (concat (semantic-tag-name type) + "<" (semantic-c--template-name-1 (cdr spec-list)) ">")) + +(defun semantic-c-dereference-template (type scope &optional type-declaration) + "Dereference any template specifieres in TYPE within SCOPE. +If TYPE is a template, return a TYPE copy with the templates types +instantiated as specified in TYPE-DECLARATION." + (when (semantic-tag-p type-declaration) + (let ((def-list (semantic-tag-get-attribute type :template)) + (spec-list (semantic-tag-get-attribute type-declaration :template-specifier))) + (when (and def-list spec-list) + (setq type (semantic-tag-deep-copy-one-tag + type + (lambda (tag) + (when (semantic-tag-of-class-p tag 'type) + (semantic-c--instantiate-template + tag def-list spec-list)) + tag) + )) + (semantic-tag-set-name type (semantic-c--template-name type spec-list)) + (semantic-tag-put-attribute type :template nil) + (semantic-tag-set-faux type)))) + (list type type-declaration)) + +;;; Patch here by "Raf" for instantiating templates. +(defun semantic-c-dereference-member-of (type scope &optional type-declaration) + "Dereference through the `->' operator of TYPE. +Uses the return type of the '->' operator if it is contained in TYPE. +SCOPE is the current local scope to perform searches in. +TYPE-DECLARATION is passed through." + (if semantic-c-member-of-autocast + (let ((operator (car (semantic-find-tags-by-name "->" (semantic-analyze-scoped-type-parts type))))) + (if operator + (list (semantic-tag-get-attribute operator :type) (semantic-tag-get-attribute operator :type)) + (list type type-declaration))) + (list type type-declaration))) + +;; David Engster: The following three functions deal with namespace +;; aliases and types which are member of a namespace through a using +;; statement. For examples, see the file semantic/tests/testusing.cpp, +;; tests 5 and following. + +(defun semantic-c-dereference-namespace (type scope &optional type-declaration) + "Dereference namespace which might hold an 'alias' for TYPE. +Such an alias can be created through 'using' statements in a +namespace declaration. This function checks the namespaces in +SCOPE for such statements." + (let ((scopetypes (oref scope scopetypes)) + typename currentns tmp usingname result namespaces) + (when (and (semantic-tag-p type-declaration) + (or (null type) (semantic-tag-prototype-p type))) + (setq typename (semantic-analyze-split-name (semantic-tag-name type-declaration))) + ;; If we already have that TYPE in SCOPE, we do nothing + (unless (semantic-deep-find-tags-by-name (or (car-safe typename) typename) scopetypes) + (if (stringp typename) + ;; The type isn't fully qualified, so we have to search in all namespaces in SCOPE. + (setq namespaces (semantic-find-tags-by-type "namespace" scopetypes)) + ;; This is a fully qualified name, so we only have to search one namespace. + (setq namespaces (semanticdb-typecache-find (car typename))) + ;; Make sure it's really a namespace. + (if (string= (semantic-tag-type namespaces) "namespace") + (setq namespaces (list namespaces)) + (setq namespaces nil))) + (setq result nil) + ;; Iterate over all the namespaces we have to check. + (while (and namespaces + (null result)) + (setq currentns (car namespaces)) + ;; Check if this is namespace is an alias and dereference it if necessary. + (setq result (semantic-c-dereference-namespace-alias type-declaration currentns)) + (unless result + ;; Otherwise, check if we can reach the type through 'using' statements. + (setq result + (semantic-c-check-type-namespace-using type-declaration currentns))) + (setq namespaces (cdr namespaces))))) + (if result + ;; we have found the original type + (list result result) + (list type type-declaration)))) + +(defun semantic-c-dereference-namespace-alias (type namespace) + "Dereference TYPE in NAMESPACE, given that NAMESPACE is an alias. +Checks if NAMESPACE is an alias and if so, returns a new type +with a fully qualified name in the original namespace. Returns +nil if NAMESPACE is not an alias." + (when (eq (semantic-tag-get-attribute namespace :kind) 'alias) + (let ((typename (semantic-analyze-split-name (semantic-tag-name type))) + ns nstype originaltype newtype) + ;; Make typename unqualified + (if (listp typename) + (setq typename (last typename)) + (setq typename (list typename))) + (when + (and + ;; Get original namespace and make sure TYPE exists there. + (setq ns (semantic-tag-name + (car (semantic-tag-get-attribute namespace :members)))) + (setq nstype (semanticdb-typecache-find ns)) + (setq originaltype (semantic-find-tags-by-name + (car typename) + (semantic-tag-get-attribute nstype :members)))) + ;; Construct new type with name in original namespace. + (setq ns (semantic-analyze-split-name ns)) + (setq newtype + (semantic-tag-clone + (car originaltype) + (semantic-analyze-unsplit-name + (if (listp ns) + (append ns typename) + (append (list ns) typename))))))))) + +;; This searches a type in a namespace, following through all using +;; statements. +(defun semantic-c-check-type-namespace-using (type namespace) + "Check if TYPE is accessible in NAMESPACE through a using statement. +Returns the original type from the namespace where it is defined, +or nil if it cannot be found." + (let (usings result usingname usingtype unqualifiedname members shortname tmp) + ;; Get all using statements from NAMESPACE. + (when (and (setq usings (semantic-tag-get-attribute namespace :members)) + (setq usings (semantic-find-tags-by-class 'using usings))) + ;; Get unqualified typename. + (when (listp (setq unqualifiedname (semantic-analyze-split-name + (semantic-tag-name type)))) + (setq unqualifiedname (car (last unqualifiedname)))) + ;; Iterate over all using statements in NAMESPACE. + (while (and usings + (null result)) + (setq usingname (semantic-analyze-split-name + (semantic-tag-name (car usings))) + usingtype (semantic-tag-type (semantic-tag-type (car usings)))) + (cond + ((or (string= usingtype "namespace") + (stringp usingname)) + ;; We are dealing with a 'using [namespace] NAMESPACE;' + ;; Search for TYPE in that namespace + (setq result + (semanticdb-typecache-find usingname)) + (if (and result + (setq members (semantic-tag-get-attribute result :members)) + (setq members (semantic-find-tags-by-name unqualifiedname members))) + ;; TYPE is member of that namespace, so we are finished + (setq result (car members)) + ;; otherwise recursively search in that namespace for an alias + (setq result (semantic-c-check-type-namespace-using type result)) + (when result + (setq result (semantic-tag-type result))))) + ((and (string= usingtype "class") + (listp usingname)) + ;; We are dealing with a 'using TYPE;' + (when (string= unqualifiedname (car (last usingname))) + ;; We have found the correct tag. + (setq result (semantic-tag-type (car usings)))))) + (setq usings (cdr usings)))) + result)) + + +(define-mode-local-override semantic-analyze-dereference-metatype + c-mode (type scope &optional type-declaration) + "Dereference TYPE as described in `semantic-analyze-dereference-metatype'. +Handle typedef, template instantiation, and '->' operator." + (let* ((dereferencer-list '(semantic-c-dereference-typedef + semantic-c-dereference-template + semantic-c-dereference-member-of + semantic-c-dereference-namespace)) + (dereferencer (pop dereferencer-list)) + (type-tuple) + (original-type type)) + (while dereferencer + (setq type-tuple (funcall dereferencer type scope type-declaration) + type (car type-tuple) + type-declaration (cadr type-tuple)) + (if (not (eq type original-type)) + ;; we found a new type so break the dereferencer loop now ! + ;; (we will be recalled with the new type expanded by + ;; semantic-analyze-dereference-metatype-stack). + (setq dereferencer nil) + ;; no new type found try the next dereferencer : + (setq dereferencer (pop dereferencer-list))))) + (list type type-declaration)) + +(define-mode-local-override semantic-analyze-type-constants c-mode (type) + "When TYPE is a tag for an enum, return it's parts. +These are constants which are of type TYPE." + (if (and (eq (semantic-tag-class type) 'type) + (string= (semantic-tag-type type) "enum")) + (semantic-tag-type-members type))) + +(define-mode-local-override semantic-analyze-split-name c-mode (name) + "Split up tag names on colon (:) boundaries." + (let ((ans (split-string name ":"))) + (if (= (length ans) 1) + name + (delete "" ans)))) + +(define-mode-local-override semantic-analyze-unsplit-name c-mode (namelist) + "Assemble the list of names NAMELIST into a namespace name." + (mapconcat 'identity namelist "::")) + +(define-mode-local-override semantic-ctxt-scoped-types c++-mode (&optional point) + "Return a list of tags of CLASS type based on POINT. +DO NOT return the list of tags encompassing point." + (when point (goto-char (point))) + (let ((tagsaroundpoint (semantic-find-tag-by-overlay)) + (tagreturn nil) + (tmp nil)) + ;; In C++, we want to find all the namespaces declared + ;; locally and add them to the list. + (setq tmp (semantic-find-tags-by-class 'type (current-buffer))) + (setq tmp (semantic-find-tags-by-type "namespace" tmp)) + (setq tmp (semantic-find-tags-by-name "unnamed" tmp)) + (setq tagreturn tmp) + ;; We should also find all "using" type statements and + ;; accept those entities in as well. + (setq tmp (semanticdb-find-tags-by-class 'using)) + (let ((idx 0) + (len (semanticdb-find-result-length tmp))) + (while (< idx len) + (setq tagreturn (cons (semantic-tag-type (car (semanticdb-find-result-nth tmp idx))) tagreturn)) + (setq idx (1+ idx))) + ) + ;; Use the encompased types around point to also look for using statements. + ;;(setq tagreturn (cons "bread_name" tagreturn)) + (while (cdr tagsaroundpoint) ; don't search the last one + (setq tmp (semantic-find-tags-by-class 'using (semantic-tag-components (car tagsaroundpoint)))) + (dolist (T tmp) + (setq tagreturn (cons (semantic-tag-type T) tagreturn)) + ) + (setq tagsaroundpoint (cdr tagsaroundpoint)) + ) + ;; If in a function... + (when (and (semantic-tag-of-class-p (car tagsaroundpoint) 'function) + ;; ...search for using statements in the local scope... + (setq tmp (semantic-find-tags-by-class + 'using + (semantic-get-local-variables)))) + ;; ... and add them. + (setq tagreturn + (append tagreturn + (mapcar 'semantic-tag-type tmp)))) + ;; Return the stuff + tagreturn + )) + +(define-mode-local-override semantic-get-local-variables c++-mode () + "Do what `semantic-get-local-variables' does, plus add `this' if needed." + (let* ((origvar (semantic-get-local-variables-default)) + (ct (semantic-current-tag)) + (p (semantic-tag-function-parent ct))) + ;; If we have a function parent, then that implies we can + (if (and p (semantic-tag-of-class-p ct 'function)) + ;; Append a new tag THIS into our space. + (cons (semantic-tag-new-variable "this" p nil) + origvar) + ;; No parent, just return the usual + origvar) + )) + +(define-mode-local-override semantic-idle-summary-current-symbol-info + c-mode () + "Handle the SPP keywords, then use the default mechanism." + (let* ((sym (car (semantic-ctxt-current-thing))) + (spp-sym (semantic-lex-spp-symbol sym))) + (if spp-sym + (let* ((txt (concat "Macro: " sym)) + (sv (symbol-value spp-sym)) + (arg (semantic-lex-spp-macro-with-args sv)) + ) + (when arg + (setq txt (concat txt (format "%S" arg))) + (setq sv (cdr sv))) + + ;; This is optional, and potentially fraught w/ errors. + (condition-case nil + (dolist (lt sv) + (setq txt (concat txt " " (semantic-lex-token-text lt)))) + (error (setq txt (concat txt " #error in summary fcn")))) + + txt) + (semantic-idle-summary-current-symbol-info-default)))) + +(defvar-mode-local c-mode semantic-orphaned-member-metaparent-type "struct" + "When lost memberes are found in the class hierarchy generator, use a struct.") + +(defvar-mode-local c-mode semantic-symbol->name-assoc-list + '((type . "Types") + (variable . "Variables") + (function . "Functions") + (include . "Includes") + ) + "List of tag classes, and strings to describe them.") + +(defvar-mode-local c-mode semantic-symbol->name-assoc-list-for-type-parts + '((type . "Types") + (variable . "Attributes") + (function . "Methods") + (label . "Labels") + ) + "List of tag classes in a datatype decl, and strings to describe them.") + +(defvar-mode-local c-mode imenu-create-index-function 'semantic-create-imenu-index + "Imenu index function for C.") + +(defvar-mode-local c-mode semantic-type-relation-separator-character + '("." "->" "::") + "Separator characters between something of a given type, and a field.") + +(defvar-mode-local c-mode semantic-command-separation-character ";" + "Commen separation character for C") + +(defvar-mode-local c-mode senator-step-at-tag-classes '(function variable) + "Tag classes where senator will stop at the end.") + +;;;###autoload +(defun semantic-default-c-setup () + "Set up a buffer for semantic parsing of the C language." + (semantic-c-by--install-parser) + (setq semantic-lex-syntax-modifications '((?> ".") + (?< ".") + ) + ) + + (setq semantic-lex-analyzer #'semantic-c-lexer) + (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t) + ) + +;;;###autoload +(defun semantic-c-add-preprocessor-symbol (sym replacement) + "Add a preprocessor symbol SYM with a REPLACEMENT value." + (interactive "sSymbol: \nsReplacement: ") + (let ((SA (assoc sym semantic-lex-c-preprocessor-symbol-map))) + (if SA + ;; Replace if there is one. + (setcdr SA replacement) + ;; Otherwise, append + (setq semantic-lex-c-preprocessor-symbol-map + (cons (cons sym replacement) + semantic-lex-c-preprocessor-symbol-map)))) + + (semantic-c-reset-preprocessor-symbol-map) + ) + +;;; SETUP QUERY +;; +(defun semantic-c-describe-environment () + "Describe the Semantic features of the current C environment." + (interactive) + (if (not (or (eq major-mode 'c-mode) (eq major-mode 'c++-mode))) + (error "Not useful to query C mode in %s mode" major-mode)) + (let ((gcc (when (boundp 'semantic-gcc-setup-data) + semantic-gcc-setup-data)) + ) + (semantic-fetch-tags) + + (with-output-to-temp-buffer "*Semantic C Environment*" + (when gcc + (princ "Calculated GCC Parameters:") + (dolist (P gcc) + (princ "\n ") + (princ (car P)) + (princ " = ") + (princ (cdr P)) + ) + ) + + (princ "\n\nInclude Path Summary:\n") + (when (and (boundp 'ede-object) ede-object) + (princ "\n This file's project include is handled by:\n") + (princ " ") + (princ (object-print ede-object)) + (princ "\n with the system path:\n") + (dolist (dir (ede-system-include-path ede-object)) + (princ " ") + (princ dir) + (princ "\n")) + ) + + (when semantic-dependency-include-path + (princ "\n This file's generic include path is:\n") + (dolist (dir semantic-dependency-include-path) + (princ " ") + (princ dir) + (princ "\n"))) + + (when semantic-dependency-system-include-path + (princ "\n This file's system include path is:\n") + (dolist (dir semantic-dependency-system-include-path) + (princ " ") + (princ dir) + (princ "\n"))) + + (princ "\n\nMacro Summary:\n") + (when semantic-lex-c-preprocessor-symbol-file + (princ "\n Your CPP table is primed from these files:\n") + (dolist (file semantic-lex-c-preprocessor-symbol-file) + (princ " ") + (princ file) + (princ "\n") + (princ " in table: ") + (princ (object-print (semanticdb-file-table-object file))) + (princ "\n") + )) + + (when semantic-lex-c-preprocessor-symbol-map-builtin + (princ "\n Built-in symbol map:\n") + (dolist (S semantic-lex-c-preprocessor-symbol-map-builtin) + (princ " ") + (princ (car S)) + (princ " = ") + (princ (cdr S)) + (princ "\n") + )) + + (when semantic-lex-c-preprocessor-symbol-map + (princ "\n User symbol map:\n") + (dolist (S semantic-lex-c-preprocessor-symbol-map) + (princ " ") + (princ (car S)) + (princ " = ") + (princ (cdr S)) + (princ "\n") + )) + + (princ "\n\n Use: M-x semantic-lex-spp-describe RET\n") + (princ "\n to see the complete macro table.\n") + + ))) + +(provide 'semantic/bovine/c) + +(semantic-c-reset-preprocessor-symbol-map) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/bovine/c" +;; End: + +;;; semantic/bovine/c.el ends here diff --git a/lisp/cedet/semantic/bovine/debug.el b/lisp/cedet/semantic/bovine/debug.el new file mode 100644 index 00000000000..cd54bf4ce07 --- /dev/null +++ b/lisp/cedet/semantic/bovine/debug.el @@ -0,0 +1,147 @@ +;;; semantic/bovine/debug.el --- Debugger support for bovinator + +;;; Copyright (C) 2003 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/bovine/el.el b/lisp/cedet/semantic/bovine/el.el new file mode 100644 index 00000000000..596e29228f9 --- /dev/null +++ b/lisp/cedet/semantic/bovine/el.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Use the Semantic Bovinator for 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 <de_bb@...> 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 --git a/lisp/cedet/semantic/bovine/gcc.el b/lisp/cedet/semantic/bovine/gcc.el new file mode 100644 index 00000000000..49c65366c2a --- /dev/null +++ b/lisp/cedet/semantic/bovine/gcc.el @@ -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 <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/bovine/make-by.el b/lisp/cedet/semantic/bovine/make-by.el new file mode 100644 index 00000000000..19e35d0682b --- /dev/null +++ b/lisp/cedet/semantic/bovine/make-by.el @@ -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 <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file was generated from the grammar file +;; semantic/bovine/make.by in the CEDET repository. + +;;; Code: + +(require 'semantic/lex) +(eval-when-compile (require 'semantic/bovine)) + + +;;; 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 --git a/lisp/cedet/semantic/bovine/make.el b/lisp/cedet/semantic/bovine/make.el new file mode 100644 index 00000000000..9f3edcfbe9b --- /dev/null +++ b/lisp/cedet/semantic/bovine/make.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Use the Semantic Bovinator to parse Makefiles. +;; Concocted as an experiment for nonstandard languages. + +(require 'make-mode) + +(require 'semantic) +(require 'semantic/bovine/make-by) +(require 'semantic/analyze) +(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 --git a/lisp/cedet/semantic/bovine/scm-by.el b/lisp/cedet/semantic/bovine/scm-by.el new file mode 100644 index 00000000000..82a8ae6ffa3 --- /dev/null +++ b/lisp/cedet/semantic/bovine/scm-by.el @@ -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 <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file was generated from the grammar file +;; semantic/bovine/scm.by in the CEDET repository. + +;;; Code: + +(require 'semantic/lex) + +(eval-when-compile (require 'semantic/bovine)) + +;;; 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 --git a/lisp/cedet/semantic/bovine/scm.el b/lisp/cedet/semantic/bovine/scm.el new file mode 100644 index 00000000000..82a7dde039b --- /dev/null +++ b/lisp/cedet/semantic/bovine/scm.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Use the Semantic Bovinator for Scheme (guile) + +(require 'semantic) +(require 'semantic/bovine/scm-by) +(require 'semantic/format) +(require 'semantic/dep) + +;;; Code: + +(defcustom-mode-local-semantic-dependency-system-include-path + scheme-mode semantic-default-scheme-path + '("/usr/share/guile/") + "Default set of include paths for scheme (guile) code. +This should probably do some sort of search to see what is +actually on the local machine.") + +(define-mode-local-override semantic-format-tag-prototype scheme-mode (tag) + "Return a prototype for the Emacs Lisp nonterminal TAG." + (let* ((tok (semantic-tag-class tag)) + (args (semantic-tag-components tag)) + ) + (if (eq tok 'function) + (concat (semantic-tag-name tag) " (" + (mapconcat (lambda (a) a) args " ") + ")") + (semantic-format-tag-prototype-default tag)))) + +(define-mode-local-override semantic-documentation-for-tag scheme-mode (tag &optional nosnarf) + "Return the documentation string for TAG. +Optional argument NOSNARF is ignored." + (let ((d (semantic-tag-docstring tag))) + (if (and d (> (length d) 0) (= (aref d 0) ?*)) + (substring d 1) + d))) + +(define-mode-local-override semantic-insert-foreign-tag scheme-mode (tag tagfile) + "Insert TAG from TAGFILE at point. +Attempts a simple prototype for calling or using TAG." + (cond ((eq (semantic-tag-class tag) 'function) + (insert "(" (semantic-tag-name tag) " )") + (forward-char -1)) + (t + (insert (semantic-tag-name tag))))) + +;; Note: Analyzer from Henry S. Thompson +(define-lex-regex-analyzer semantic-lex-scheme-symbol + "Detect and create symbol and keyword tokens." + "\\(\\sw\\([:]\\|\\sw\\|\\s_\\)+\\)" + ;; (message (format "symbol: %s" (match-string 0))) + (semantic-lex-push-token + (semantic-lex-token + (or (semantic-lex-keyword-p (match-string 0)) 'symbol) + (match-beginning 0) (match-end 0)))) + + +(define-lex semantic-scheme-lexer + "A simple lexical analyzer that handles simple buffers. +This lexer ignores comments and whitespace, and will return +syntax as specified by the syntax table." + semantic-lex-ignore-whitespace + semantic-lex-ignore-newline + semantic-lex-scheme-symbol + semantic-lex-charquote + semantic-lex-paren-or-list + semantic-lex-close-paren + semantic-lex-string + semantic-lex-ignore-comments + semantic-lex-punctuation + semantic-lex-number + semantic-lex-default-action) + +;;;###autoload +(defun semantic-default-scheme-setup () + "Setup hook function for Emacs Lisp files and Semantic." + (semantic-scm-by--install-parser) + (setq semantic-symbol->name-assoc-list '( (variable . "Variables") + ;;(type . "Types") + (function . "Functions") + (include . "Loads") + (package . "DefineModule")) + imenu-create-index-function 'semantic-create-imenu-index + imenu-create-index-function 'semantic-create-imenu-index + ) + (setq semantic-lex-analyzer #'semantic-scheme-lexer) + ) + +(provide 'semantic/bovine/scm) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/bovine/scm" +;; End: + +;;; semantic/bovine/scm.el ends here diff --git a/lisp/cedet/semantic/chart.el b/lisp/cedet/semantic/chart.el new file mode 100644 index 00000000000..7efe4e6dfae --- /dev/null +++ b/lisp/cedet/semantic/chart.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el new file mode 100644 index 00000000000..cbf3d9da9ae --- /dev/null +++ b/lisp/cedet/semantic/complete.el @@ -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 <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Completion of tags by name using tables of semantic generated tags. +;; +;; While it would be a simple matter of flattening all tag known +;; tables to perform completion across them using `all-completions', +;; or `try-completion', that process would be slow. In particular, +;; when a system database is included in the mix, the potential for a +;; ludicrous number of options becomes apparent. +;; +;; As such, dynamically searching across tables using a prefix, +;; regular expression, or other feature is needed to help find symbols +;; quickly without resorting to "show me every possible option now". +;; +;; In addition, some symbol names will appear in multiple locations. +;; If it is important to distiguish, then a way to provide a choice +;; over these locations is important as well. +;; +;; Beyond brute force offers for completion of plain strings, +;; using the smarts of semantic-analyze to provide reduced lists of +;; symbols, or fancy tabbing to zoom into files to show multiple hits +;; of the same name can be provided. +;; +;;; How it works: +;; +;; There are several parts of any completion engine. They are: +;; +;; A. Collection of possible hits +;; B. Typing or selecting an option +;; C. Displaying possible unique completions +;; D. Using the result +;; +;; Here, we will treat each section separately (excluding D) +;; They can then be strung together in user-visible commands to +;; fullfill specific needs. +;; +;; COLLECTORS: +;; +;; A collector is an object which represents the means by which tags +;; to complete on are collected. It's first job is to find all the +;; tags which are to be completed against. It can also rename +;; some tags if needed so long as `semantic-tag-clone' is used. +;; +;; Some collectors will gather all tags to complete against first +;; (for in buffer queries, or other small list situations). It may +;; choose to do a broad search on each completion request. Built in +;; functionality automatically focuses the cache in as the user types. +;; +;; A collector choosing to create and rename tags could choose a +;; plain name format, a postfix name such as method:class, or a +;; prefix name such as class.method. +;; +;; DISPLAYORS +;; +;; A displayor is in charge if showing the user interesting things +;; about available completions, and can optionally provide a focus. +;; The simplest display just lists all available names in a separate +;; window. It may even choose to show short names when there are +;; many to choose from, or long names when there are fewer. +;; +;; A complex displayor could opt to help the user 'focus' on some +;; range. For example, if 4 tags all have the same name, subsequent +;; calls to the displayor may opt to show each tag one at a time in +;; the buffer. When the user likes one, selection would cause the +;; 'focus' item to be selected. +;; +;; CACHE FORMAT +;; +;; The format of the tag lists used to perform the completions are in +;; semanticdb "find" format, like this: +;; +;; ( ( DBTABLE1 TAG1 TAG2 ...) +;; ( DBTABLE2 TAG1 TAG2 ...) +;; ... ) +;; +;; INLINE vs MINIBUFFER +;; +;; Two major ways completion is used in Emacs is either through a +;; minibuffer query, or via completion in a normal editing buffer, +;; encompassing some small range of characters. +;; +;; Structure for both types of completion are provided here. +;; `semantic-complete-read-tag-engine' will use the minibuffer. +;; `semantic-complete-inline-tag-engine' will complete text in +;; a buffer. + +(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 <jet@gyve.org> +;; +;; Modified by Eric Ludlam for +;; * Safe compatibility for tooltip free systems. +;; * Don't use 'avoid package for tooltip positioning. + +(defclass semantic-displayor-tooltip (semantic-displayor-traditional) + ((max-tags :type integer + :initarg :max-tags + :initform 5 + :custom integer + :documentation + "Max number of tags displayed on tooltip at once. +If `force-show' is 1, this value is ignored with typing tab or space twice continuously. +if `force-show' is 0, this value is always ignored.") + (force-show :type integer + :initarg :force-show + :initform 1 + :custom (choice (const + :tag "Show when double typing" + 1) + (const + :tag "Show always" + 0) + (const + :tag "Show if the number of tags is less than `max-tags'." + -1)) + :documentation + "Control the behavior of the number of tags is greater than `max-tags'. +-1 means tags are never shown. +0 means the tags are always shown. +1 means tags are shown if space or tab is typed twice continuously.") + (typing-count :type integer + :initform 0 + :documentation + "Counter holding how many times the user types space or tab continuously before showing tags.") + (shown :type boolean + :initform nil + :documentation + "Flag representing whether tags is shown once or not.") + ) + "Display completions options in a tooltip. +Display mechanism using tooltip for a list of possible completions.") + +(defmethod initialize-instance :AFTER ((obj semantic-displayor-tooltip) &rest args) + "Make sure we have tooltips required." + (condition-case nil + (require 'tooltip) + (error nil)) + ) + +(defmethod semantic-displayor-show-request ((obj semantic-displayor-tooltip)) + "A request to show the current tags table." + (if (or (not (featurep 'tooltip)) (not tooltip-mode)) + ;; If we cannot use tooltips, then go to the normal mode with + ;; a traditional completion buffer. + (call-next-method) + (let* ((tablelong (semanticdb-strip-find-results (oref obj table))) + (table (semantic-unique-tag-table-by-name tablelong)) + (l (mapcar semantic-completion-displayor-format-tag-function table)) + (ll (length l)) + (typing-count (oref obj typing-count)) + (force-show (oref obj force-show)) + (matchtxt (semantic-completion-text)) + msg) + (if (or (oref obj shown) + (< ll (oref obj max-tags)) + (and (<= 0 force-show) + (< (1- force-show) typing-count))) + (progn + (oset obj typing-count 0) + (oset obj shown t) + (if (eq 1 ll) + ;; We Have only one possible match. There could be two cases. + ;; 1) input text != single match. + ;; --> Show it! + ;; 2) input text == single match. + ;; --> Complain about it, but still show the match. + (if (string= matchtxt (semantic-tag-name (car table))) + (setq msg (concat "[COMPLETE]\n" (car l))) + (setq msg (car l))) + ;; Create the long message. + (setq msg (mapconcat 'identity l "\n")) + ;; If there is nothing, say so! + (if (eq 0 (length msg)) + (setq msg "[NO MATCH]"))) + (semantic-displayor-tooltip-show msg)) + ;; The typing count determines if the user REALLY REALLY + ;; wanted to show that much stuff. Only increment + ;; if the current command is a completion command. + (if (and (stringp (this-command-keys)) + (string= (this-command-keys) "\C-i")) + (oset obj typing-count (1+ typing-count))) + ;; At this point, we know we have too many items. + ;; Lets be brave, and truncate l + (setcdr (nthcdr (oref obj max-tags) l) nil) + (setq msg (mapconcat 'identity l "\n")) + (cond + ((= force-show -1) + (semantic-displayor-tooltip-show (concat msg "\n..."))) + ((= force-show 1) + (semantic-displayor-tooltip-show (concat msg "\n(TAB for more)"))) + ))))) + +;;; Compatibility +;; +(eval-and-compile + (if (fboundp 'window-inside-edges) + ;; Emacs devel. + (defalias 'semantic-displayor-window-edges + 'window-inside-edges) + ;; Emacs 21 + (defalias 'semantic-displayor-window-edges + 'window-edges) + )) + +(defun semantic-displayor-point-position () + "Return the location of POINT as positioned on the selected frame. +Return a cons cell (X . Y)" + (let* ((frame (selected-frame)) + (left (frame-parameter frame 'left)) + (top (frame-parameter frame 'top)) + (point-pix-pos (posn-x-y (posn-at-point))) + (edges (window-inside-pixel-edges (selected-window)))) + (cons (+ (car point-pix-pos) (car edges) left) + (+ (cdr point-pix-pos) (cadr edges) top)))) + + +(defun semantic-displayor-tooltip-show (text) + "Display a tooltip with TEXT near cursor." + (let ((point-pix-pos (semantic-displayor-point-position)) + (tooltip-frame-parameters + (append tooltip-frame-parameters nil))) + (push + (cons 'left (+ (car point-pix-pos) (frame-char-width))) + tooltip-frame-parameters) + (push + (cons 'top (+ (cdr point-pix-pos) (frame-char-height))) + tooltip-frame-parameters) + (tooltip-show text))) + +(defmethod semantic-displayor-scroll-request ((obj semantic-displayor-tooltip)) + "A request to for the displayor to scroll the completion list (if needed)." + ;; Do scrolling in the tooltip. + (oset obj max-tags 30) + (semantic-displayor-show-request obj) + ) + +;; End code contributed by Masatake YAMATO <jet@gyve.org> + + +;;; 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 --git a/lisp/cedet/semantic/ctxt.el b/lisp/cedet/semantic/ctxt.el new file mode 100644 index 00000000000..ab72f4d4e7f --- /dev/null +++ b/lisp/cedet/semantic/ctxt.el @@ -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 <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic, 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 --git a/lisp/cedet/semantic/db-debug.el b/lisp/cedet/semantic/db-debug.el new file mode 100644 index 00000000000..cf188af8323 --- /dev/null +++ b/lisp/cedet/semantic/db-debug.el @@ -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 <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el new file mode 100644 index 00000000000..8c6237f542c --- /dev/null +++ b/lisp/cedet/semantic/db-ebrowse.el @@ -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 <zappo@gnu.org>, Joakim Verona +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This program was started by Eric Ludlam, and Joakim Verona finished +;; the implementation by adding searches and fixing bugs. +;; +;; Read in custom-created ebrowse BROWSE files into a semanticdb back +;; end. +;; +;; Add these databases to the 'system' search. +;; Possibly use ebrowse for local parsing too. +;; +;; When real details are needed out of the tag system from ebrowse, +;; we will need to delve into the originating source and parse those +;; files the usual way. +;; +;; COMMANDS: +;; `semanticdb-create-ebrowse-database' - Call EBROWSE to create a +;; system database for some directory. In general, use this for +;; system libraries, such as /usr/include, or include directories +;; large software projects. +;; Customize `semanticdb-ebrowse-file-match' to make sure the correct +;; file extensions are matched. +;; +;; `semanticdb-load-ebrowse-caches' - Load all the EBROWSE caches from +;; your semanticdb system database directory. Once they are +;; loaded, they become searchable as omnipotent databases for +;; all C++ files. This is called automatically by semantic-load. +;; Call it a second time to refresh the Emacs DB with the file. +;; + +(require 'ebrowse) +(require 'semantic) +(require 'semantic/db-file) + +(eval-when-compile + ;; For generic function searching. + (require 'eieio) + (require 'eieio-opt) + (require 'semantic/find)) + +(declare-function semantic-add-system-include "semantic/dep") + +;;; Code: +(defvar semanticdb-ebrowse-default-file-name "BROWSE" + "The EBROWSE file name used for system caches.") + +(defcustom semanticdb-ebrowse-file-match "\\.\\(hh?\\|HH?\\|hpp\\)" + "Regular expression matching file names for ebrowse to parse. +This expression should exclude C++ headers that have no extension. +By default, include only headers since the semantic use of EBrowse +is only for searching via semanticdb, and thus only headers would +be searched." + :group 'semanticdb + :type 'string) + +;;; SEMANTIC Database related Code +;;; Classes: +(defclass semanticdb-table-ebrowse (semanticdb-table) + ((major-mode :initform c++-mode) + (ebrowse-tree :initform nil + :initarg :ebrowse-tree + :documentation + "The raw ebrowse tree for this file." + ) + (global-extract :initform nil + :initarg :global-extract + :documentation + "Table of ebrowse tags specific to this file. +This table is compisited from the ebrowse *Globals* section.") + ) + "A table for returning search results from ebrowse.") + +(defclass semanticdb-project-database-ebrowse + (semanticdb-project-database) + ((new-table-class :initform semanticdb-table-ebrowse + :type class + :documentation + "New tables created for this database are of this class.") + (system-include-p :initform nil + :initarg :system-include + :documentation + "Flag indicating this database represents a system include directory.") + (ebrowse-struct :initform nil + :initarg :ebrowse-struct + ) + ) + "Semantic Database deriving tags using the EBROWSE tool. +EBROWSE is a C/C++ parser for use with `ebrowse' Emacs program.") + + +(defun semanticdb-ebrowse-C-file-p (file) + "Is FILE a C or C++ file?" + (or (string-match semanticdb-ebrowse-file-match file) + (and (string-match "/\\w+$" file) + (not (file-directory-p file)) + (let ((tmp (get-buffer-create "*semanticdb-ebrowse-tmp*"))) + (save-excursion + (set-buffer tmp) + (condition-case nil + (insert-file-contents file nil 0 100 t) + (error (insert-file-contents file nil nil nil t))) + (goto-char (point-min)) + (looking-at "\\s-*/\\(\\*\\|/\\)") + )) + ))) + +(defun semanticdb-create-ebrowse-database (dir) + "Create an EBROSE database for directory DIR. +The database file is stored in ~/.semanticdb, or whichever directory +is specified by `semanticdb-default-save-directory'." + (interactive "DDirectory: ") + (setq dir (file-name-as-directory dir)) ;; for / on end + (let* ((savein (semanticdb-ebrowse-file-for-directory dir)) + (filebuff (get-buffer-create "*SEMANTICDB EBROWSE TMP*")) + (files (directory-files (expand-file-name dir) t)) + (mma auto-mode-alist) + (regexp nil) + ) + ;; Create the input to the ebrowse command + (save-excursion + (set-buffer filebuff) + (buffer-disable-undo filebuff) + (setq default-directory (expand-file-name dir)) + + ;;; @TODO - convert to use semanticdb-collect-matching-filenames + ;; to get the file names. + + + (mapc (lambda (f) + (when (semanticdb-ebrowse-C-file-p f) + (insert f) + (insert "\n"))) + files) + ;; Cleanup the ebrowse output buffer. + (save-excursion + (set-buffer (get-buffer-create "*EBROWSE OUTPUT*")) + (erase-buffer)) + ;; Call the EBROWSE command. + (message "Creating ebrowse file: %s ..." savein) + (call-process-region (point-min) (point-max) + "ebrowse" nil "*EBROWSE OUTPUT*" nil + (concat "--output-file=" savein) + "--very-verbose") + ) + ;; Create a short LOADER program for loading in this database. + (let* ((lfn (concat savein "-load.el")) + (lf (find-file-noselect lfn))) + (save-excursion + (set-buffer lf) + (erase-buffer) + (insert "(semanticdb-ebrowse-load-helper \"" + (expand-file-name dir) + "\")\n") + (save-buffer) + (kill-buffer (current-buffer))) + (message "Creating ebrowse file: %s ... done" savein) + ;; Reload that database + (load lfn nil t) + ))) + +(defun semanticdb-load-ebrowse-caches () + "Load all semanticdb controlled EBROWSE caches." + (interactive) + (let ((f (directory-files semanticdb-default-save-directory + t (concat semanticdb-ebrowse-default-file-name "-load.el$") t))) + (while f + (load (car f) nil t) + (setq f (cdr f))) + )) + +(defun semanticdb-ebrowse-load-helper (directory) + "Create the semanticdb database via ebrowse for directory. +If DIRECTORY is found to be defunct, it won't load the DB, and will +warn instead." + (if (file-directory-p directory) + (semanticdb-create-database semanticdb-project-database-ebrowse + directory) + (let* ((BF (semanticdb-ebrowse-file-for-directory directory)) + (BFL (concat BF "-load.el")) + (BFLB (concat BF "-load.el~"))) + (save-window-excursion + (with-output-to-temp-buffer "*FILES TO DELETE*" + (princ "The following BROWSE files are obsolete.\n\n") + (princ BF) + (princ "\n") + (princ BFL) + (princ "\n") + (when (file-exists-p BFLB) + (princ BFLB) + (princ "\n")) + ) + (when (y-or-n-p (format + "Warning: Obsolete BROWSE file for: %s\nDelete? " + directory)) + (delete-file BF) + (delete-file BFL) + (when (file-exists-p BFLB) + (delete-file BFLB)) + ))))) + +;JAVE this just instantiates a default empty ebrowse struct? +; how would new instances wind up here? +; the ebrowse class isnt singleton, unlike the emacs lisp one +(defvar-mode-local c++-mode semanticdb-project-system-databases + () + "Search Ebrowse for symbols.") + +(defmethod semanticdb-needs-refresh-p ((table semanticdb-table-ebrowse)) + "EBROWSE database do not need to be refreshed. + +JAVE: stub for needs-refresh, because, how do we know if BROWSE files + are out of date? + +EML: Our database should probably remember the timestamp/checksum of + the most recently read EBROWSE file, and use that." + nil +) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +;;; EBROWSE code +;; +;; These routines deal with part of the ebrowse interface. +(defun semanticdb-ebrowse-file-for-directory (dir) + "Return the file name for DIR where the ebrowse BROWSE file is. +This file should reside in `semanticdb-default-save-directory'." + (let* ((semanticdb-default-save-directory + semanticdb-default-save-directory) + (B (semanticdb-file-name-directory + 'semanticdb-project-database-file + (concat (expand-file-name dir) + semanticdb-ebrowse-default-file-name))) + ) + B)) + +(defun semanticdb-ebrowse-get-ebrowse-structure (dir) + "Return the ebrowse structure for directory DIR. +This assumes semantic manages the BROWSE files, so they are assumed to live +where semantic cache files live, depending on your settings. + +For instance: /home/<username>/.semanticdb/!usr!include!BROWSE" + (let* ((B (semanticdb-ebrowse-file-for-directory dir)) + (buf (get-buffer-create "*semanticdb ebrowse*"))) + (message "semanticdb-ebrowse %s" B) + (when (file-exists-p B) + (set-buffer buf) + (buffer-disable-undo buf) + (erase-buffer) + (insert-file-contents B) + (let ((ans nil) + (efcn (symbol-function 'ebrowse-show-progress))) + (fset 'ebrowse-show-progress #'(lambda (&rest junk) nil)) + (unwind-protect ;; Protect against errors w/ ebrowse + (setq ans (list B (ebrowse-read))) + ;; These items must always happen + (erase-buffer) + (fset 'ebrowse-show-fcn efcn) + ) + ans)))) + +;;; Methods for creating a database or tables +;; +(defmethod semanticdb-create-database :STATIC ((dbeC semanticdb-project-database-ebrowse) + directory) + "Create a new semantic database for DIRECTORY based on ebrowse. +If there is no database for DIRECTORY available, then +{not implemented yet} create one. Return nil if that is not possible." + ;; MAKE SURE THAT THE FILE LOADED DOESN'T ALREADY EXIST. + (require 'semantic/dep) + (let ((dbs semanticdb-database-list) + (found nil)) + (while (and (not found) dbs) + (when (semanticdb-project-database-ebrowse-p (car dbs)) + (when (string= (oref (car dbs) reference-directory) directory) + (setq found (car dbs)))) + (setq dbs (cdr dbs))) + ;;STATIC means DBE cant be used as object, only as a class + (let* ((ebrowse-data (semanticdb-ebrowse-get-ebrowse-structure directory)) + (dat (car (cdr ebrowse-data))) + (ebd (car dat)) + (db nil) + (default-directory directory) + ) + (if found + (setq db found) + (setq db (make-instance + dbeC + directory + :ebrowse-struct ebd + )) + (oset db reference-directory directory)) + + ;; Once we recycle or make a new DB, refresh the + ;; contents from the BROWSE file. + (oset db tables nil) + ;; only possible after object creation, tables inited to nil. + (semanticdb-ebrowse-strip-trees db dat) + + ;; Once our database is loaded, if we are a system DB, we + ;; add ourselves to the include list for C++. + (semantic-add-system-include directory 'c++-mode) + (semantic-add-system-include directory 'c-mode) + + db))) + +(defmethod semanticdb-ebrowse-strip-trees ((dbe semanticdb-project-database-ebrowse) + data) + "For the ebrowse database DBE, strip all tables from DATA." +;JAVE what it actually seems to do is split the original tree in "tables" associated with files +; im not sure it actually works: +; the filename slot sometimes gets to be nil, +; apparently for classes which definition cant be found, yet needs to be included in the tree +; like library baseclasses +; a file can define several classes + (let ((T (car (cdr data))));1st comes a header, then the tree + (while T + + (let* ((tree (car T)) + (class (ebrowse-ts-class tree)); root class of tree + ;; Something funny going on with this file thing... + (filename (or (ebrowse-cs-source-file class) + (ebrowse-cs-file class))) + ) + (cond + ((ebrowse-globals-tree-p tree) + ;; We have the globals tree.. save this special. + (semanticdb-ebrowse-add-globals-to-table dbe tree) + ) + (t + ;; ebrowse will collect all the info from multiple files + ;; into one tree. Semantic wants all the bits to be tied + ;; into different files. We need to do a full dissociation + ;; into semantic parsable tables. + (semanticdb-ebrowse-add-tree-to-table dbe tree) + )) + (setq T (cdr T)))) + )) + +;;; Filename based methods +;; +(defun semanticdb-ebrowse-add-globals-to-table (dbe tree) + "For database DBE, add the ebrowse TREE into the table." + (if (or (not (ebrowse-ts-p tree)) + (not (ebrowse-globals-tree-p tree))) + (signal 'wrong-type-argument (list 'ebrowse-ts-p tree))) + + (let* ((class (ebrowse-ts-class tree)) + (fname (or (ebrowse-cs-source-file class) + (ebrowse-cs-file class) + ;; Not def'd here, assume our current + ;; file + (concat default-directory "/unknown-proxy.hh"))) + (vars (ebrowse-ts-member-functions tree)) + (fns (ebrowse-ts-member-variables tree)) + (toks nil) + ) + (while vars + (let ((nt (semantic-tag (ebrowse-ms-name (car vars)) + 'variable)) + (defpoint (ebrowse-bs-point class))) + (when defpoint + (semantic--tag-set-overlay nt + (vector defpoint defpoint))) + (setq toks (cons nt toks))) + (setq vars (cdr vars))) + (while fns + (let ((nt (semantic-tag (ebrowse-ms-name (car fns)) + 'function)) + (defpoint (ebrowse-bs-point class))) + (when defpoint + (semantic--tag-set-overlay nt + (vector defpoint defpoint))) + (setq toks (cons nt toks))) + (setq fns (cdr fns))) + + )) + +(defun semanticdb-ebrowse-add-tree-to-table (dbe tree &optional fname baseclasses) + "For database DBE, add the ebrowse TREE into the table for FNAME. +Optional argument BASECLASSES specifyies a baseclass to the tree being provided." + (if (not (ebrowse-ts-p tree)) + (signal 'wrong-type-argument (list 'ebrowse-ts-p tree))) + + ;; Strategy overview: + ;; 1) Calculate the filename for this tree. + ;; 2) Find a matching namespace in TAB, or create a new one. + ;; 3) Fabricate a tag proxy for CLASS + ;; 4) Add it to the namespace + ;; 5) Add subclasses + + ;; 1 - Find the filename + (if (not fname) + (setq fname (or (ebrowse-cs-source-file (ebrowse-ts-class tree)) + (ebrowse-cs-file (ebrowse-ts-class tree)) + ;; Not def'd here, assume our current + ;; file + (concat default-directory "/unknown-proxy.hh")))) + + (let* ((tab (or (semanticdb-file-table dbe fname) + (semanticdb-create-table dbe fname))) + (class (ebrowse-ts-class tree)) + (scope (ebrowse-cs-scope class)) + (ns (when scope (split-string scope ":" t))) + (nst nil) + (cls nil) + ) + + ;; 2 - Get the namespace tag + (when ns + (let ((taglst (if (slot-boundp tab 'tags) (oref tab tags) nil))) + (setq nst (semantic-find-first-tag-by-name (car ns) taglst)) + (when (not nst) + (setq nst (semantic-tag (car ns) 'type :type "namespace")) + (oset tab tags (cons nst taglst)) + ))) + + ;; 3 - Create a proxy tg. + (setq cls (semantic-tag (ebrowse-cs-name class) + 'type + :type "class" + :superclasses baseclasses + :faux t + :filename fname + )) + (let ((defpoint (ebrowse-bs-point class))) + (when defpoint + (semantic--tag-set-overlay cls + (vector defpoint defpoint)))) + + ;; 4 - add to namespace + (if nst + (semantic-tag-put-attribute + nst :members (cons cls (semantic-tag-get-attribute nst :members))) + (oset tab tags (cons cls (when (slot-boundp tab 'tags) + (oref tab tags))))) + + ;; 5 - Subclasses + (let* ((subclass (ebrowse-ts-subclasses tree)) + (pname (ebrowse-cs-name class))) + (when (ebrowse-cs-scope class) + (setq pname (concat (mapconcat (lambda (a) a) (cdr ns) "::") "::" pname))) + + (while subclass + (let* ((scc (ebrowse-ts-class (car subclass))) + (fname (or (ebrowse-cs-source-file scc) + (ebrowse-cs-file scc) + ;; Not def'd here, assume our current + ;; file + fname + ))) + (when fname + (semanticdb-ebrowse-add-tree-to-table + dbe (car subclass) fname pname))) + (setq subclass (cdr subclass)))) + )) + +;;; +;; Overload for converting the simple faux tag into something better. +;; +(defmethod semanticdb-normalize-tags ((obj semanticdb-table-ebrowse) tags) + "Convert in Ebrowse database OBJ a list of TAGS into a complete tag. +The default tag provided by searches exclude many features of a +semantic parsed tag. Look up the file for OBJ, and match TAGS +against a semantic parsed tag that has all the info needed, and +return that." + (let ((tagret nil) + ) + ;; SemanticDB will automatically create a regular database + ;; on top of the file just loaded by ebrowse during the set + ;; buffer. Fetch that table, and use it's tag list to look + ;; up the tag we just got, and thus turn it into a full semantic + ;; tag. + (while tags + (let ((tag (car tags))) + (save-excursion + (semanticdb-set-buffer obj) + (let ((ans nil)) + ;; Gee, it would be nice to do this, but ebrowse LIES. Oi. + (when (semantic-tag-with-position-p tag) + (goto-char (semantic-tag-start tag)) + (let ((foundtag (semantic-current-tag))) + ;; Make sure the discovered tag is the same as what we started with. + (when (string= (semantic-tag-name tag) + (semantic-tag-name foundtag)) + ;; We have a winner! + (setq ans foundtag)))) + ;; Sometimes ebrowse lies. Do a generic search + ;; to find it within this file. + (when (not ans) + ;; We might find multiple hits for this tag, and we have no way + ;; of knowing which one the user wanted. Return the first one. + (setq ans (semantic-deep-find-tags-by-name + (semantic-tag-name tag) + (semantic-fetch-tags)))) + (if (semantic-tag-p ans) + (setq tagret (cons ans tagret)) + (setq tagret (append ans tagret))) + )) + (setq tags (cdr tags)))) + tagret)) + +(defmethod semanticdb-normalize-one-tag ((obj semanticdb-table-ebrowse) tag) + "Convert in Ebrowse database OBJ one TAG into a complete tag. +The default tag provided by searches exclude many features of a +semantic parsed tag. Look up the file for OBJ, and match TAG +against a semantic parsed tag that has all the info needed, and +return that." + (let ((tagret nil) + (objret nil)) + ;; SemanticDB will automatically create a regular database + ;; on top of the file just loaded by ebrowse during the set + ;; buffer. Fetch that table, and use it's tag list to look + ;; up the tag we just got, and thus turn it into a full semantic + ;; tag. + (save-excursion + (semanticdb-set-buffer obj) + (setq objret semanticdb-current-table) + (when (not objret) + ;; What to do?? + (debug)) + (let ((ans nil)) + ;; Gee, it would be nice to do this, but ebrowse LIES. Oi. + (when (semantic-tag-with-position-p tag) + (goto-char (semantic-tag-start tag)) + (let ((foundtag (semantic-current-tag))) + ;; Make sure the discovered tag is the same as what we started with. + (when (string= (semantic-tag-name tag) + (semantic-tag-name foundtag)) + ;; We have a winner! + (setq ans foundtag)))) + ;; Sometimes ebrowse lies. Do a generic search + ;; to find it within this file. + (when (not ans) + ;; We might find multiple hits for this tag, and we have no way + ;; of knowing which one the user wanted. Return the first one. + (setq ans (semantic-deep-find-tags-by-name + (semantic-tag-name tag) + (semantic-fetch-tags)))) + (if (semantic-tag-p ans) + (setq tagret ans) + (setq tagret (car ans))) + )) + (cons objret tagret))) + +;;; Search Overrides +;; +;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining +;; how your new search routines are implemented. +;; +(defmethod semanticdb-find-tags-by-name-method + ((table semanticdb-table-ebrowse) name &optional tags) + "Find all tags named NAME in TABLE. +Return a list of tags." + ;;(message "semanticdb-find-tags-by-name-method name -- %s" name) + (if tags + ;; If TAGS are passed in, then we don't need to do work here. + (call-next-method) + ;; If we ever need to do something special, add here. + ;; Since ebrowse tags are converted into semantic tags, we can + ;; get away with this sort of thing. + (call-next-method) + ) + ) + +(defmethod semanticdb-find-tags-by-name-regexp-method + ((table semanticdb-table-ebrowse) regex &optional tags) + "Find all tags with name matching REGEX in TABLE. +Optional argument TAGS is a list of tags to search. +Return a list of tags." + (if tags (call-next-method) + ;; YOUR IMPLEMENTATION HERE + (call-next-method) + )) + +(defmethod semanticdb-find-tags-for-completion-method + ((table semanticdb-table-ebrowse) prefix &optional tags) + "In TABLE, find all occurances of tags matching PREFIX. +Optional argument TAGS is a list of tags to search. +Returns a table of all matching tags." + (if tags (call-next-method) + ;; YOUR IMPLEMENTATION HERE + (call-next-method) + )) + +(defmethod semanticdb-find-tags-by-class-method + ((table semanticdb-table-ebrowse) class &optional tags) + "In TABLE, find all occurances of tags of CLASS. +Optional argument TAGS is a list of tags to search. +Returns a table of all matching tags." + (if tags (call-next-method) + (call-next-method))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Deep Searches +;; +;; If your language does not have a `deep' concept, these can be left +;; alone, otherwise replace with implementations similar to those +;; above. +;; + +(defmethod semanticdb-deep-find-tags-by-name-method + ((table semanticdb-table-ebrowse) name &optional tags) + "Find all tags name NAME in TABLE. +Optional argument TAGS is a list of tags t +Like `semanticdb-find-tags-by-name-method' for ebrowse." + ;;(semanticdb-find-tags-by-name-method table name tags) + (call-next-method)) + +(defmethod semanticdb-deep-find-tags-by-name-regexp-method + ((table semanticdb-table-ebrowse) regex &optional tags) + "Find all tags with name matching REGEX in TABLE. +Optional argument TAGS is a list of tags to search. +Like `semanticdb-find-tags-by-name-method' for ebrowse." + ;;(semanticdb-find-tags-by-name-regexp-method table regex tags) + (call-next-method)) + +(defmethod semanticdb-deep-find-tags-for-completion-method + ((table semanticdb-table-ebrowse) prefix &optional tags) + "In TABLE, find all occurances of tags matching PREFIX. +Optional argument TAGS is a list of tags to search. +Like `semanticdb-find-tags-for-completion-method' for ebrowse." + ;;(semanticdb-find-tags-for-completion-method table prefix tags) + (call-next-method)) + +;;; Advanced Searches +;; +(defmethod semanticdb-find-tags-external-children-of-type-method + ((table semanticdb-table-ebrowse) type &optional tags) + "Find all nonterminals which are child elements of TYPE +Optional argument TAGS is a list of tags to search. +Return a list of tags." + (if tags (call-next-method) + ;; Ebrowse collects all this type of stuff together for us. + ;; but we can't use it.... yet. + nil + )) + +(provide 'semantic/db-ebrowse) + +;;; semantic/db-ebrowse.el ends here diff --git a/lisp/cedet/semantic/db-el.el b/lisp/cedet/semantic/db-el.el new file mode 100644 index 00000000000..f98226906c8 --- /dev/null +++ b/lisp/cedet/semantic/db-el.el @@ -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 <zappo@gnu.org> +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/db-file.el b/lisp/cedet/semantic/db-file.el new file mode 100644 index 00000000000..2ba2b44461f --- /dev/null +++ b/lisp/cedet/semantic/db-file.el @@ -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 <zappo@gnu.org> +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el new file mode 100644 index 00000000000..e7ce7fcbdef --- /dev/null +++ b/lisp/cedet/semantic/db-find.el @@ -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 <zappo@gnu.org> +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Databases of various forms can all be searched. +;; There are a few types of searches that can be done: +;; +;; Basic Name Search: +;; These searches scan a database table collection for tags based +;; on name. +;; +;; Basic Attribute Search: +;; These searches allow searching on specific attributes of tags, +;; such as name, type, or other attribute. +;; +;; Advanced Search: +;; These are searches that were needed to accomplish some +;; specialized tasks as discovered in utilities. Advanced searches +;; include matching methods defined outside some parent class. +;; +;; The reason for advanced searches are so that external +;; repositories such as the Emacs obarray, or java .class files can +;; quickly answer these needed questions without dumping the entire +;; symbol list into Emacs for additional refinement searches via +;; regular semanticdb search. +;; +;; How databases are decided upon is another important aspect of a +;; database search. When it comes to searching for a name, there are +;; these types of searches: +;; +;; Basic Search: +;; Basic search means that tags looking for a given name start +;; with a specific search path. Names are sought on that path +;; until it is empty or items on the path can no longer be found. +;; Use `semanticdb-dump-all-table-summary' to test this list. +;; Use `semanticdb-find-throttle-custom-list' to refine this list. +;; +;; Deep Search: +;; A deep search will search more than just the global namespace. +;; It will recurse into tags that contain more tags, and search +;; those too. +;; +;; Brute Search: +;; Brute search means that all tables in all databases in a given +;; project are searched. Brute searches are the search style as +;; written for semantic version 1.x. +;; +;; How does the search path work? +;; +;; A basic search starts with three parameters: +;; +;; (FINDME &optional PATH FIND-FILE-MATCH) +;; +;; FINDME is key to be searched for dependent on the type of search. +;; PATH is an indicator of which tables are to be searched. +;; FIND-FILE-MATCH indicates that any time a match is found, the +;; file associated with the tag should be read into a file. +;; +;; The PATH argument is then the most interesting argument. It can +;; have these values: +;; +;; nil - Take the current buffer, and use it's include list +;; buffer - Use that buffer's include list. +;; filename - Use that file's include list. If the file is not +;; in a buffer, see of there is a semanticdb table for it. If +;; not, read that file into a buffer. +;; tag - Get that tag's buffer of file file. See above. +;; table - Search that table, and it's include list. +;; +;; Search Results: +;; +;; Semanticdb returns the results in a specific format. There are a +;; series of routines for using those results, and results can be +;; passed in as a search-path for refinement searches with +;; semanticdb. Apropos for semanticdb.*find-result for more. +;; +;; Application: +;; +;; Here are applications where different searches are needed which +;; exist as of semantic 1.4.x +;; +;; eldoc - popup help +;; => Requires basic search using default path. (Header files ok) +;; tag jump - jump to a named tag +;; => Requires a brute search useing whole project. (Source files only) +;; completion - Completing symbol names in a smart way +;; => Basic search (headers ok) +;; type analysis - finding type definitions for variables & fcns +;; => Basic search (headers ok) +;; Class browser - organize types into some structure +;; => Brute search, or custom navigation. + +;; TODO: +;; During a search, load any unloaded DB files based on paths in the +;; current project. + +(require 'semantic/db) +(require 'semantic/db-ref) +(eval-when-compile + (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 "#<FIND RESULT " + (mapconcat (lambda (a) + (concat "(" (object-name (car a) ) " . " + "#<TAG LIST " (number-to-string (length (cdr a))) ">)")) + result + " ") + ">") + ;; Longer results should have an abreviated form. + (format "#<FIND RESULT %d TAGS in %d FILES>" + (semanticdb-find-result-length result) + (length result)))) + +(defun semanticdb-find-result-with-nil-p (resultp) + "Non-nil of RESULTP is in the form of a semanticdb search result. +nil is a valid value where a TABLE usually is, but only if the TAG +results include overlays. +This query only really tests the first entry in the list that is RESULTP, +but should be good enough for debugging assertions." + (and (listp resultp) + (listp (car resultp)) + (let ((tag-to-test (car-safe (cdr (car resultp))))) + (or (and (semanticdb-abstract-table-child-p (car (car resultp))) + (or (semantic-tag-p tag-to-test) + (null tag-to-test))) + (and (null (car (car resultp))) + (or (semantic-tag-with-position-p tag-to-test) + (null tag-to-test)))) + ))) + +;;;###autoload +(defun semanticdb-find-result-length (result) + "Number of tags found in RESULT." + (let ((count 0)) + (mapc (lambda (onetable) + (setq count (+ count (1- (length onetable))))) + result) + count)) + +;;;###autoload +(defun semanticdb-find-result-nth (result n) + "In RESULT, return the Nth search result. +This is a 0 based search result, with the first match being element 0. + +The returned value is a cons cell: (TAG . TABLE) where TAG +is the tag at the Nth position. TABLE is the semanticdb table where +the TAG was found. Sometimes TABLE can be nil." + (let ((ans nil) + (anstable nil)) + ;; Loop over each single table hit. + (while (and (not ans) result) + ;; For each table result, get local length, and modify + ;; N to be that much less. + (let ((ll (length (cdr (car result))))) ;; local length + (if (> ll n) + ;; We have a local match. + (setq ans (nth n (cdr (car result))) + anstable (car (car result))) + ;; More to go. Decrement N. + (setq n (- n ll)))) + ;; Keep moving. + (setq result (cdr result))) + (cons ans anstable))) + +(defun semanticdb-find-result-test (result) + "Test RESULT by accessing all the tags in the list." + (if (not (semanticdb-find-results-p result)) + (error "Does not pass `semanticdb-find-results-p.\n")) + (let ((len (semanticdb-find-result-length result)) + (i 0)) + (while (< i len) + (let ((tag (semanticdb-find-result-nth result i))) + (if (not (semantic-tag-p (car tag))) + (error "%d entry is not a tag" i))) + (setq i (1+ i))))) + +;;;###autoload +(defun semanticdb-find-result-nth-in-buffer (result n) + "In RESULT, return the Nth search result. +Like `semanticdb-find-result-nth', except that only the TAG +is returned, and the buffer it is found it will be made current. +If the result tag has no position information, the originating buffer +is still made current." + (let* ((ret (semanticdb-find-result-nth result n)) + (ans (car ret)) + (anstable (cdr ret))) + ;; If we have a hit, double-check the find-file + ;; entry. If the file must be loaded, then gat that table's + ;; source file into a buffer. + + (if anstable + (let ((norm (semanticdb-normalize-one-tag anstable ans))) + (when norm + ;; The normalized tags can now be found based on that + ;; tags table. + (semanticdb-set-buffer (car norm)) + ;; Now reset ans + (setq ans (cdr norm)) + )) + ) + ;; Return the tag. + ans)) + +(defun semanticdb-find-result-mapc (fcn result) + "Apply FCN to each element of find RESULT for side-effects only. +FCN takes two arguments. The first is a TAG, and the +second is a DB from wence TAG originated. +Returns result." + (mapc (lambda (sublst) + (mapc (lambda (tag) + (funcall fcn tag (car sublst))) + (cdr sublst))) + result) + result) + +;;; Search Logging +;; +;; Basic logging to see what the search routines are doing. +(defvar semanticdb-find-log-flag nil + "Non-nil means log the process of searches.") + +(defvar semanticdb-find-log-buffer-name "*SemanticDB Find Log*" + "The name of the logging buffer.") + +(defun semanticdb-find-toggle-logging () + "Toggle sematnicdb logging." + (interactive) + (setq semanticdb-find-log-flag (null semanticdb-find-log-flag)) + (message "Semanticdb find logging is %sabled" + (if semanticdb-find-log-flag "en" "dis"))) + +(defun semanticdb-reset-log () + "Reset the log buffer." + (interactive) + (when semanticdb-find-log-flag + (save-excursion + (set-buffer (get-buffer-create semanticdb-find-log-buffer-name)) + (erase-buffer) + ))) + +(defun semanticdb-find-log-move-to-end () + "Move to the end of the semantic log." + (let ((cb (current-buffer)) + (cw (selected-window))) + (unwind-protect + (progn + (set-buffer semanticdb-find-log-buffer-name) + (if (get-buffer-window (current-buffer) 'visible) + (select-window (get-buffer-window (current-buffer) 'visible))) + (goto-char (point-max))) + (if cw (select-window cw)) + (set-buffer cb)))) + +(defun semanticdb-find-log-new-search (forwhat) + "Start a new search FORWHAT." + (when semanticdb-find-log-flag + (save-excursion + (set-buffer (get-buffer-create semanticdb-find-log-buffer-name)) + (insert (format "New Search: %S\n" forwhat)) + ) + (semanticdb-find-log-move-to-end))) + +(defun semanticdb-find-log-activity (table result) + "Log that TABLE has been searched and RESULT was found." + (when semanticdb-find-log-flag + (save-excursion + (set-buffer semanticdb-find-log-buffer-name) + (insert "Table: " (object-print table) + " Result: " (int-to-string (length result)) " tags" + "\n") + ) + (semanticdb-find-log-move-to-end))) + +;;; Semanticdb find API functions +;; These are the routines actually used to perform searches. +;; +(defun semanticdb-find-tags-collector (function &optional path find-file-match + brutish) + "Collect all tags returned by FUNCTION over PATH. +The FUNCTION must take two arguments. The first is TABLE, +which is a semanticdb table containing tags. The second argument +to FUNCTION is TAGS. TAGS may be a list of tags. If TAGS is non-nil, then +FUNCTION should search the TAG list, not through TABLE. + +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer. + +Note: You should leave FIND-FILE-MATCH as nil. It is far more +efficient to take the results from any search and use +`semanticdb-strip-find-results' instead. This argument is here +for backward compatibility. + +If optional argument BRUTISH is non-nil, then ignore include statements, +and search all tables in this project tree." + (let (found match) + (save-excursion + ;; If path is a buffer, set ourselves up in that buffer + ;; so that the override methods work correctly. + (when (bufferp path) (set-buffer path)) + (if (semanticdb-find-results-p path) + ;; When we get find results, loop over that. + (dolist (tableandtags path) + (semantic-throw-on-input 'semantic-find-translate-path) + ;; If FIND-FILE-MATCH is non-nil, skip tables of class + ;; `semanticdb-search-results-table', since those are system + ;; databases and not associated with a file. + (unless (and find-file-match + (obj-of-class-p + (car tableandtags) semanticdb-search-results-table)) + (when (setq match (funcall function + (car tableandtags) (cdr tableandtags))) + (when find-file-match + (save-excursion (semanticdb-set-buffer (car tableandtags)))) + (push (cons (car tableandtags) match) found))) + ) + ;; Only log searches across data bases. + (semanticdb-find-log-new-search nil) + ;; If we get something else, scan the list of tables resulting + ;; from translating it into a list of objects. + (dolist (table (semanticdb-find-translate-path path brutish)) + (semantic-throw-on-input 'semantic-find-translate-path) + ;; If FIND-FILE-MATCH is non-nil, skip tables of class + ;; `semanticdb-search-results-table', since those are system + ;; databases and not associated with a file. + (unless (and find-file-match + (obj-of-class-p table semanticdb-search-results-table)) + (when (and table (setq match (funcall function table nil))) + (semanticdb-find-log-activity table match) + (when find-file-match + (save-excursion (semanticdb-set-buffer table))) + (push (cons table match) found)))))) + ;; At this point, FOUND has had items pushed onto it. + ;; This means items are being returned in REVERSE order + ;; of the tables searched, so if you just get th CAR, then + ;; too-bad, you may have some system-tag that has no + ;; buffer associated with it. + + ;; It must be reversed. + (nreverse found))) + +;;;###autoload +(defun semanticdb-find-tags-by-name (name &optional path find-file-match) + "Search for all tags matching NAME on PATH. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-name-method table name tags)) + path find-file-match)) + +;;;###autoload +(defun semanticdb-find-tags-by-name-regexp (regexp &optional path find-file-match) + "Search for all tags matching REGEXP on PATH. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-name-regexp-method table regexp tags)) + path find-file-match)) + +;;;###autoload +(defun semanticdb-find-tags-for-completion (prefix &optional path find-file-match) + "Search for all tags matching PREFIX on PATH. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-for-completion-method table prefix tags)) + path find-file-match)) + +;;;###autoload +(defun semanticdb-find-tags-by-class (class &optional path find-file-match) + "Search for all tags of CLASS on PATH. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-class-method table class tags)) + path find-file-match)) + +;;; Deep Searches +(defun semanticdb-deep-find-tags-by-name (name &optional path find-file-match) + "Search for all tags matching NAME on PATH. +Search also in all components of top level tags founds. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-by-name-method table name tags)) + path find-file-match)) + +(defun semanticdb-deep-find-tags-by-name-regexp (regexp &optional path find-file-match) + "Search for all tags matching REGEXP on PATH. +Search also in all components of top level tags founds. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-by-name-regexp-method table regexp tags)) + path find-file-match)) + +(defun semanticdb-deep-find-tags-for-completion (prefix &optional path find-file-match) + "Search for all tags matching PREFIX on PATH. +Search also in all components of top level tags founds. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-for-completion-method table prefix tags)) + path find-file-match)) + +;;; Brutish Search Routines +;; +(defun semanticdb-brute-deep-find-tags-by-name (name &optional path find-file-match) + "Search for all tags matching NAME on PATH. +See `semanticdb-find-translate-path' for details on PATH. +The argument BRUTISH will be set so that searching includes all tables +in the current project. +FIND-FILE-MATCH indicates that any time a matchi is found, the file +associated wit that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-by-name-method table name tags)) + path find-file-match t)) + +(defun semanticdb-brute-deep-find-tags-for-completion (prefix &optional path find-file-match) + "Search for all tags matching PREFIX on PATH. +See `semanticdb-find-translate-path' for details on PATH. +The argument BRUTISH will be set so that searching includes all tables +in the current project. +FIND-FILE-MATCH indicates that any time a matchi is found, the file +associated wit that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-deep-find-tags-for-completion-method table prefix tags)) + path find-file-match t)) + +(defun semanticdb-brute-find-tags-by-class (class &optional path find-file-match) + "Search for all tags of CLASS on PATH. +See `semanticdb-find-translate-path' for details on PATH. +The argument BRUTISH will be set so that searching includes all tables +in the current project. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-by-class-method table class tags)) + path find-file-match t)) + +;;; Specialty Search Routines +(defun semanticdb-find-tags-external-children-of-type + (type &optional path find-file-match) + "Search for all tags defined outside of TYPE w/ TYPE as a parent. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-external-children-of-type-method table type tags)) + path find-file-match)) + +(defun semanticdb-find-tags-subclasses-of-type + (type &optional path find-file-match) + "Search for all tags of class type defined that subclass TYPE. +See `semanticdb-find-translate-path' for details on PATH. +FIND-FILE-MATCH indicates that any time a match is found, the file +associated with that tag should be loaded into a buffer." + (semanticdb-find-tags-collector + (lambda (table tags) + (semanticdb-find-tags-subclasses-of-type-method table type tags)) + path find-file-match t)) + +;;; 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 --git a/lisp/cedet/semantic/db-global.el b/lisp/cedet/semantic/db-global.el new file mode 100644 index 00000000000..7e13e8c7054 --- /dev/null +++ b/lisp/cedet/semantic/db-global.el @@ -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 <zappo@gnu.org> +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/db-javascript.el b/lisp/cedet/semantic/db-javascript.el new file mode 100644 index 00000000000..e9d3794558d --- /dev/null +++ b/lisp/cedet/semantic/db-javascript.el @@ -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 <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semanticdb database for Javascript. +;; +;; This is an omniscient database with a hard-coded list of symbols for +;; Javascript. See the doc at the end of this file for adding or modifying +;; the list of tags. +;; + +(require 'semantic/db) +(require 'semantic/db-find) + +(eval-when-compile + ;; For generic function searching. + (require 'eieio) + (require 'eieio-opt)) + +;;; Code: +(defvar semanticdb-javascript-tags + '(("eval" function + (:arguments + (("x" variable nil nil nil))) + nil nil) + ("parseInt" function + (:arguments + (("string" variable nil nil nil) + ("radix" variable nil nil nil))) + nil nil) + ("parseFloat" function + (:arguments + (("string" variable nil nil nil))) + nil nil) + ("isNaN" function + (:arguments + (("number" variable nil nil nil))) + nil nil) + ("isFinite" function + (:arguments + (("number" variable nil nil nil))) + nil nil) + ("decodeURI" function + (:arguments + (("encodedURI" variable nil nil nil))) + nil nil) + ("decodeURIComponent" function + (:arguments + (("encodedURIComponent" variable nil nil nil))) + nil nil) + ("encodeURI" function + (:arguments + (("uri" variable nil nil nil))) + nil nil) + ("encodeURIComponent" function + (:arguments + (("uriComponent" variable nil nil nil))) + nil nil)) + "Hard-coded list of javascript tags for semanticdb. +See bottom of this file for instruction on managing this list.") + +;;; Classes: +(defclass semanticdb-table-javascript (semanticdb-search-results-table) + ((major-mode :initform javascript-mode) + ) + "A table for returning search results from javascript.") + +(defclass semanticdb-project-database-javascript + (semanticdb-project-database + eieio-singleton ;this db is for js globals, so singleton is apropriate + ) + ((new-table-class :initform semanticdb-table-javascript + :type class + :documentation + "New tables created for this database are of this class.") + ) + "Database representing javascript.") + +;; Create the database, and add it to searchable databases for javascript mode. +(defvar-mode-local javascript-mode semanticdb-project-system-databases + (list + (semanticdb-project-database-javascript "Javascript")) + "Search javascript for symbols.") + +;; NOTE: Be sure to modify this to the best advantage of your +;; language. +(defvar-mode-local javascript-mode semanticdb-find-default-throttle + '(project omniscience) + "Search project files, then search this omniscience database. +It is not necessary to to system or recursive searching because of +the omniscience database.") + +;;; Filename based methods +;; +(defmethod semanticdb-get-database-tables ((obj semanticdb-project-database-javascript)) + "For a javascript database, there are no explicit tables. +Create one of our special tables that can act as an intermediary." + ;; NOTE: This method overrides an accessor for the `tables' slot in + ;; a database. You can either construct your own (like tmp here + ;; or you can manage any number of tables. + + ;; We need to return something since there is always the "master table" + ;; The table can then answer file name type questions. + (when (not (slot-boundp obj 'tables)) + (let ((newtable (semanticdb-table-javascript "tmp"))) + (oset obj tables (list newtable)) + (oset newtable parent-db obj) + (oset newtable tags nil) + )) + (call-next-method) + ) + +(defmethod semanticdb-file-table ((obj semanticdb-project-database-javascript) filename) + "From OBJ, return FILENAME's associated table object." + ;; NOTE: See not for `semanticdb-get-database-tables'. + (car (semanticdb-get-database-tables obj)) + ) + +(defmethod semanticdb-get-tags ((table semanticdb-table-javascript )) + "Return the list of tags belonging to TABLE." + ;; NOTE: Omniscient databases probably don't want to keep large tabes + ;; lolly-gagging about. Keep internal Emacs tables empty and + ;; refer to alternate databases when you need something. + semanticdb-javascript-tags) + +(defmethod semanticdb-equivalent-mode ((table semanticdb-table-javascript) &optional buffer) + "Return non-nil if TABLE's mode is equivalent to BUFFER. +Equivalent modes are specified by by `semantic-equivalent-major-modes' +local variable." + (save-excursion + (set-buffer buffer) + (eq (or mode-local-active-mode major-mode) 'javascript-mode))) + +;;; Usage +;; +;; Unlike other tables, an omniscent database does not need to +;; be associated with a path. Use this routine to always add ourselves +;; to a search list. +(define-mode-local-override semanticdb-find-translate-path javascript-mode + (path brutish) + "Return a list of semanticdb tables asociated with PATH. +If brutish, do the default action. +If not brutish, do the default action, and append the system +database (if available.)" + (let ((default + ;; When we recurse, disable searching of system databases + ;; so that our Javascript database only shows up once when + ;; we append it in this iteration. + (let ((semanticdb-search-system-databases nil) + ) + (semanticdb-find-translate-path-default path brutish)))) + ;; Don't add anything if BRUTISH is on (it will be added in that fcn) + ;; or if we aren't supposed to search the system. + (if (or brutish (not semanticdb-search-system-databases)) + default + (let ((tables (apply #'append + (mapcar + (lambda (db) (semanticdb-get-database-tables db)) + semanticdb-project-system-databases)))) + (append default tables))))) + +;;; Search Overrides +;; +;; NOTE WHEN IMPLEMENTING: Be sure to add doc-string updates explaining +;; how your new search routines are implemented. +;; +(defun semanticdb-javascript-regexp-search (regexp) + "Search for REGEXP in our fixed list of javascript tags." + (let* ((tags semanticdb-javascript-tags) + (result nil)) + (while tags + (if (string-match regexp (caar tags)) + (setq result (cons (car tags) result))) + (setq tags (cdr tags))) + result)) + +(defmethod semanticdb-find-tags-by-name-method + ((table semanticdb-table-javascript) name &optional tags) + "Find all tags named NAME in TABLE. +Return a list of tags." + (if tags + ;; If TAGS are passed in, then we don't need to do work here. + (call-next-method) + (assoc-string name semanticdb-javascript-tags) + )) + +(defmethod semanticdb-find-tags-by-name-regexp-method + ((table semanticdb-table-javascript) regex &optional tags) + "Find all tags with name matching REGEX in TABLE. +Optional argument TAGS is a list of tags to search. +Return a list of tags." + (if tags (call-next-method) + ;; YOUR IMPLEMENTATION HERE + (semanticdb-javascript-regexp-search regex) + + )) + +(defmethod semanticdb-find-tags-for-completion-method + ((table semanticdb-table-javascript) prefix &optional tags) + "In TABLE, find all occurances of tags matching PREFIX. +Optional argument TAGS is a list of tags to search. +Returns a table of all matching tags." + (if tags (call-next-method) + ;; YOUR IMPLEMENTATION HERE + (semanticdb-javascript-regexp-search (concat "^" prefix ".*")) + )) + +(defmethod semanticdb-find-tags-by-class-method + ((table semanticdb-table-javascript) class &optional tags) + "In TABLE, find all occurances of tags of CLASS. +Optional argument TAGS is a list of tags to search. +Returns a table of all matching tags." + (if tags (call-next-method) + ;; YOUR IMPLEMENTATION HERE + ;; + ;; Note: This search method could be considered optional in an + ;; omniscient database. It may be unwise to return all tags + ;; that exist for a language that are a variable or function. + ;; + ;; If it is optional, you can just delete this method. + nil)) + +;;; Deep Searches +;; +;; If your language does not have a `deep' concept, these can be left +;; alone, otherwise replace with implementations similar to those +;; above. +;; +(defmethod semanticdb-deep-find-tags-by-name-method + ((table semanticdb-table-javascript) name &optional tags) + "Find all tags name NAME in TABLE. +Optional argument TAGS is a list of tags t +Like `semanticdb-find-tags-by-name-method' for javascript." + (semanticdb-find-tags-by-name-method table name tags)) + +(defmethod semanticdb-deep-find-tags-by-name-regexp-method + ((table semanticdb-table-javascript) regex &optional tags) + "Find all tags with name matching REGEX in TABLE. +Optional argument TAGS is a list of tags to search. +Like `semanticdb-find-tags-by-name-method' for javascript." + (semanticdb-find-tags-by-name-regexp-method table regex tags)) + +(defmethod semanticdb-deep-find-tags-for-completion-method + ((table semanticdb-table-javascript) prefix &optional tags) + "In TABLE, find all occurances of tags matching PREFIX. +Optional argument TAGS is a list of tags to search. +Like `semanticdb-find-tags-for-completion-method' for javascript." + (semanticdb-find-tags-for-completion-method table prefix tags)) + +;;; Advanced Searches +;; +(defmethod semanticdb-find-tags-external-children-of-type-method + ((table semanticdb-table-javascript) type &optional tags) + "Find all nonterminals which are child elements of TYPE +Optional argument TAGS is a list of tags to search. +Return a list of tags." + (if tags (call-next-method) + ;; YOUR IMPLEMENTATION HERE + ;; + ;; OPTIONAL: This could be considered an optional function. It is + ;; used for `semantic-adopt-external-members' and may not + ;; be possible to do in your language. + ;; + ;; If it is optional, you can just delete this method. + )) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun semanticdb-javascript-strip-tags (tags) + "Strip TAGS from overlays and reparse symbols." + (cond ((and (consp tags) (eq 'reparse-symbol (car tags))) + nil) + ((overlayp tags) nil) + ((atom tags) tags) + (t (cons (semanticdb-javascript-strip-tags + (car tags)) (semanticdb-javascript-strip-tags + (cdr tags)))))) + +;this list was made from a javascript file, and the above function +;; function eval(x){} +;; function parseInt(string,radix){} +;; function parseFloat(string){} +;; function isNaN(number){} +;; function isFinite(number){} +;; function decodeURI(encodedURI){} +;; function decodeURIComponent (encodedURIComponent){} +;; function encodeURI (uri){} +;; function encodeURIComponent (uriComponent){} + +(provide 'semantic/db-javascript) + +;;; semantic/db-javascript.el ends here diff --git a/lisp/cedet/semantic/db-mode.el b/lisp/cedet/semantic/db-mode.el new file mode 100644 index 00000000000..c526515f248 --- /dev/null +++ b/lisp/cedet/semantic/db-mode.el @@ -0,0 +1,221 @@ +;;; semantic/db-mode.el --- Semanticdb Minor Mode + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Major mode for managing Semantic Databases automatically. + +;;; 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 --git a/lisp/cedet/semantic/db-ref.el b/lisp/cedet/semantic/db-ref.el new file mode 100644 index 00000000000..2c8dd7729c4 --- /dev/null +++ b/lisp/cedet/semantic/db-ref.el @@ -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 <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/db-typecache.el b/lisp/cedet/semantic/db-typecache.el new file mode 100644 index 00000000000..02d77327c69 --- /dev/null +++ b/lisp/cedet/semantic/db-typecache.el @@ -0,0 +1,606 @@ +;;; db-typecache.el --- Manage Datatypes + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el new file mode 100644 index 00000000000..bc25d31f19e --- /dev/null +++ b/lisp/cedet/semantic/db.el @@ -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 <zappo@gnu.org> +;; Keywords: tags + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Maintain a database of tags for a group of files and enable +;; queries into the database. +;; +;; By default, assume one database per directory. +;; + +;;; 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 --git a/lisp/cedet/semantic/debug.el b/lisp/cedet/semantic/debug.el new file mode 100644 index 00000000000..3a348f2a9e9 --- /dev/null +++ b/lisp/cedet/semantic/debug.el @@ -0,0 +1,576 @@ +;;; semantic/debug.el --- Language Debugger framework + +;;; Copyright (C) 2003, 2004, 2005, 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/decorate.el b/lisp/cedet/semantic/decorate.el new file mode 100644 index 00000000000..70c082e4e98 --- /dev/null +++ b/lisp/cedet/semantic/decorate.el @@ -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 <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Text representing a semantic tag is wrapped in an overlay. +;; This overlay can be used for highlighting, or setting other +;; editing properties on a tag, such as "read only." +;; + +(require 'semantic) +(require 'pulse) + +;;; Code: + +;;; Highlighting Basics +(defun semantic-highlight-tag (tag &optional face) + "Specify that TAG should be highlighted. +Optional FACE specifies the face to use." + (let ((o (semantic-tag-overlay tag))) + (semantic-overlay-put o 'old-face + (cons (semantic-overlay-get o 'face) + (semantic-overlay-get o 'old-face))) + (semantic-overlay-put o 'face (or face 'semantic-tag-highlight-face)) + )) + +(defun semantic-unhighlight-tag (tag) + "Unhighlight TAG, restoring it's previous face." + (let ((o (semantic-tag-overlay tag))) + (semantic-overlay-put o 'face (car (semantic-overlay-get o 'old-face))) + (semantic-overlay-put o 'old-face (cdr (semantic-overlay-get o 'old-face))) + )) + +;;; Momentary Highlighting - One line +(defun semantic-momentary-highlight-one-tag-line (tag &optional face) + "Highlight the first line of TAG, unhighlighting before next command. +Optional argument FACE specifies the face to do the highlighting." + (save-excursion + ;; Go to first line in tag + (semantic-go-to-tag tag) + (pulse-momentary-highlight-one-line (point)))) + +;;; Momentary Highlighting - Whole Tag +(defun semantic-momentary-highlight-tag (tag &optional face) + "Highlight TAG, removing highlighting when the user hits a key. +Optional argument FACE is the face to use for highlighting. +If FACE is not specified, then `highlight' will be used." + (when (semantic-tag-with-position-p tag) + (if (not (semantic-overlay-p (semantic-tag-overlay tag))) + ;; No overlay, but a position. Highlight the first line only. + (semantic-momentary-highlight-one-tag-line tag face) + ;; The tag has an overlay, highlight the whole thing + (pulse-momentary-highlight-overlay (semantic-tag-overlay tag) + face) + ))) + +(defun semantic-set-tag-face (tag face) + "Specify that TAG should use FACE for display." + (semantic-overlay-put (semantic-tag-overlay tag) 'face face)) + +(defun semantic-set-tag-invisible (tag &optional visible) + "Enable the text in TAG to be made invisible. +If VISIBLE is non-nil, make the text visible." + (semantic-overlay-put (semantic-tag-overlay tag) 'invisible + (not visible))) + +(defun semantic-tag-invisible-p (tag) + "Return non-nil if TAG is invisible." + (semantic-overlay-get (semantic-tag-overlay tag) 'invisible)) + +(defun semantic-set-tag-intangible (tag &optional tangible) + "Enable the text in TAG to be made intangible. +If TANGIBLE is non-nil, make the text visible. +This function does not have meaning in XEmacs because it seems that +the extent 'intangible' property does not exist." + (semantic-overlay-put (semantic-tag-overlay tag) 'intangible + (not tangible))) + +(defun semantic-tag-intangible-p (tag) + "Return non-nil if TAG is intangible. +This function does not have meaning in XEmacs because it seems that +the extent 'intangible' property does not exist." + (semantic-overlay-get (semantic-tag-overlay tag) 'intangible)) + +(defun semantic-overlay-signal-read-only + (overlay after start end &optional len) + "Hook used in modification hooks to prevent modification. +Allows deletion of the entire text. +Argument OVERLAY, AFTER, START, END, and LEN are passed in by the system." + ;; Stolen blithly from cpp.el in Emacs 21.1 + (if (and (not after) + (or (< (semantic-overlay-start overlay) start) + (> (semantic-overlay-end overlay) end))) + (error "This text is read only"))) + +(defun semantic-set-tag-read-only (tag &optional writable) + "Enable the text in TAG to be made read-only. +Optional argument WRITABLE should be non-nil to make the text writable +instead of read-only." + (let ((o (semantic-tag-overlay tag)) + (hook (if writable nil '(semantic-overlay-signal-read-only)))) + (if (featurep 'xemacs) + ;; XEmacs extents have a 'read-only' property. + (semantic-overlay-put o 'read-only (not writable)) + (semantic-overlay-put o 'modification-hooks hook) + (semantic-overlay-put o 'insert-in-front-hooks hook) + (semantic-overlay-put o 'insert-behind-hooks hook)))) + +(defun semantic-tag-read-only-p (tag) + "Return non-nil if the current TAG is marked read only." + (let ((o (semantic-tag-overlay tag))) + (if (featurep 'xemacs) + ;; XEmacs extents have a 'read-only' property. + (semantic-overlay-get o 'read-only) + (member 'semantic-overlay-signal-read-only + (semantic-overlay-get o 'modification-hooks))))) + +;;; Secondary overlays +;; +;; Some types of decoration require a second overlay to be made. +;; It could be for images, arrows, or whatever. +;; We need a way to create such an overlay, and make sure it +;; gets whacked, but doesn't show up in the master list +;; of overlays used for searching. +(defun semantic-tag-secondary-overlays (tag) + "Return a list of secondary overlays active on TAG." + (semantic--tag-get-property tag 'secondary-overlays)) + +(defun semantic-tag-create-secondary-overlay (tag &optional link-hook) + "Create a secondary overlay for TAG. +Returns an overlay. The overlay is also saved in TAG. +LINK-HOOK is a function called whenever TAG is to be linked into +a buffer. It should take TAG and OVERLAY as arguments. +The LINK-HOOK should be used to position and set properties on the +generated secondary overlay." + (if (not (semantic-tag-overlay tag)) + ;; do nothing if there is no overlay + nil + (let* ((os (semantic-tag-start tag)) + (oe (semantic-tag-end tag)) + (o (semantic-make-overlay os oe (semantic-tag-buffer tag) t)) + (attr (semantic-tag-secondary-overlays tag)) + ) + (semantic--tag-put-property tag 'secondary-overlays (cons o attr)) + (semantic-overlay-put o 'semantic-secondary t) + (semantic-overlay-put o 'semantic-link-hook link-hook) + (semantic-tag-add-hook tag 'link-hook 'semantic--tag-link-secondary-overlays) + (semantic-tag-add-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) + (semantic-tag-add-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) + (run-hook-with-args link-hook tag o) + o))) + +(defun semantic-tag-get-secondary-overlay (tag property) + "Return secondary overlays from TAG with PROPERTY. +PROPERTY is a symbol and all overlays with that symbol are returned.." + (let* ((olsearch (semantic-tag-secondary-overlays tag)) + (o nil)) + (while olsearch + (when (semantic-overlay-get (car olsearch) property) + (setq o (cons (car olsearch) o))) + (setq olsearch (cdr olsearch))) + o)) + +(defun semantic-tag-delete-secondary-overlay (tag overlay-or-property) + "Delete from TAG the secondary overlay OVERLAY-OR-PROPERTY. +If OVERLAY-OR-PROPERTY is an overlay, delete that overlay. +If OVERLAY-OR-PROPERTY is a symbol, find the overlay with that property." + (let* ((o overlay-or-property)) + (if (semantic-overlay-p o) + (setq o (list o)) + (setq o (semantic-tag-get-secondary-overlay tag overlay-or-property))) + (while (semantic-overlay-p (car o)) + ;; We don't really need to worry about the hooks. + ;; They will clean themselves up eventually ?? + (semantic--tag-put-property + tag 'secondary-overlays + (delete (car o) (semantic-tag-secondary-overlays tag))) + (semantic-overlay-delete (car o)) + (setq o (cdr o))))) + +(defun semantic--tag-unlink-copy-secondary-overlays (tag) + "Unlink secondary overlays from TAG which is a copy. +This means we don't destroy the overlays, only remove reference +from them in TAG." + (let ((ol (semantic-tag-secondary-overlays tag))) + (while ol + ;; Else, remove all traces of ourself from the tag + ;; Note to self: Does this prevent multiple types of secondary + ;; overlays per tag? + (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays) + (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) + (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) + ;; Next! + (setq ol (cdr ol))) + (semantic--tag-put-property tag 'secondary-overlays nil) + )) + +(defun semantic--tag-unlink-secondary-overlays (tag) + "Unlink secondary overlays from TAG." + (let ((ol (semantic-tag-secondary-overlays tag)) + (nl nil)) + (while ol + (if (semantic-overlay-get (car ol) 'semantic-link-hook) + ;; Only put in a proxy if there is a link-hook. If there is no link-hook + ;; the decorating mode must know when tags are unlinked on its own. + (setq nl (cons (semantic-overlay-get (car ol) 'semantic-link-hook) + nl)) + ;; Else, remove all traces of ourself from the tag + ;; Note to self: Does this prevent multiple types of secondary + ;; overlays per tag? + (semantic-tag-remove-hook tag 'link-hook 'semantic--tag-link-secondary-overlays) + (semantic-tag-remove-hook tag 'unlink-hook 'semantic--tag-unlink-secondary-overlays) + (semantic-tag-remove-hook tag 'unlink-copy-hook 'semantic--tag-unlink-copy-secondary-overlays) + ) + (semantic-overlay-delete (car ol)) + (setq ol (cdr ol))) + (semantic--tag-put-property tag 'secondary-overlays (nreverse nl)) + )) + +(defun semantic--tag-link-secondary-overlays (tag) + "Unlink secondary overlays from TAG." + (let ((ol (semantic-tag-secondary-overlays tag))) + ;; Wipe out old values. + (semantic--tag-put-property tag 'secondary-overlays nil) + ;; Run all the link hooks. + (while ol + (semantic-tag-create-secondary-overlay tag (car ol)) + (setq ol (cdr ol))) + )) + +;;; Secondary Overlay Uses +;; +;; States to put on tags that depend on a secondary overlay. +(defun semantic-set-tag-folded (tag &optional folded) + "Fold TAG, such that only the first line of text is shown. +Optional argument FOLDED should be non-nil to fold the tag. +nil implies the tag should be fully shown." + ;; If they are different, do the deed. + (let ((o (semantic-tag-folded-p tag))) + (if (not folded) + ;; We unfold. + (when o + (semantic-tag-delete-secondary-overlay tag 'semantic-folded)) + (unless o + ;; Add the foldn + (setq o (semantic-tag-create-secondary-overlay tag)) + ;; mark as folded + (semantic-overlay-put o 'semantic-folded t) + ;; Move to cover end of tag + (save-excursion + (goto-char (semantic-tag-start tag)) + (end-of-line) + (semantic-overlay-move o (point) (semantic-tag-end tag))) + ;; We need to modify the invisibility spec for this to + ;; work. + (if (or (eq buffer-invisibility-spec t) + (not (assoc 'semantic-fold buffer-invisibility-spec))) + (add-to-invisibility-spec '(semantic-fold . t))) + (semantic-overlay-put o 'invisible 'semantic-fold) + (overlay-put o 'isearch-open-invisible + 'semantic-set-tag-folded-isearch))) + )) + +(declare-function semantic-current-tag "semantic/find") + +(defun semantic-set-tag-folded-isearch (overlay) + "Called by isearch if it discovers text in the folded region. +OVERLAY is passed in by isearch." + (semantic-set-tag-folded (semantic-current-tag) nil) + ) + +(defun semantic-tag-folded-p (tag) + "Non-nil if TAG is currently folded." + (semantic-tag-get-secondary-overlay tag 'semantic-folded) + ) + +(provide 'semantic/decorate) + +;;; semantic/decorate.el ends here diff --git a/lisp/cedet/semantic/decorate/include.el b/lisp/cedet/semantic/decorate/include.el new file mode 100644 index 00000000000..7acae52a58d --- /dev/null +++ b/lisp/cedet/semantic/decorate/include.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/decorate/mode.el b/lisp/cedet/semantic/decorate/mode.el new file mode 100644 index 00000000000..66c7c1224f8 --- /dev/null +++ b/lisp/cedet/semantic/decorate/mode.el @@ -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 <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; A minor mode for use in decorating tags. +;; +;; There are two types of decorations that can be performed on a tag. +;; You can either highlight the full tag, or you can add an +;; independent decoration on some part of the tag body. +;; +;; For independent decoration in particular, managing them so that they +;; do not get corrupted is challenging. This major mode and +;; corresponding macros will make handling those types of decorations +;; easier. +;; + +;;; Code: +(require 'semantic) +(require 'semantic/decorate) +(require 'semantic/tag-ls) +(require 'semantic/util-modes) + +;;; 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 <value> - specify the default enabled value for NAME. + + +This defines two new overload functions respectively called `NAME-p' +and `NAME-highlight', for which you must provide a default +implementation in respectively the functions `NAME-p-default' and +`NAME-highlight-default'. Those functions are passed a tag. `NAME-p' +must return non-nil to indicate that the tag should be decorated by +`NAME-highlight'. + +To put primary decorations on a tag `NAME-highlight' must use +functions like `semantic-set-tag-face', `semantic-set-tag-intangible', +etc., found in the semantic-decorate library. + +To add other kind of decorations on a tag, `NAME-highlight' must use +`semantic-decorate-tag', and other functions of the semantic +decoration API found in this library." + (let ((predicate (semantic-decorate-style-predicate name)) + (highlighter (semantic-decorate-style-highlighter name)) + (defaultenable (if (plist-member flags :enabled) + (plist-get flags :enabled) + t)) + ) + `(progn + ;; Clear the menu cache so that new items are added when + ;; needed. + (setq semantic-decoration-menu-cache nil) + ;; Create an override method to specify if a given tag belongs + ;; to this type of decoration + (define-overloadable-function ,predicate (tag) + ,(format "Return non-nil to decorate TAG with `%s' style.\n%s" + name doc)) + ;; Create an override method that will perform the highlight + ;; operation if the -p method returns non-nil. + (define-overloadable-function ,highlighter (tag) + ,(format "Decorate TAG with `%s' style.\n%s" + name doc)) + ;; Add this to the list of primary decoration modes. + (add-to-list 'semantic-decoration-styles + (cons ',(symbol-name name) + ,defaultenable)) + ))) + +;;; 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 --git a/lisp/cedet/semantic/dep.el b/lisp/cedet/semantic/dep.el new file mode 100644 index 00000000000..d4b17744d06 --- /dev/null +++ b/lisp/cedet/semantic/dep.el @@ -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 <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/doc.el b/lisp/cedet/semantic/doc.el new file mode 100644 index 00000000000..9feeee294f6 --- /dev/null +++ b/lisp/cedet/semantic/doc.el @@ -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 <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; It is good practice to write documenation for your functions and +;; variables. These core routines deal with these documentation +;; comments or strings. They can exist either as a tag property +;; (:documentation) or as a comment just before the symbol, or after +;; the symbol on the same line. + +(require 'semantic/tag) + +;;; Code: + +;;;###autoload +(define-overloadable-function semantic-documentation-for-tag (&optional tag nosnarf) + "Find documentation from TAG and return it as a clean string. +TAG might have DOCUMENTATION set in it already. If not, there may be +some documentation in a comment preceding TAG's definition which we +can look for. When appropriate, this can be overridden by a language specific +enhancement. +Optional argument NOSNARF means to only return the lexical analyzer token for it. +If nosnarf if 'lex, then only return the lex token." + (if (not tag) (setq tag (semantic-current-tag))) + (save-excursion + (when (semantic-tag-with-position-p tag) + (set-buffer (semantic-tag-buffer tag))) + (:override + ;; No override. Try something simple to find documentation nearby + (save-excursion + (semantic-go-to-tag tag) + (let ((doctmp (semantic-tag-docstring tag (current-buffer)))) + (or + ;; Is there doc in the tag??? + doctmp + ;; Check just before the definition. + (when (semantic-tag-with-position-p tag) + (semantic-documentation-comment-preceeding-tag tag nosnarf)) + ;; Lets look for comments either after the definition, but before code: + ;; Not sure yet. Fill in something clever later.... + nil)))))) + +(defun semantic-documentation-comment-preceeding-tag (&optional tag nosnarf) + "Find a comment preceeding TAG. +If TAG is nil. use the tag under point. +Searches the space between TAG and the preceeding tag for a comment, +and converts the comment into clean documentation. +Optional argument NOSNARF with a value of 'lex means to return +just the lexical token and not the string." + (if (not tag) (setq tag (semantic-current-tag))) + (save-excursion + ;; Find this tag. + (semantic-go-to-tag tag) + (let* ((starttag (semantic-find-tag-by-overlay-prev + (semantic-tag-start tag))) + (start (if starttag + (semantic-tag-end starttag) + (point-min)))) + (when (re-search-backward comment-start-skip start t) + ;; We found a comment that doesn't belong to the body + ;; of a function. + (semantic-doc-snarf-comment-for-tag nosnarf))) + )) + +(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 --git a/lisp/cedet/semantic/ede-grammar.el b/lisp/cedet/semantic/ede-grammar.el new file mode 100644 index 00000000000..c23b489c837 --- /dev/null +++ b/lisp/cedet/semantic/ede-grammar.el @@ -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 <zappo@gnu.org> +;; Keywords: project, make + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Handle .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 --git a/lisp/cedet/semantic/edit.el b/lisp/cedet/semantic/edit.el new file mode 100644 index 00000000000..cb573e35c1e --- /dev/null +++ b/lisp/cedet/semantic/edit.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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 --git a/lisp/cedet/semantic/find.el b/lisp/cedet/semantic/find.el new file mode 100644 index 00000000000..9886685cb5d --- /dev/null +++ b/lisp/cedet/semantic/find.el @@ -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 <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Routines for searching through lists of tags. +;; There are several groups of tag search routines: +;; +;; 1) semantic-brute-find-tag-by-* +;; These routines use brute force hierarchical search to scan +;; through lists of tags. They include some parameters +;; used for compatibility with the semantic 1.x search routines. +;; +;; 1.5) semantic-brute-find-first-tag-by-* +;; Like 1, except seraching stops on the first match for the given +;; information. +;; +;; 2) semantic-find-tag-by-* +;; These prefered search routines attempt to scan through lists +;; in an intelligent way based on questions asked. +;; +;; 3) semantic-find-*-overlay +;; These routines use overlays to return tags based on a buffer position. +;; +;; 4) ... + +;;; Code: + +(require 'semantic) +(require 'semantic/tag) + +(declare-function semantic-tag-protected-p "semantic/tag-ls") + +;;; 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 --git a/lisp/cedet/semantic/format.el b/lisp/cedet/semantic/format.el new file mode 100644 index 00000000000..13945931b3f --- /dev/null +++ b/lisp/cedet/semantic/format.el @@ -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 <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Once a language file has been parsed into a TAG, it is often useful +;; then display that tag information in browsers, completion engines, or +;; help routines. The functions and setup in this file provide ways +;; to reformat a tag into different standard output types. +;; +;; In addition, macros for setting up customizable variables that let +;; the user choose their default format type are also provided. +;; + +;;; Code: +(eval-when-compile (require 'font-lock)) +(require 'semantic) +(require 'semantic/tag-ls) +(require 'ezimage) + +(eval-when-compile (require 'semantic/find)) + +;;; Tag to text overload functions +;; +;; abbreviations, prototypes, and coloring support. +(defvar semantic-format-tag-functions + '(semantic-format-tag-name + semantic-format-tag-canonical-name + semantic-format-tag-abbreviate + semantic-format-tag-summarize + semantic-format-tag-summarize-with-file + semantic-format-tag-short-doc + semantic-format-tag-prototype + semantic-format-tag-concise-prototype + semantic-format-tag-uml-abbreviate + semantic-format-tag-uml-prototype + semantic-format-tag-uml-concise-prototype + semantic-format-tag-prin1 + ) + "List of functions which convert a tag to text. +Each function must take the parameters TAG &optional PARENT COLOR. +TAG is the tag to convert. +PARENT is a parent tag or name which refers to the structure +or class which contains TAG. PARENT is NOT a class which a TAG +would claim as a parent. +COLOR indicates that the generated text should be colored using +`font-lock'.") + +(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 --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el new file mode 100644 index 00000000000..9f9bcaaea23 --- /dev/null +++ b/lisp/cedet/semantic/fw.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic has several core features shared across it's lex/parse/util +;; stages. This used to clutter semantic.el some. These routines are all +;; simple things that are not parser specific, but aid in making +;; semantic flexible and compatible amongst different Emacs platforms. + +;;; Code: +;; +(require 'mode-local) +(require 'eieio) +(require 'semantic/loaddefs) + +;;; Compatibility + +(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 --git a/lisp/cedet/semantic/grammar-wy.el b/lisp/cedet/semantic/grammar-wy.el new file mode 100644 index 00000000000..ae1aec7b466 --- /dev/null +++ b/lisp/cedet/semantic/grammar-wy.el @@ -0,0 +1,478 @@ +;;; semantic/grammar-wy.el --- Generated parser support file + +;; Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc. + +;; Author: David Ponce <david@dponce.com> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; 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>-sexp-analyzer + "sexp analyzer for <sexp> tokens." + "\\=" + 'SEXP) + +(define-lex-sexp-type-analyzer semantic-grammar-wy--<qlist>-sexp-analyzer + "sexp analyzer for <qlist> tokens." + "\\s'\\s-*(" + 'PREFIXED_LIST) + +(define-lex-keyword-type-analyzer semantic-grammar-wy--<keyword>-keyword-analyzer + "keyword analyzer for <keyword> tokens." + "\\(\\sw\\|\\s_\\)+") + +(define-lex-block-type-analyzer semantic-grammar-wy--<block>-block-analyzer + "block analyzer for <block> tokens." + "\\s(\\|\\s)" + '((("(" LPAREN PAREN_BLOCK) + ("{" LBRACE BRACE_BLOCK)) + (")" RPAREN) + ("}" RBRACE)) + ) + +(define-lex-regex-type-analyzer semantic-grammar-wy--<char>-regexp-analyzer + "regexp analyzer for <char> tokens." + semantic-grammar-lex-c-char-re + nil + 'CHARACTER) + +(define-lex-sexp-type-analyzer semantic-grammar-wy--<string>-sexp-analyzer + "sexp analyzer for <string> tokens." + "\\s\"" + 'STRING) + +(define-lex-regex-type-analyzer semantic-grammar-wy--<symbol>-regexp-analyzer + "regexp analyzer for <symbol> tokens." + ":?\\(\\sw\\|\\s_\\)+" + '((PERCENT_PERCENT . "\\`%%\\'")) + 'SYMBOL) + +(define-lex-string-type-analyzer semantic-grammar-wy--<punctuation>-string-analyzer + "string analyzer for <punctuation> tokens." + "\\(\\s.\\|\\s$\\|\\s'\\)+" + '((GT . ">") + (LT . "<") + (OR . "|") + (SEMI . ";") + (COLON . ":")) + 'punctuation) + +(provide 'semantic/grammar-wy) + +;;; semantic/grammar-wy.el ends here diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el new file mode 100644 index 00000000000..f47275bdcf6 --- /dev/null +++ b/lisp/cedet/semantic/grammar.el @@ -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 <david@dponce.com> +;; Maintainer: David Ponce <david@dponce.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Major mode framework for editing Semantic's input grammar files. + +;;; History: +;; + +;;; Code: + +(require 'semantic) +(require 'semantic/ctxt) +(require 'semantic/format) +(require 'semantic/grammar-wy) +(require 'semantic/idle) +(declare-function semantic-momentary-highlight-tag "semantic/decorate") +(declare-function semantic-analyze-context "semantic/analyze") +(declare-function semantic-analyze-tags-of-class-list + "semantic/analyze/complete") + +(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>-keyword-analyzer + semantic-grammar-wy--<symbol>-regexp-analyzer + semantic-grammar-wy--<char>-regexp-analyzer + semantic-grammar-wy--<string>-sexp-analyzer + ;; Must detect comments after strings because `comment-start-skip' + ;; regexp match semicolons inside strings! + semantic-lex-ignore-comments + ;; Must detect prefixed list before punctuation because prefix chars + ;; are also punctuations! + semantic-grammar-wy--<qlist>-sexp-analyzer + ;; Must detect punctuations after comments because the semicolon can + ;; be a punctuation or a comment start! + semantic-grammar-wy--<punctuation>-string-analyzer + semantic-grammar-wy--<block>-block-analyzer + semantic-grammar-wy--<sexp>-sexp-analyzer) + +;;; Test the lexer +;; +(defun semantic-grammar-lex-buffer () + "Run `semantic-grammar-lex' on current buffer." + (interactive) + (semantic-lex-init) + (setq semantic-lex-analyzer 'semantic-grammar-lexer) + (let ((token-stream + (semantic-lex (point-min) (point-max)))) + (with-current-buffer (get-buffer-create "*semantic-grammar-lex*") + (erase-buffer) + (pp token-stream (current-buffer)) + (goto-char (point-min)) + (pop-to-buffer (current-buffer))))) + +;;;; +;;;; 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 <type> symbol +and DEFS is an alist of (TOKEN . VALUE). TOKEN is the terminal symbol +identifying the token and VALUE is the string value of the token or +nil." + (let (tags alist assoc tag type term names value) + + ;; Check for <type> in %left, %right & %nonassoc declarations + (setq tags (semantic-find-tags-by-class + 'assoc (current-buffer))) + (while tags + (setq tag (car tags) + tags (cdr tags)) + (when (setq type (semantic-tag-type tag)) + (setq names (semantic-tag-get-attribute tag :value) + assoc (assoc type alist)) + (or assoc (setq assoc (list type) + alist (cons assoc alist))) + (while names + (setq term (car names) + names (cdr names)) + (or (string-match semantic-grammar-lex-c-char-re term) + (setcdr assoc (cons (list (intern term)) + (cdr assoc))))))) + + ;; Then process %token declarations so they can override any + ;; previous specifications + (setq tags (semantic-find-tags-by-class + 'token (current-buffer))) + (while tags + (setq tag (car tags) + tags (cdr tags)) + (setq names (cons (semantic-tag-name tag) + (semantic-tag-get-attribute tag :rest)) + type (or (semantic-tag-type tag) "<no-type>") + value (semantic-tag-get-attribute tag :value) + assoc (assoc type alist)) + (or assoc (setq assoc (list type) + alist (cons assoc alist))) + (while names + (setq term (intern (car names)) + names (cdr names)) + (setcdr assoc (cons (cons term value) (cdr assoc))))) + alist)) + +(defun semantic-grammar-token-%type-properties (&optional props) + "Return properties set by %type statements. +This declare a new type if necessary. +If optional argument PROPS is non-nil, it is an existing list of +properties where to add new properties." + (let (type) + (dolist (tag (semantic-find-tags-by-class 'type (current-buffer))) + (setq type (semantic-tag-name tag)) + ;; Indicate to auto-generate the analyzer for this type + (push (list type :declared t) props) + (dolist (e (semantic-tag-get-attribute tag :value)) + (push (list type (intern (car e)) (read (or (cdr e) "nil"))) + props))) + props)) + +(defun semantic-grammar-token-%put-properties (tokens) + "For types found in TOKENS, return properties set by %put statements." + (let (found props) + (dolist (put (semantic-find-tags-by-class 'put (current-buffer))) + (dolist (type (cons (semantic-tag-name put) + (semantic-tag-get-attribute put :rest))) + (setq found (assoc type tokens)) + (if (null found) + nil ;; %put <type> ignored, no token defined + (setq type (car found)) + (dolist (e (semantic-tag-get-attribute put :value)) + (push (list type (intern (car e)) (read (or (cdr e) "nil"))) + props))))) + props)) + +(defsubst semantic-grammar-token-properties (tokens) + "Return properties of declared types. +Types are explicitly declared by %type statements. Types found in +TOKENS are those declared implicitly by %token statements. +Properties can be set by %put and %type statements. +Properties set by %type statements take precedence over those set by +%put statements." + (let ((props (semantic-grammar-token-%put-properties tokens))) + (semantic-grammar-token-%type-properties props))) + +(defun semantic-grammar-use-macros () + "Return macro definitions from %use-macros statements. +Also load the specified macro libraries." + (let (lib defs) + (dolist (tag (semantic-find-tags-by-class 'macro (current-buffer))) + (setq lib (intern (semantic-tag-type tag))) + (condition-case nil + ;;(load lib) ;; Be sure to use the latest macro library. + (require lib) + (error nil)) + (dolist (mac (semantic-tag-get-attribute tag :value)) + (push (cons (intern mac) + (intern (format "%s-%s" lib mac))) + defs))) + (nreverse defs))) + +(defvar semantic-grammar-macros nil + "List of associations (MACRO-NAME . EXPANDER).") +(make-variable-buffer-local 'semantic-grammar-macros) + +(defun semantic-grammar-macros () + "Build and return the alist of defined macros." + (append + ;; Definitions found in tags. + (semantic-grammar-use-macros) + ;; Other pre-installed definitions. + semantic-grammar-macros)) + +;;;; +;;;; 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)) + ("\\<error\\>" + 0 (unless (semantic-grammar-in-lisp-p) 'bold)) + ("^\\(\\(\\sw\\|\\s_\\)+\\)[ \n\r\t]*:" + 1 font-lock-function-name-face) + (semantic--grammar-macros-matcher + 1 ,(if (boundp 'font-lock-builtin-face) + 'font-lock-builtin-face + 'font-lock-preprocessor-face)) + ("\\$\\(\\sw\\|\\s_\\)*" + 0 font-lock-variable-name-face) + ("<\\(\\(\\sw\\|\\s_\\)+\\)>" + 1 font-lock-type-face) + (,semantic-grammar-lex-c-char-re + 0 ,(if (boundp 'font-lock-constant-face) + 'font-lock-constant-face + 'font-lock-string-face) t) + ;; Must highlight :keyword here, because ':' is a punctuation in + ;; grammar mode! + ("[\r\n\t ]+:\\sw+\\>" + 0 font-lock-builtin-face) + ;; ;; Append the Semantic keywords + ;; ,@semantic-fw-font-lock-keywords + ) + "Font Lock keywords used to highlight Semantic grammar buffers.") + +(defvar semantic-grammar-mode-keywords-2 + (append semantic-grammar-mode-keywords-1 + lisp-font-lock-keywords-1) + "Font Lock keywords used to highlight Semantic grammar buffers.") + +(defvar semantic-grammar-mode-keywords-3 + (append semantic-grammar-mode-keywords-1 + lisp-font-lock-keywords-2) + "Font Lock keywords used to highlight Semantic grammar buffers.") + +(defvar semantic-grammar-mode-keywords + semantic-grammar-mode-keywords-1 + "Font Lock keywords used to highlight Semantic grammar buffers.") + +(defvar semantic-grammar-map + (let ((km (make-sparse-keymap))) + + (define-key km "|" 'semantic-grammar-electric-punctuation) + (define-key km ";" 'semantic-grammar-electric-punctuation) + (define-key km "%" 'semantic-grammar-electric-punctuation) + (define-key km "(" 'semantic-grammar-electric-punctuation) + (define-key km ")" 'semantic-grammar-electric-punctuation) + (define-key km ":" 'semantic-grammar-electric-punctuation) + + (define-key km "\t" 'semantic-grammar-indent) + (define-key km "\M-\t" 'semantic-grammar-complete) + (define-key km "\C-c\C-c" 'semantic-grammar-create-package) + (define-key km "\C-cm" 'semantic-grammar-find-macro-expander) + (define-key km "\C-cik" 'semantic-grammar-insert-keyword) +;; (define-key km "\C-cc" 'semantic-grammar-generate-and-load) +;; (define-key km "\C-cr" 'semantic-grammar-generate-one-rule) + + km) + "Keymap used in `semantic-grammar-mode'.") + +(defvar semantic-grammar-menu + '("Grammar" + ["Indent Line" semantic-grammar-indent] + ["Complete Symbol" semantic-grammar-complete] + ["Find Macro" semantic-grammar-find-macro-expander] + "--" + ["Insert %keyword" semantic-grammar-insert-keyword] + "--" + ["Update Lisp Package" semantic-grammar-create-package] + ["Recreate Lisp Package" semantic-grammar-recreate-package] + ) + "Common semantic grammar menu.") + +(defun semantic-grammar-setup-menu-emacs (symbol mode-menu) + "Setup a GNU Emacs grammar menu in variable SYMBOL. +MODE-MENU is an optional specific menu whose items are appended to the +common grammar menu." + (let ((items (make-symbol "items"))) + `(unless (boundp ',symbol) + (easy-menu-define ,symbol (current-local-map) + "Grammar Menu" semantic-grammar-menu) + (let ((,items (cdr ,mode-menu))) + (when ,items + (easy-menu-add-item ,symbol nil "--") + (while ,items + (easy-menu-add-item ,symbol nil (car ,items)) + (setq ,items (cdr ,items)))))) + )) + +(defun semantic-grammar-setup-menu-xemacs (symbol mode-menu) + "Setup an XEmacs grammar menu in variable SYMBOL. +MODE-MENU is an optional specific menu whose items are appended to the +common grammar menu." + (let ((items (make-symbol "items")) + (path (make-symbol "path"))) + `(progn + (unless (boundp ',symbol) + (easy-menu-define ,symbol nil + "Grammar Menu" (copy-sequence semantic-grammar-menu))) + (easy-menu-add ,symbol) + (let ((,items (cdr ,mode-menu)) + (,path (list (car ,symbol)))) + (when ,items + (easy-menu-add-item nil ,path "--") + (while ,items + (easy-menu-add-item nil ,path (car ,items)) + (setq ,items (cdr ,items)))))) + )) + +(defmacro semantic-grammar-setup-menu (&optional mode-menu) + "Setup a mode local grammar menu. +MODE-MENU is an optional specific menu whose items are appended to the +common grammar menu." + (let ((menu (intern (format "%s-menu" major-mode)))) + (if (featurep 'xemacs) + (semantic-grammar-setup-menu-xemacs menu mode-menu) + (semantic-grammar-setup-menu-emacs menu mode-menu)))) + +(defsubst semantic-grammar-in-lisp-p () + "Return non-nil if point is in Lisp code." + (or (>= (point) (semantic-grammar-epilogue-start)) + (condition-case nil + (save-excursion + (up-list -1) + t) + (error nil)))) + +(defun semantic-grammar-edits-new-change-hook-fcn (overlay) + "Function set into `semantic-edits-new-change-hook'. +Argument OVERLAY is the overlay created to mark the change. +When OVERLAY marks a change in the scope of a nonterminal tag extend +the change bounds to encompass the whole nonterminal tag." + (let ((outer (car (semantic-find-tag-by-overlay-in-region + (semantic-edits-os overlay) + (semantic-edits-oe overlay))))) + (if (semantic-tag-of-class-p outer 'nonterminal) + (semantic-overlay-move overlay + (semantic-tag-start outer) + (semantic-tag-end outer))))) + +(defun semantic-grammar-mode () + "Initialize a buffer for editing Semantic grammars. + +\\{semantic-grammar-map}" + (interactive) + (kill-all-local-variables) + (setq major-mode 'semantic-grammar-mode + mode-name "Semantic Grammar Framework") + (set (make-local-variable 'parse-sexp-ignore-comments) t) + (set (make-local-variable 'comment-start) ";;") + ;; Look within the line for a ; following an even number of backslashes + ;; after either a non-backslash or the line beginning. + (set (make-local-variable 'comment-start-skip) + "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + (set-syntax-table semantic-grammar-syntax-table) + (use-local-map semantic-grammar-map) + (set (make-local-variable 'indent-line-function) + 'semantic-grammar-indent) + (set (make-local-variable 'fill-paragraph-function) + 'lisp-fill-paragraph) + (set (make-local-variable 'font-lock-multiline) + 'undecided) + (set (make-local-variable 'font-lock-defaults) + '((semantic-grammar-mode-keywords + semantic-grammar-mode-keywords-1 + semantic-grammar-mode-keywords-2 + semantic-grammar-mode-keywords-3) + nil ;; perform string/comment fontification + nil ;; keywords are case sensitive. + ;; This puts _ & - as a word constituant, + ;; simplifying our keywords significantly + ((?_ . "w") (?- . "w")))) + ;; Setup Semantic to parse grammar + (semantic-grammar-wy--install-parser) + (setq semantic-lex-comment-regex ";;" + semantic-lex-analyzer 'semantic-grammar-lexer + semantic-type-relation-separator-character '(":") + semantic-symbol->name-assoc-list + '( + (code . "Setup Code") + (keyword . "Keyword") + (token . "Token") + (nonterminal . "Nonterminal") + (rule . "Rule") + )) + (set (make-local-variable 'semantic-format-face-alist) + '( + (code . default) + (keyword . font-lock-keyword-face) + (token . font-lock-type-face) + (nonterminal . font-lock-function-name-face) + (rule . default) + )) + (set (make-local-variable 'semantic-stickyfunc-sticky-classes) + '(nonterminal)) + ;; Before each change, clear the cached regexp used to highlight + ;; macros local in this grammar. + (semantic-make-local-hook 'before-change-functions) + (add-hook 'before-change-functions + 'semantic--grammar-clear-macros-regexp-2 nil t) + ;; Handle safe re-parse of grammar rules. + (semantic-make-local-hook 'semantic-edits-new-change-hooks) + (add-hook 'semantic-edits-new-change-hooks + 'semantic-grammar-edits-new-change-hook-fcn + nil t) + (semantic-run-mode-hooks 'semantic-grammar-mode-hook)) + +;;;; +;;;; Useful commands +;;;; + +(defvar semantic-grammar-skip-quoted-syntax-table + (let ((st (copy-syntax-table semantic-grammar-syntax-table))) + (modify-syntax-entry ?\' "$" st) + st) + "Syntax table to skip a whole quoted expression in grammar code. +Consider quote as a \"paired delimiter\", so `forward-sexp' will skip +whole quoted expression.") + +(defsubst semantic-grammar-backward-item () + "Move point to beginning of the previous grammar item." + (forward-comment (- (point-max))) + (if (zerop (skip-syntax-backward ".")) + (if (eq (char-before) ?\') + (with-syntax-table + ;; Can't be Lisp code here! Temporarily consider quote + ;; as a "paired delimiter", so `forward-sexp' can skip + ;; the whole quoted expression. + semantic-grammar-skip-quoted-syntax-table + (forward-sexp -1)) + (forward-sexp -1)))) + +(defun semantic-grammar-anchored-indentation () + "Return indentation based on previous anchor character found." + (let (indent) + (save-excursion + (while (not indent) + (semantic-grammar-backward-item) + (cond + ((bobp) + (setq indent 0)) + ((looking-at ":\\(\\s-\\|$\\)") + (setq indent (current-column)) + (forward-char) + (skip-syntax-forward "-") + (if (eolp) (setq indent 2)) + ) + ((and (looking-at "[;%]") + (not (looking-at "\\<%prec\\>"))) + (setq indent 0) + )))) + indent)) + +(defun semantic-grammar-do-grammar-indent () + "Indent a line of grammar. +When called the point is not in Lisp code." + (let (indent n) + (save-excursion + (beginning-of-line) + (skip-syntax-forward "-") + (setq indent (current-column)) + (cond + ((or (bobp) + (looking-at "\\(\\w\\|\\s_\\)+\\s-*:") + (and (looking-at "%") + (not (looking-at "%prec\\>")))) + (setq n 0)) + ((looking-at ":") + (setq n 2)) + ((and (looking-at ";;") + (save-excursion (forward-comment (point-max)) + (looking-at ":"))) + (setq n 1)) + (t + (setq n (semantic-grammar-anchored-indentation)) + (unless (zerop n) + (cond + ((looking-at ";;") + (setq n (1- n))) + ((looking-at "[|;]") + ) + (t + (setq n (+ n 2))))))) + (when (/= n indent) + (beginning-of-line) + (delete-horizontal-space) + (indent-to n))))) + +(defvar semantic-grammar-brackets-as-parens-syntax-table + (let ((st (copy-syntax-table emacs-lisp-mode-syntax-table))) + (modify-syntax-entry ?\{ "(} " st) + (modify-syntax-entry ?\} "){ " st) + st) + "Syntax table that consider brackets as parenthesis. +So `lisp-indent-line' will work inside bracket blocks.") + +(defun semantic-grammar-do-lisp-indent () + "Maybe run the Emacs Lisp indenter on a line of code. +Return nil if not in a Lisp expression." + (condition-case nil + (save-excursion + (beginning-of-line) + (skip-chars-forward "\t ") + (let ((first (point))) + (or (>= first (semantic-grammar-epilogue-start)) + (up-list -1)) + (condition-case nil + (while t + (up-list -1)) + (error nil)) + (beginning-of-line) + (save-restriction + (narrow-to-region (point) first) + (goto-char (point-max)) + (with-syntax-table + ;; Temporarily consider brackets as parenthesis so + ;; `lisp-indent-line' can indent Lisp code inside + ;; brackets. + semantic-grammar-brackets-as-parens-syntax-table + (lisp-indent-line)))) + t) + (error nil))) + +(defun semantic-grammar-indent () + "Indent the current line. +Use the Lisp or grammar indenter depending on point location." + (interactive) + (let ((orig (point)) + first) + (or (semantic-grammar-do-lisp-indent) + (semantic-grammar-do-grammar-indent)) + (setq first (save-excursion + (beginning-of-line) + (skip-chars-forward "\t ") + (point))) + (if (or (< orig first) (/= orig (point))) + (goto-char first)))) + +(defun semantic-grammar-electric-punctuation () + "Insert and reindent for the symbol just typed in." + (interactive) + (self-insert-command 1) + (save-excursion + (semantic-grammar-indent))) + +(defun semantic-grammar-complete () + "Attempt to complete the symbol under point. +Completion is position sensitive. If the cursor is in a match section of +a rule, then nonterminals symbols are scanned. If the cursor is in a Lisp +expression then Lisp symbols are completed." + (interactive) + (if (semantic-grammar-in-lisp-p) + ;; We are in lisp code. Do lisp completion. + (lisp-complete-symbol) + ;; We are not in lisp code. Do rule completion. + (let* ((nonterms (semantic-find-tags-by-class 'nonterminal (current-buffer))) + (sym (car (semantic-ctxt-current-symbol))) + (ans (try-completion sym nonterms))) + (cond ((eq ans t) + ;; All done + (message "Symbols is already complete")) + ((and (stringp ans) (string= ans sym)) + ;; Max matchable. Show completions. + (with-output-to-temp-buffer "*Completions*" + (display-completion-list (all-completions sym nonterms))) + ) + ((stringp ans) + ;; Expand the completions + (forward-sexp -1) + (delete-region (point) (progn (forward-sexp 1) (point))) + (insert ans)) + (t (message "No Completions.")) + )) + )) + +(defun semantic-grammar-insert-keyword (name) + "Insert a new %keyword declaration with NAME. +Assumes it is typed in with the correct casing." + (interactive "sKeyword: ") + (if (not (bolp)) (insert "\n")) + (insert "%keyword " (upcase name) " \"" name "\" +%put " (upcase name) " summary +\"\"\n") + (forward-char -2)) + +;;; Macro facilities +;; + +(defsubst semantic--grammar-macro-function-tag (name) + "Search for a function tag for the grammar macro with name NAME. +Return the tag found or nil if not found." + (car (semantic-find-tags-by-class + 'function + (or (semantic-find-tags-by-name name (current-buffer)) + (and (featurep 'semanticdb) + semanticdb-current-database + (cdar (semanticdb-find-tags-by-name name nil t))))))) + +(defsubst semantic--grammar-macro-lib-part (def) + "Return the library part of the grammar macro defined by DEF." + (let ((suf (format "-%s\\'" (regexp-quote (symbol-name (car def))))) + (fun (symbol-name (cdr def)))) + (substring fun 0 (string-match suf fun)))) + +(defun semantic--grammar-macro-compl-elt (def &optional full) + "Return a completion entry for the grammar macro defined by DEF. +If optional argument FULL is non-nil qualify the macro name with the +library found in DEF." + (let ((mac (car def)) + (lib (semantic--grammar-macro-lib-part def))) + (cons (if full + (format "%s/%s" mac lib) + (symbol-name mac)) + (list mac lib)))) + +(defun semantic--grammar-macro-compl-dict () + "Return a completion dictionnary of macro definitions." + (let ((defs (semantic-grammar-macros)) + def dups dict) + (while defs + (setq def (car defs) + defs (cdr defs)) + (if (or (assoc (car def) defs) (assoc (car def) dups)) + (push def dups) + (push (semantic--grammar-macro-compl-elt def) dict))) + (while dups + (setq def (car dups) + dups (cdr dups)) + (push (semantic--grammar-macro-compl-elt def t) dict)) + dict)) + +(defun semantic-grammar-find-macro-expander (macro-name library) + "Visit the Emacs Lisp library where a grammar macro is implemented. +MACRO-NAME is a symbol that identifies a grammar macro. +LIBRARY is the name (sans extension) of the Emacs Lisp library where +to start searching the macro implementation. Lookup in included +libraries, if necessary. +Find a function tag (in current tags table) whose name contains MACRO-NAME. +Select the buffer containing the tag's definition, and move point there." + (interactive + (let* ((dic (semantic--grammar-macro-compl-dict)) + (def (assoc (completing-read "Macro: " dic nil 1) dic))) + (or (cdr def) '(nil nil)))) + (when (and macro-name library) + (let* ((lib (format "%s.el" library)) + (buf (find-file-noselect (or (locate-library lib t) lib))) + (tag (with-current-buffer buf + (semantic--grammar-macro-function-tag + (format "%s-%s" library macro-name))))) + (if tag + (progn + (require 'semantic/decorate) + (pop-to-buffer (semantic-tag-buffer tag)) + (goto-char (semantic-tag-start tag)) + (semantic-momentary-highlight-tag tag)) + (pop-to-buffer buf) + (message "No expander found in library %s for macro %s" + library macro-name))))) + +;;; Additional help +;; + +(defvar semantic-grammar-syntax-help + `( + ;; Lexical Symbols + ("symbol" . "Syntax: A symbol of alpha numeric and symbol characters") + ("number" . "Syntax: Numeric characters.") + ("punctuation" . "Syntax: Punctuation character.") + ("semantic-list" . "Syntax: A list delimited by any valid list characters") + ("open-paren" . "Syntax: Open Parenthesis character") + ("close-paren" . "Syntax: Close Parenthesis character") + ("string" . "Syntax: String character delimited text") + ("comment" . "Syntax: Comment character delimited text") + ;; Special Macros + ("EMPTY" . "Syntax: Match empty text") + ("ASSOC" . "Lambda Key: (ASSOC key1 value1 key2 value2 ...)") + ("EXPAND" . "Lambda Key: (EXPAND <list id> <rule>)") + ("EXPANDFULL" . "Lambda Key: (EXPANDFULL <list id> <rule>)") + ;; Tag Generator Macros + ("TAG" . "Generic Tag Generation: (TAG <name> <tag-class> [ :key value ]*)") + ("VARIABLE-TAG" . "(VARIABLE-TAG <name> <lang-type> <default-value> [ :key value ]*)") + ("FUNCTION-TAG" . "(FUNCTION-TAG <name> <lang-type> <arg-list> [ :key value ]*)") + ("TYPE-TAG" . "(TYPE-TAG <name> <lang-type> <part-list> <parents> [ :key value ]*)") + ("INCLUDE-TAG" . "(INCLUDE-TAG <name> <system-flag> [ :key value ]*)") + ("PACKAGE-TAG" . "(PACKAGE-TAG <name> <detail> [ :key value ]*)") + ("CODE-TAG" . "(CODE-TAG <name> <detail> [ :key value ]*)") + ("ALIAS-TAG" . "(ALIAS-TAG <name> <aliasclass> <definition> [:key value]*)") + ;; Special value macros + ("$1" . "Match Value: Value from match list in slot 1") + ("$2" . "Match Value: Value from match list in slot 2") + ("$3" . "Match Value: Value from match list in slot 3") + ("$4" . "Match Value: Value from match list in slot 4") + ("$5" . "Match Value: Value from match list in slot 5") + ("$6" . "Match Value: Value from match list in slot 6") + ("$7" . "Match Value: Value from match list in slot 7") + ("$8" . "Match Value: Value from match list in slot 8") + ("$9" . "Match Value: Value from match list in slot 9") + ;; Same, but with annoying , in front. + (",$1" . "Match Value: Value from match list in slot 1") + (",$2" . "Match Value: Value from match list in slot 2") + (",$3" . "Match Value: Value from match list in slot 3") + (",$4" . "Match Value: Value from match list in slot 4") + (",$5" . "Match Value: Value from match list in slot 5") + (",$6" . "Match Value: Value from match list in slot 6") + (",$7" . "Match Value: Value from match list in slot 7") + (",$8" . "Match Value: Value from match list in slot 8") + (",$9" . "Match Value: Value from match list in slot 9") + ) + "Association of syntax elements, and the corresponding help.") + +(defun semantic-grammar-eldoc-get-macro-docstring (macro expander) + "Return a one-line docstring for the given grammar MACRO. +EXPANDER is the name of the function that expands MACRO." + (require 'eldoc) + (if (and (eq expander (aref eldoc-last-data 0)) + (eq 'function (aref eldoc-last-data 2))) + (aref eldoc-last-data 1) + (let ((doc (help-split-fundoc (documentation expander t) expander))) + (cond + (doc + (setq doc (car doc)) + (string-match "\\`[^ )]* ?" doc) + (setq doc (concat "(" (substring doc (match-end 0))))) + (t + (setq doc (eldoc-function-argstring expander)))) + (when doc + (setq doc + (eldoc-docstring-format-sym-doc + macro (format "==> %s %s" expander doc) 'default)) + (eldoc-last-data-store expander doc 'function)) + doc))) + +(define-mode-local-override semantic-idle-summary-current-symbol-info + semantic-grammar-mode () + "Display additional eldoc information about grammar syntax elements. +Syntax element is the current symbol at point. +If it is associated a help string in `semantic-grammar-syntax-help', +return that string. +If it is a macro name, return a description of the associated expander +function parameter list. +If it is a function name, return a description of this function +parameter list. +It it is a variable name, return a brief (one-line) documentation +string for the variable. +If a default description of the current context can be obtained, +return it. +Otherwise return nil." + (require 'eldoc) + (let* ((elt (car (semantic-ctxt-current-symbol))) + (val (and elt (cdr (assoc elt semantic-grammar-syntax-help))))) + (when (and (not val) elt (semantic-grammar-in-lisp-p)) + ;; Ensure to load macro definitions before doing `intern-soft'. + (setq val (semantic-grammar-macros) + elt (intern-soft elt) + val (and elt (cdr (assq elt val)))) + (cond + ;; Grammar macro + ((and val (fboundp val)) + (setq val (semantic-grammar-eldoc-get-macro-docstring elt val))) + ;; Function + ((and elt (fboundp elt)) + (setq val (eldoc-get-fnsym-args-string elt))) + ;; Variable + ((and elt (boundp elt)) + (setq val (eldoc-get-var-docstring elt))) + (t nil))) + (or val (semantic-idle-summary-current-symbol-info-default)))) + +(define-mode-local-override semantic-tag-boundary-p + semantic-grammar-mode (tag) + "Return non-nil for tags that should have a boundary drawn. +Only tags of type 'nonterminal will be so marked." + (let ((c (semantic-tag-class tag))) + (eq c 'nonterminal))) + +(define-mode-local-override semantic-ctxt-current-function + semantic-grammar-mode (&optional point) + "Determine the name of the current function at POINT." + (save-excursion + (and point (goto-char point)) + (when (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-ctxt-current-function))))) + +(define-mode-local-override semantic-ctxt-current-argument + semantic-grammar-mode (&optional point) + "Determine the argument index of the called function at POINT." + (save-excursion + (and point (goto-char point)) + (when (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-ctxt-current-argument))))) + +(define-mode-local-override semantic-ctxt-current-assignment + semantic-grammar-mode (&optional point) + "Determine the tag being assigned into at POINT." + (save-excursion + (and point (goto-char point)) + (when (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-ctxt-current-assignment))))) + +(define-mode-local-override semantic-ctxt-current-class-list + semantic-grammar-mode (&optional point) + "Determine the class of tags that can be used at POINT." + (save-excursion + (and point (goto-char point)) + (if (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-ctxt-current-class-list)) + '(nonterminal keyword)))) + +(define-mode-local-override semantic-ctxt-current-mode + semantic-grammar-mode (&optional point) + "Return the major mode active at POINT. +POINT defaults to the value of point in current buffer. +Return `emacs-lisp-mode' is POINT is within Lisp code, otherwise +return the current major mode." + (save-excursion + (and point (goto-char point)) + (if (semantic-grammar-in-lisp-p) + 'emacs-lisp-mode + (semantic-ctxt-current-mode-default)))) + +(define-mode-local-override semantic-format-tag-abbreviate + semantic-grammar-mode (tag &optional parent color) + "Return a string abbreviation of TAG. +Optional PARENT is not used. +Optional COLOR is used to flag if color is added to the text." + (let ((class (semantic-tag-class tag)) + (name (semantic-format-tag-name tag parent color))) + (cond + ((eq class 'nonterminal) + (concat name ":")) + ((eq class 'setting) + "%settings%") + ((memq class '(rule keyword)) + name) + (t + (concat "%" (symbol-name class) " " name))))) + +(define-mode-local-override semantic-format-tag-summarize + semantic-grammar-mode (tag &optional parent color) + "Return a string summarizing TAG. +Optional PARENT is not used. +Optional argument COLOR determines if color is added to the text." + (let ((class (semantic-tag-class tag)) + (name (semantic-format-tag-name tag parent color)) + (label nil) + (desc nil)) + (cond + ((eq class 'nonterminal) + (setq label "Nonterminal: " + desc (format + " with %d match lists." + (length (semantic-tag-components tag))))) + ((eq class 'keyword) + (setq label "Keyword: ") + (let (summary) + (semantic--find-tags-by-function + #'(lambda (put) + (unless summary + (setq summary (cdr (assoc "summary" + (semantic-tag-get-attribute + put :value)))))) + ;; Get `put' tag with TAG name. + (semantic-find-tags-by-name-regexp + (regexp-quote (semantic-tag-name tag)) + (semantic-find-tags-by-class 'put (current-buffer)))) + (setq desc (concat " = " + (semantic-tag-get-attribute tag :value) + (if summary + (concat " - " (read summary)) + ""))))) + ((eq class 'token) + (setq label "Token: ") + (let ((val (semantic-tag-get-attribute tag :value)) + (names (semantic-tag-get-attribute tag :rest)) + (type (semantic-tag-type tag))) + (if names + (setq name (mapconcat 'identity (cons name names) " "))) + (setq desc (concat + (if type + (format " <%s>" type) + "") + (if val + (format "%s%S" val (if type " " "")) + ""))))) + ((eq class 'assoc) + (setq label "Assoc: ") + (let ((val (semantic-tag-get-attribute tag :value)) + (type (semantic-tag-type tag))) + (setq desc (concat + (if type + (format " <%s>" type) + "") + (if val + (concat " " (mapconcat 'identity val " ")) + ""))))) + (t + (setq desc (semantic-format-tag-abbreviate tag parent color)))) + (if (and color label) + (setq label (semantic--format-colorize-text label 'label))) + (if (and color label desc) + (setq desc (semantic--format-colorize-text desc 'comment))) + (if label + (concat label name desc) + ;; Just a description is the abbreviated version + desc))) + +;;; Semantic Analysis + +(define-mode-local-override semantic-analyze-current-context + semantic-grammar-mode (point) + "Provide a semantic analysis object describing a context in a grammar." + (require 'semantic/analyze) + (if (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-analyze-current-context point)) + + (let* ((context-return nil) + (prefixandbounds (semantic-ctxt-current-symbol-and-bounds)) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + (prefixsym nil) + (prefixclass (semantic-ctxt-current-class-list)) + ) + + ;; Do context for rules when in a match list. + (setq prefixsym + (semantic-find-first-tag-by-name + (car prefix) + (current-buffer))) + + (setq context-return + (semantic-analyze-context + "context-for-semantic-grammar" + :buffer (current-buffer) + :scope nil + :bounds bounds + :prefix (if prefixsym + (list prefixsym) + prefix) + :prefixtypes nil + :prefixclass prefixclass + )) + + context-return))) + +(define-mode-local-override semantic-analyze-possible-completions + semantic-grammar-mode (context) + "Return a list of possible completions based on CONTEXT." + (require 'semantic/analyze/complete) + (if (semantic-grammar-in-lisp-p) + (with-mode-local emacs-lisp-mode + (semantic-analyze-possible-completions context)) + (save-excursion + (set-buffer (oref context buffer)) + (let* ((prefix (car (oref context :prefix))) + (completetext (cond ((semantic-tag-p prefix) + (semantic-tag-name prefix)) + ((stringp prefix) + prefix) + ((stringp (car prefix)) + (car prefix)))) + (tags (semantic-find-tags-for-completion completetext + (current-buffer)))) + (semantic-analyze-tags-of-class-list + tags (oref context prefixclass))) + ))) + +(provide 'semantic/grammar) + +;;; semantic/grammar.el ends here diff --git a/lisp/cedet/semantic/html.el b/lisp/cedet/semantic/html.el new file mode 100644 index 00000000000..c1d9276ff1e --- /dev/null +++ b/lisp/cedet/semantic/html.el @@ -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 <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Parse HTML files and organize them in a nice way. +;; Pay attention to anchors, including them in the tag list. +;; +;; Copied from the original semantic-texi.el. +;; +;; ToDo: Find <script> tags, and parse the contents in other +;; parsers, such as javascript, php, shtml, or others. + +;;; Code: + +(require 'semantic) +(require 'semantic/format) +(require 'sgml-mode) + +(defvar semantic-command-separation-character) + +(defvar semantic-html-super-regex + "<\\(h[1-9]\\|title\\|script\\|body\\|a +href\\)\\>" + "Regular expression used to find special sections in an HTML file.") + +(defvar semantic-html-section-list + '(("title" 1) + ("script" 1) + ("body" 1) + ("a" 11) + ("h1" 2) + ("h2" 3) + ("h3" 4) + ("h4" 5) + ("h5" 6) + ("h6" 7) + ("h7" 8) + ("h8" 9) + ("h9" 10) + ) + "Alist of sectioning commands and their relative level.") + +(define-mode-local-override semantic-parse-region + html-mode (&rest ignore) + "Parse the current html buffer for semantic tags. +INGNORE any arguments. Always parse the whole buffer. +Each tag returned is of the form: + (\"NAME\" section (:members CHILDREN)) +or + (\"NAME\" anchor)" + (mapcar 'semantic-html-expand-tag + (semantic-html-parse-headings))) + +(define-mode-local-override semantic-parse-changes + html-mode () + "We can't parse changes for HTML mode right now." + (semantic-parse-tree-set-needs-rebuild)) + +(defun semantic-html-expand-tag (tag) + "Expand the HTML tag TAG." + (let ((chil (semantic-html-components tag))) + (if chil + (semantic-tag-put-attribute + tag :members (mapcar 'semantic-html-expand-tag chil))) + (car (semantic--tag-expand tag)))) + +(defun semantic-html-components (tag) + "Return components belonging to TAG." + (semantic-tag-get-attribute tag :members)) + +(defun semantic-html-parse-headings () + "Parse the current html buffer for all semantic tags." + (let ((pass1 nil)) + ;; First search and snarf. + (save-excursion + (goto-char (point-min)) + + (let ((semantic--progress-reporter + (make-progress-reporter + (format "Parsing %s..." + (file-name-nondirectory buffer-file-name)) + (point-min) (point-max)))) + (while (re-search-forward semantic-html-super-regex nil t) + (setq pass1 (cons (match-beginning 0) pass1)) + (progress-reporter-update semantic--progress-reporter (point))) + (progress-reporter-done semantic--progress-reporter))) + + (setq pass1 (nreverse pass1)) + ;; Now, make some tags while creating a set of children. + (car (semantic-html-recursive-combobulate-list pass1 0)) + )) + +(defun semantic-html-set-endpoint (metataglist pnt) + "Set the end point of the first section tag in METATAGLIST to PNT. +METATAGLIST is a list of tags in the intermediate tag format used by the +html parser. PNT is the new point to set." + (let ((metatag nil)) + (while (and metataglist + (not (eq (semantic-tag-class (car metataglist)) 'section))) + (setq metataglist (cdr metataglist))) + (setq metatag (car metataglist)) + (when metatag + (setcar (nthcdr (1- (length metatag)) metatag) pnt) + metatag))) + +(defsubst semantic-html-new-section-tag (name members level start end) + "Create a semantic tag of class section. +NAME is the name of this section. +MEMBERS is a list of semantic tags representing the elements that make +up this section. +LEVEL is the levelling level. +START and END define the location of data described by the tag." + (let ((anchorp (eq level 11))) + (append (semantic-tag name + (cond (anchorp 'anchor) + (t 'section)) + :members members) + (list start (if anchorp (point) end)) ))) + +(defun semantic-html-extract-section-name () + "Extract a section name from the current buffer and point. +Assume the cursor is in the tag representing the section we +need the name from." + (save-excursion + ; Skip over the HTML tag. + (forward-sexp -1) + (forward-char -1) + (forward-sexp 1) + (skip-chars-forward "\n\t ") + (while (looking-at "<") + (forward-sexp 1) + (skip-chars-forward "\n\t ") + ) + (let ((start (point)) + (end nil)) + (if (re-search-forward "</" nil t) + (progn + (goto-char (match-beginning 0)) + (skip-chars-backward " \n\t") + (setq end (point)) + (buffer-substring-no-properties start end)) + "")) + )) + +(defun semantic-html-recursive-combobulate-list (sectionlist level) + "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL. +Return the rearranged new list, with all remaining tags from +SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a +tag with greater section value than LEVEL is found." + (let ((newl nil) + (oldl sectionlist) + (case-fold-search t) + tag + ) + (save-excursion + (catch 'level-jump + (while oldl + (goto-char (car oldl)) + (if (looking-at "<\\(\\w+\\)") + (let* ((word (match-string 1)) + (levelmatch (assoc-string + word semantic-html-section-list t)) + text begin tmp + ) + (when (not levelmatch) + (error "Tag %s matched in regexp but is not in list" + word)) + ;; Set begin to the right location + (setq begin (point)) + ;; Get out of here if there if we made it that far. + (if (and levelmatch (<= (car (cdr levelmatch)) level)) + (progn + (when newl + (semantic-html-set-endpoint newl begin)) + (throw 'level-jump t))) + ;; When there is a match, the descriptive text + ;; consists of the rest of the line. + (goto-char (match-end 1)) + (skip-chars-forward " \t") + (setq text (semantic-html-extract-section-name)) + ;; Next, recurse into the body to find the end. + (setq tmp (semantic-html-recursive-combobulate-list + (cdr oldl) (car (cdr levelmatch)))) + ;; Build a tag + (setq tag (semantic-html-new-section-tag + text (car tmp) (car (cdr levelmatch)) begin (point-max))) + ;; Before appending the newtag, update the previous tag + ;; if it is a section tag. + (when newl + (semantic-html-set-endpoint newl begin)) + ;; Append new tag to our master list. + (setq newl (cons tag newl)) + ;; continue + (setq oldl (cdr tmp)) + ) + (error "Problem finding section in semantic/html parser")) + ;; (setq oldl (cdr oldl)) + ))) + ;; Return the list + (cons (nreverse newl) oldl))) + +(define-mode-local-override semantic-sb-tag-children-to-expand + html-mode (tag) + "The children TAG expands to." + (semantic-html-components tag)) + +;;;###autoload +(defun semantic-default-html-setup () + "Set up a buffer for parsing of HTML files." + ;; This will use our parser. + (setq semantic-parser-name "HTML" + semantic--parse-table t + imenu-create-index-function 'semantic-create-imenu-index + semantic-command-separation-character ">" + semantic-type-relation-separator-character '(":") + semantic-symbol->name-assoc-list '((section . "Section") + + ) + semantic-imenu-expandable-tag-classes '(section) + semantic-imenu-bucketize-file nil + semantic-imenu-bucketize-type-members nil + senator-step-at-start-end-tag-classes '(section) + semantic-stickyfunc-sticky-classes '(section) + ) + (semantic-install-function-overrides + '((tag-components . semantic-html-components) + ) + t) + ) + +(define-child-mode html-helper-mode html-mode + "`html-helper-mode' needs the same semantic support as `html-mode'.") + +(provide 'semantic/html) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/html" +;; End: + +;;; semantic/html.el ends here diff --git a/lisp/cedet/semantic/ia-sb.el b/lisp/cedet/semantic/ia-sb.el new file mode 100644 index 00000000000..d9f223a90d1 --- /dev/null +++ b/lisp/cedet/semantic/ia-sb.el @@ -0,0 +1,374 @@ +;;; semantic/ia-sb.el --- Speedbar analysis display interactor + +;;; Copyright (C) 2002, 2003, 2004, 2006, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Speedbar node for displaying derived context information. +;; + +(require 'semantic/analyze) +(require 'speedbar) + +;;; Code: +(defvar semantic-ia-sb-key-map nil + "Keymap used when in semantic analysis display mode.") + +(if semantic-ia-sb-key-map + nil + (setq semantic-ia-sb-key-map (speedbar-make-specialized-keymap)) + + ;; Basic featuers. + (define-key semantic-ia-sb-key-map "\C-m" 'speedbar-edit-line) + (define-key semantic-ia-sb-key-map "I" 'semantic-ia-sb-show-tag-info) + ) + +(defvar semantic-ia-sb-easymenu-definition + '( "---" +; [ "Expand" speedbar-expand-line nil ] +; [ "Contract" speedbar-contract-line nil ] + [ "Tag Information" semantic-ia-sb-show-tag-info t ] + [ "Jump to Tag" speedbar-edit-line t ] + [ "Complete" speedbar-edit-line t ] + ) + "Extra menu items Analysis mode.") + +;; Make sure our special speedbar major mode is loaded +(speedbar-add-expansion-list '("Analyze" + semantic-ia-sb-easymenu-definition + semantic-ia-sb-key-map + semantic-ia-speedbar)) + +(speedbar-add-mode-functions-list + (list "Analyze" + ;;'(speedbar-item-info . eieio-speedbar-item-info) + '(speedbar-line-directory . semantic-ia-sb-line-path))) + +;;;###autoload +(defun semantic-speedbar-analysis () + "Start Speedbar in semantic analysis mode. +The analyzer displays information about the current context, plus a smart +list of possible completions." + (interactive) + ;; Make sure that speedbar is active + (speedbar-frame-mode 1) + ;; Now, throw us into Analyze mode on speedbar. + (speedbar-change-initial-expansion-list "Analyze") + ) + +(defun semantic-ia-speedbar (directory zero) + "Create buttons in speedbar which define the current analysis at POINT. +DIRECTORY is the current directory, which is ignored, and ZERO is 0." + (let ((analysis nil) + (scope nil) + (buffer nil) + (completions nil) + (cf (selected-frame)) + (cnt nil) + (mode-local-active-mode nil) + ) + ;; Try and get some sort of analysis + (condition-case nil + (progn + (speedbar-select-attached-frame) + (setq buffer (current-buffer)) + (setq mode-local-active-mode major-mode) + (save-excursion + ;; Get the current scope + (setq scope (semantic-calculate-scope (point))) + ;; Get the analysis + (setq analysis (semantic-analyze-current-context (point))) + (setq cnt (semantic-find-tag-by-overlay)) + (when analysis + (setq completions (semantic-analyze-possible-completions analysis)) + ) + )) + (error nil)) + (select-frame cf) + (save-excursion + (set-buffer speedbar-buffer) + ;; If we have something, do something spiff with it. + (erase-buffer) + (speedbar-insert-separator "Buffer/Function") + ;; Note to self: Turn this into an expandable file name. + (speedbar-make-tag-line 'bracket ? nil nil + (buffer-name buffer) + nil nil 'speedbar-file-face 0) + + (when cnt + (semantic-ia-sb-string-list cnt + 'speedbar-tag-face + 'semantic-sb-token-jump)) + (when analysis + ;; If this analyzer happens to point at a complete symbol, then + ;; see if we can dig up some documentation for it. + (semantic-ia-sb-show-doc analysis)) + + (when analysis + ;; Let different classes draw more buttons. + (semantic-ia-sb-more-buttons analysis) + (when completions + (speedbar-insert-separator "Completions") + (semantic-ia-sb-completion-list completions + 'speedbar-tag-face + 'semantic-ia-sb-complete)) + ) + + ;; Show local variables + (when scope + (semantic-ia-sb-show-scope scope)) + + ))) + +(defmethod semantic-ia-sb-show-doc ((context semantic-analyze-context)) + "Show documentation about CONTEXT iff CONTEXT points at a complete symbol." + (let ((sym (car (reverse (oref context prefix)))) + (doc nil)) + (when (semantic-tag-p sym) + (setq doc (semantic-documentation-for-tag sym)) + (when doc + (speedbar-insert-separator "Documentation") + (insert doc) + (insert "\n") + )) + )) + +(defun semantic-ia-sb-show-scope (scope) + "Show SCOPE information." + (let ((localvars (when scope + (oref scope localvar))) + ) + (when localvars + (speedbar-insert-separator "Local Variables") + (semantic-ia-sb-string-list localvars + 'speedbar-tag-face + ;; This is from semantic-sb + 'semantic-sb-token-jump)))) + +(defmethod semantic-ia-sb-more-buttons ((context semantic-analyze-context)) + "Show a set of speedbar buttons specific to CONTEXT." + (let ((prefix (oref context prefix))) + (when prefix + (speedbar-insert-separator "Prefix") + (semantic-ia-sb-string-list prefix + 'speedbar-tag-face + 'semantic-sb-token-jump)) + )) + +(defmethod semantic-ia-sb-more-buttons ((context semantic-analyze-context-assignment)) + "Show a set of speedbar buttons specific to CONTEXT." + (call-next-method) + (let ((assignee (oref context assignee))) + (when assignee + (speedbar-insert-separator "Assignee") + (semantic-ia-sb-string-list assignee + 'speedbar-tag-face + 'semantic-sb-token-jump)))) + +(defmethod semantic-ia-sb-more-buttons ((context semantic-analyze-context-functionarg)) + "Show a set of speedbar buttons specific to CONTEXT." + (call-next-method) + (let ((func (oref context function))) + (when func + (speedbar-insert-separator "Function") + (semantic-ia-sb-string-list func + 'speedbar-tag-face + 'semantic-sb-token-jump) + ;; An index for the argument the prefix is in: + (let ((arg (oref context argument)) + (args (semantic-tag-function-arguments (car func))) + (idx 0) + ) + (speedbar-insert-separator + (format "Argument #%d" (oref context index))) + (if args + (semantic-ia-sb-string-list args + 'speedbar-tag-face + 'semantic-sb-token-jump + (oref context index) + 'speedbar-selected-face) + ;; Else, no args list, so use what the context had. + (semantic-ia-sb-string-list arg + 'speedbar-tag-face + 'semantic-sb-token-jump)) + )))) + +(defun semantic-ia-sb-string-list (list face function &optional idx idxface) + "Create some speedbar buttons from LIST. +Each button will use FACE, and be activated with FUNCTION. +Optional IDX is an index into LIST to apply IDXFACE instead." + (let ((count 1)) + (while list + (let* ((usefn nil) + (string (cond ((stringp (car list)) + (car list)) + ((semantic-tag-p (car list)) + (setq usefn (semantic-tag-with-position-p (car list))) + (semantic-format-tag-uml-concise-prototype (car list))) + (t "<No Tag>"))) + (localface (if (or (not idx) (/= idx count)) + face + idxface)) + ) + (if (semantic-tag-p (car list)) + (speedbar-make-tag-line 'angle ?i + 'semantic-ia-sb-tag-info (car list) + string (if usefn function) (car list) localface + 0) + (speedbar-make-tag-line 'statictag ?? + nil nil + string (if usefn function) (car list) localface + 0)) + (setq list (cdr list) + count (1+ count))) + ))) + +(defun semantic-ia-sb-completion-list (list face function) + "Create some speedbar buttons from LIST. +Each button will use FACE, and be activated with FUNCTION." + (while list + (let* ((documentable nil) + (string (cond ((stringp (car list)) + (car list)) + ((semantic-tag-p (car list)) + (setq documentable t) + (semantic-format-tag-uml-concise-prototype (car list))) + (t "foo")))) + (if documentable + (speedbar-make-tag-line 'angle ?i + 'semantic-ia-sb-tag-info + (car list) + string function (car list) face + 0) + (speedbar-make-tag-line 'statictag ? nil nil + string function (car list) face + 0)) + (setq list (cdr list))))) + +(defun semantic-ia-sb-show-tag-info () + "Display information about the tag on the current line. +Same as clicking on the <i> button. +See `semantic-ia-sb-tag-info' for more." + (interactive) + (let ((tok nil)) + (save-excursion + (end-of-line) + (forward-char -1) + (setq tok (get-text-property (point) 'speedbar-token))) + (semantic-ia-sb-tag-info nil tok 0))) + +(defun semantic-ia-sb-tag-info (text tag indent) + "Display as much information as we can about tag. +Show the information in a shrunk split-buffer and expand +out as many details as possible. +TEXT, TAG, and INDENT are speedbar function arguments." + (when (semantic-tag-p tag) + (unwind-protect + (let ((ob nil)) + (speedbar-select-attached-frame) + (setq ob (current-buffer)) + (with-output-to-temp-buffer "*Tag Information*" + ;; Output something about this tag: + (save-excursion + (set-buffer "*Tag Information*") + (goto-char (point-max)) + (insert + (semantic-format-tag-prototype tag nil t) + "\n") + (let ((typetok + (condition-case nil + (save-excursion + (set-buffer ob) + ;; @todo - We need a context to derive a scope from. + (semantic-analyze-tag-type tag nil)) + (error nil)))) + (if typetok + (insert (semantic-format-tag-prototype + typetok nil t)) + ;; No type found by the analyzer + ;; The below used to try and select the buffer from the last + ;; analysis, but since we are already in the correct buffer, I + ;; don't think that is needed. + (let ((type (semantic-tag-type tag))) + (cond ((semantic-tag-p type) + (setq type (semantic-tag-name type))) + ((listp type) + (setq type (car type)))) + (if (semantic-lex-keyword-p type) + (setq typetok + (semantic-lex-keyword-get type 'summary)))) + (if typetok + (insert typetok)) + )) + )) + ;; Make it small + (shrink-window-if-larger-than-buffer + (get-buffer-window "*Tag Information*"))) + (select-frame speedbar-frame)))) + +(defun semantic-ia-sb-line-path (&optional depth) + "Return the file name associated with DEPTH." + (save-match-data + (let* ((tok (speedbar-line-token)) + (buff (if (semantic-tag-buffer tok) + (semantic-tag-buffer tok) + (current-buffer)))) + (buffer-file-name buff)))) + +(defun semantic-ia-sb-complete (text tag indent) + "At point in the attached buffer, complete the symbol clicked on. +TEXT TAG and INDENT are the details." + ;; Find the specified bounds from the current analysis. + (speedbar-select-attached-frame) + (unwind-protect + (let* ((a (semantic-analyze-current-context (point))) + (bounds (oref a bounds)) + (movepoint nil) + ) + (save-excursion + (if (and (<= (point) (cdr bounds)) (>= (point) (car bounds))) + (setq movepoint t)) + (goto-char (car bounds)) + (delete-region (car bounds) (cdr bounds)) + (insert (semantic-tag-name tag)) + (if movepoint (setq movepoint (point))) + ;; I'd like to use this to add fancy () or what not at the end + ;; but we need the parent file whih requires an upgrade to the + ;; analysis tool. + ;;(semantic-insert-foreign-tag tag ??)) + ) + (if movepoint + (let ((cf (selected-frame))) + (speedbar-select-attached-frame) + (goto-char movepoint) + (select-frame cf)))) + (select-frame speedbar-frame))) + +(provide 'semantic/ia-sb) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/ia-sb" +;; End: + +;;; semantic/ia-sb.el ends here diff --git a/lisp/cedet/semantic/ia.el b/lisp/cedet/semantic/ia.el new file mode 100644 index 00000000000..1036a9b5b98 --- /dev/null +++ b/lisp/cedet/semantic/ia.el @@ -0,0 +1,422 @@ +;;; semantic/ia.el --- Interactive Analysis functions + +;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Interactive access to `semantic-analyze'. +;; +;; These routines are fairly simple, and show how to use the Semantic +;; analyzer to provide things such as completion lists, summaries, +;; locations, or documentation. +;; + +;;; TODO +;; +;; fast-jump. For a virtual method, offer some of the possible +;; implementations in various sub-classes. + +(require 'semantic/analyze) +(require 'semantic/format) +(require 'pulse) +(eval-when-compile + (require 'semantic/analyze) + (require 'semantic/analyze/refs)) + +(declare-function imenu--mouse-menu "imenu") + +;;; Code: + +;;; COMPLETION +;; +;; This set of routines provides some simplisting completion +;; functions. + +(defcustom semantic-ia-completion-format-tag-function + 'semantic-prototype-nonterminal + "*Function used to convert a tag to a string during completion." + :group 'semantic + :type semantic-format-tag-custom-list) + +(defvar semantic-ia-cache nil + "Cache of the last completion request. +Of the form ( POINT . COMPLETIONS ) where POINT is a location in the +buffer where the completion was requested. COMPLETONS is the list +of semantic tag names that provide logical completions from that +location.") +(make-variable-buffer-local 'semantic-ia-cache) + +;;; COMPLETION HELPER +;; +;; This overload function handles inserting a tag +;; into a buffer for these local completion routines. +;; +;; By creating the functions as overloadable, it can be +;; customized. For example, the default will put a paren "(" +;; character after function names. For Lisp, it might check +;; to put a "(" in front of a function name. + +(define-overloadable-function semantic-ia-insert-tag (tag) + "Insert TAG into the current buffer based on completion.") + +(defun semantic-ia-insert-tag-default (tag) + "Insert TAG into the current buffer based on completion." + (insert (semantic-tag-name tag)) + (let ((tt (semantic-tag-class tag))) + (cond ((eq tt 'function) + (insert "(")) + (t nil)))) + +(declare-function semantic-analyze-possible-completions + "semantic/analyze/complete") + +(defun semantic-ia-get-completions (context point) + "Fetch the completion of CONTEXT at POINT. +Supports caching." + ;; Cache the current set of symbols so that we can get at + ;; them quickly the second time someone presses the + ;; complete button. + (let ((symbols + (if (and semantic-ia-cache + (= point (car semantic-ia-cache))) + (cdr semantic-ia-cache) + (semantic-analyze-possible-completions context)))) + ;; Set the cache + (setq semantic-ia-cache (cons point symbols)) + symbols)) + +;;;###autoload +(defun semantic-ia-complete-symbol (point) + "Complete the current symbol at POINT. +Completion options are calculated with `semantic-analyze-possible-completions'." + (interactive "d") + ;; Calculating completions is a two step process. + ;; + ;; The first analyzer the current context, which finds tags + ;; for all the stuff that may be references by the code around + ;; POINT. + ;; + ;; The second step derives completions from that context. + (let* ((a (semantic-analyze-current-context point)) + (syms (semantic-ia-get-completions a point)) + (pre (car (reverse (oref a prefix)))) + ) + ;; If PRE was actually an already completed symbol, it doesn't + ;; come in as a string, but as a tag instead. + (if (semantic-tag-p pre) + ;; We will try completions on it anyway. + (setq pre (semantic-tag-name pre))) + ;; Complete this symbol. + (if (null syms) + (progn + ;(message "No smart completions found. Trying senator-complete-symbol.") + (if (semantic-analyze-context-p a) + ;; This is a clever hack. If we were unable to find any + ;; smart completions, lets divert to how senator derives + ;; completions. + ;; + ;; This is a way of making this fcn more useful since the + ;; smart completion engine sometimes failes. + (semantic-complete-symbol))) + ;; Use try completion to seek a common substring. + (let ((tc (try-completion (or pre "") syms))) + (if (and (stringp tc) (not (string= tc (or pre "")))) + (let ((tok (semantic-find-first-tag-by-name + tc syms))) + ;; Delete what came before... + (when (and (car (oref a bounds)) (cdr (oref a bounds))) + (delete-region (car (oref a bounds)) + (cdr (oref a bounds))) + (goto-char (car (oref a bounds)))) + ;; We have some new text. Stick it in. + (if tok + (semantic-ia-insert-tag tok) + (insert tc))) + ;; We don't have new text. Show all completions. + (when (cdr (oref a bounds)) + (goto-char (cdr (oref a bounds)))) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list + (mapcar semantic-ia-completion-format-tag-function syms)) + )))))) + +(defcustom semantic-ia-completion-menu-format-tag-function + 'semantic-uml-concise-prototype-nonterminal + "*Function used to convert a tag to a string during completion." + :group 'semantic + :type semantic-format-tag-custom-list) + +;;; Completions Tip +;; +;; This functions shows how to get the list of completions, +;; to place in a tooltip. It doesn't actually do any completion. + +;;;###autoload +(defun semantic-ia-complete-tip (point) + "Pop up a tooltip for completion at POINT." + (interactive "d") + (let* ((a (semantic-analyze-current-context point)) + (syms (semantic-ia-get-completions a point)) + (x (mod (- (current-column) (window-hscroll)) + (window-width))) + (y (save-excursion + (save-restriction + (widen) + (narrow-to-region (window-start) (point)) + (goto-char (point-min)) + (1+ (vertical-motion (buffer-size)))))) + (str (mapconcat #'semantic-tag-name + syms + "\n")) + ) + (cond ((fboundp 'x-show-tip) + (x-show-tip str + (selected-frame) + nil + nil + x y) + ) + (t (message str)) + ))) + +;;; Summary +;; +;; Like idle-summary-mode, this shows how to get something to +;; show a summary on. + +;;;###autoload +(defun semantic-ia-show-summary (point) + "Display a summary for the symbol under POINT." + (interactive "P") + (let* ((ctxt (semantic-analyze-current-context point)) + (pf (when ctxt + ;; The CTXT is an EIEIO object. The below + ;; method will attempt to pick the most interesting + ;; tag associated with the current context. + (semantic-analyze-interesting-tag ctxt))) + ) + (when pf + (message "%s" (semantic-format-tag-summarize pf nil t))))) + +;;; FAST Jump +;; +;; Jump to a destination based on the local context. +;; +;; This shows how to use the analyzer context, and the +;; analyer references objects to choose a good destination. + +(defun semantic-ia--fast-jump-helper (dest) + "Jump to DEST, a Semantic tag. +This helper manages the mark, buffer switching, and pulsing." + ;; We have a tag, but in C++, we usually get a prototype instead + ;; because of header files. Lets try to find the actual + ;; implementaion instead. + (when (semantic-tag-prototype-p dest) + (let* ((refs (semantic-analyze-tag-references dest)) + (impl (semantic-analyze-refs-impl refs t)) + ) + (when impl (setq dest (car impl))))) + + ;; Make sure we have a place to go... + (if (not (and (or (semantic-tag-with-position-p dest) + (semantic-tag-get-attribute dest :line)) + (semantic-tag-file-name dest))) + (error "Tag %s has no buffer information" + (semantic-format-tag-name dest))) + + ;; Once we have the tag, we can jump to it. Here + ;; are the key bits to the jump: + + ;; 1) Push the mark, so you can pop global mark back, or + ;; use semantic-mru-bookmark mode to do so. + (push-mark) + (when (fboundp 'push-tag-mark) + (push-tag-mark)) + ;; 2) Visits the tag. + (semantic-go-to-tag dest) + ;; 3) go-to-tag doesn't switch the buffer in the current window, + ;; so it is like find-file-noselect. Bring it forward. + (switch-to-buffer (current-buffer)) + ;; 4) Fancy pulsing. + (pulse-momentary-highlight-one-line (point)) + ) + +(declare-function semantic-decoration-include-visit "semantic/decorate/include") + +;;;###autoload +(defun semantic-ia-fast-jump (point) + "Jump to the tag referred to by the code at POINT. +Uses `semantic-analyze-current-context' output to identify an accurate +origin of the code at point." + (interactive "d") + (let* ((ctxt (semantic-analyze-current-context point)) + (pf (and ctxt (reverse (oref ctxt prefix)))) + ;; In the analyzer context, the PREFIX is the list of items + ;; that makes up the code context at point. Thus the c++ code + ;; this.that().theothe + ;; would make a list: + ;; ( ("this" variable ..) ("that" function ...) "theothe") + ;; Where the first two elements are the semantic tags of the prefix. + ;; + ;; PF is the reverse of this list. If the first item is a string, + ;; then it is an incomplete symbol, thus we pick the second. + ;; The second cannot be a string, as that would have been an error. + (first (car pf)) + (second (nth 1 pf)) + ) + (cond + ((semantic-tag-p first) + ;; We have a match. Just go there. + (semantic-ia--fast-jump-helper first)) + + ((semantic-tag-p second) + ;; Because FIRST failed, we should visit our second tag. + ;; HOWEVER, the tag we actually want that was only an unfound + ;; string may be related to some take in the datatype that belongs + ;; to SECOND. Thus, instead of visiting second directly, we + ;; can offer to find the type of SECOND, and go there. + (let ((secondclass (car (reverse (oref ctxt prefixtypes))))) + (cond + ((and (semantic-tag-with-position-p secondclass) + (y-or-n-p (format "Could not find `%s'. Jump to %s? " + first (semantic-tag-name secondclass)))) + (semantic-ia--fast-jump-helper secondclass) + ) + ;; If we missed out on the class of the second item, then + ;; just visit SECOND. + ((and (semantic-tag-p second) + (y-or-n-p (format "Could not find `%s'. Jump to %s? " + first (semantic-tag-name second)))) + (semantic-ia--fast-jump-helper second) + )))) + + ((semantic-tag-of-class-p (semantic-current-tag) 'include) + ;; Just borrow this cool fcn. + (require 'semantic/decorate/include) + (semantic-decoration-include-visit) + ) + + (t + (error "Could not find suitable jump point for %s" + first)) + ))) + +;;;###autoload +(defun semantic-ia-fast-mouse-jump (evt) + "Jump to the tag referred to by the point clicked on. +See `semantic-ia-fast-jump' for details on how it works. + This command is meant to be bound to a mouse event." + (interactive "e") + (semantic-ia-fast-jump + (save-excursion + (posn-set-point (event-end evt)) + (point)))) + +;;; DOC/DESCRIBE +;; +;; These routines show how to get additional information about a tag +;; for purposes of describing or showing documentation about them. +;;;###autoload +(defun semantic-ia-show-doc (point) + "Display the code-level documentation for the symbol at POINT." + (interactive "d") + (let* ((ctxt (semantic-analyze-current-context point)) + (pf (reverse (oref ctxt prefix))) + ) + ;; If PF, the prefix is non-nil, then the last element is either + ;; a string (incomplete type), or a semantic TAG. If it is a TAG + ;; then we should be able to find DOC for it. + (cond + ((stringp (car pf)) + (message "Incomplete symbol name.")) + ((semantic-tag-p (car pf)) + ;; The `semantic-documentation-for-tag' fcn is language + ;; specific. If it doesn't return what you expect, you may + ;; need to implement something for your language. + ;; + ;; The default tries to find a comment in front of the tag + ;; and then strings off comment prefixes. + (let ((doc (semantic-documentation-for-tag (car pf)))) + (with-output-to-temp-buffer "*TAG DOCUMENTATION*" + (princ "Tag: ") + (princ (semantic-format-tag-prototype (car pf))) + (princ "\n") + (princ "\n") + (princ "Snarfed Documentation: ") + (princ "\n") + (princ "\n") + (if doc + (princ doc) + (princ " Documentation unavailable.")) + ))) + (t + (message "Unknown tag."))) + )) + +;;;###autoload +(defun semantic-ia-describe-class (typename) + "Display all known parts for the datatype TYPENAME. +If the type in question is a class, all methods and other accessible +parts of the parent classes are displayed." + ;; @todo - use a fancy completing reader. + (interactive "sType Name: ") + + ;; When looking for a tag of any name there are a couple ways to do + ;; it. The simple `semanticdb-find-tag-by-...' are simple, and + ;; you need to pass it the exact name you want. + ;; + ;; The analyzer function `semantic-analyze-tag-name' will take + ;; more complex names, such as the cpp symbol foo::bar::baz, + ;; and break it up, and dive through the namespaces. + (let ((class (semantic-analyze-find-tag typename))) + + (when (not (semantic-tag-p class)) + (error "Cannot find class %s" class)) + (with-output-to-temp-buffer "*TAG DOCUMENTATION*" + ;; There are many semantic-format-tag-* fcns. + ;; The summarize routine is a fairly generic one. + (princ (semantic-format-tag-summarize class)) + (princ "\n") + (princ " Type Members:\n") + ;; The type tag contains all the parts of the type. + ;; In complex languages with inheritance, not all the + ;; parts are in the tag. This analyzer fcn will traverse + ;; the inheritance tree, and find all the pieces that + ;; are inherited. + (let ((parts (semantic-analyze-scoped-type-parts class))) + (while parts + (princ " ") + (princ (semantic-format-tag-summarize (car parts))) + (princ "\n") + (setq parts (cdr parts))) + ) + ))) + +(provide 'semantic/ia) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/ia" +;; End: + +;;; semantic/ia.el ends here diff --git a/lisp/cedet/semantic/idle.el b/lisp/cedet/semantic/idle.el new file mode 100644 index 00000000000..02170154298 --- /dev/null +++ b/lisp/cedet/semantic/idle.el @@ -0,0 +1,957 @@ +;;; idle.el --- Schedule parsing tasks in idle time + +;;; Copyright (C) 2003, 2004, 2005, 2006, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Originally, `semantic-auto-parse-mode' handled refreshing the +;; tags in a buffer in idle time. Other activities can be scheduled +;; in idle time, all of which require up-to-date tag tables. +;; Having a specialized idle time scheduler that first refreshes +;; the tags buffer, and then enables other idle time tasks reduces +;; the amount of work needed. Any specialized idle tasks need not +;; ask for a fresh tags list. +;; +;; NOTE ON SEMANTIC_ANALYZE +;; +;; Some of the idle modes use the semantic analyzer. The analyzer +;; automatically caches the created context, so it is shared amongst +;; all idle modes that will need it. + +(require 'semantic) +(require 'semantic/ctxt) +(require 'semantic/format) +(require 'semantic/tag) +(require 'timer) + +;; For the semantic-find-tags-by-name macro. +(eval-when-compile (require 'semantic/find)) + +(declare-function eldoc-message "eldoc") +(declare-function semantic-analyze-interesting-tag "semantic/analyze") +(declare-function semantic-complete-analyze-inline-idle "semantic/complete") +(declare-function semanticdb-deep-find-tags-by-name "semantic/db-find") +(declare-function semanticdb-save-all-db-idle "semantic/db") +(declare-function semanticdb-typecache-refresh-for-buffer "semantic/db-typecache") +(declare-function semantic-decorate-flush-pending-decorations + "semantic/decorate/mode") +(declare-function pulse-momentary-highlight-region "pulse") +(declare-function pulse-momentary-highlight-overlay "pulse") +(declare-function semantic-symref-hits-in-region "semantic/symref/filter") + +;;; Code: + +;;; TIMER RELATED FUNCTIONS +;; +(defvar semantic-idle-scheduler-timer nil + "Timer used to schedule tasks in idle time.") + +(defvar semantic-idle-scheduler-work-timer nil + "Timer used to schedule tasks in idle time that may take a while.") + +(defcustom semantic-idle-scheduler-verbose-flag nil + "Non-nil means that the idle scheduler should provide debug messages. +Use this setting to debug idle activities." + :group 'semantic + :type 'boolean) + +(defcustom semantic-idle-scheduler-idle-time 1 + "Time in seconds of idle before scheduling events. +This time should be short enough to ensure that idle-scheduler will be +run as soon as Emacs is idle." + :group 'semantic + :type 'number + :set (lambda (sym val) + (set-default sym val) + (when (timerp semantic-idle-scheduler-timer) + (cancel-timer semantic-idle-scheduler-timer) + (setq semantic-idle-scheduler-timer nil) + (semantic-idle-scheduler-setup-timers)))) + +(defcustom semantic-idle-scheduler-work-idle-time 60 + "Time in seconds of idle before scheduling big work. +This time should be long enough that once any big work is started, it is +unlikely the user would be ready to type again right away." + :group 'semantic + :type 'number + :set (lambda (sym val) + (set-default sym val) + (when (timerp semantic-idle-scheduler-timer) + (cancel-timer semantic-idle-scheduler-timer) + (setq semantic-idle-scheduler-timer nil) + (semantic-idle-scheduler-setup-timers)))) + +(defun semantic-idle-scheduler-setup-timers () + "Lazy initialization of the auto parse idle timer." + ;; REFRESH THIS FUNCTION for XEMACS FOIBLES + (or (timerp semantic-idle-scheduler-timer) + (setq semantic-idle-scheduler-timer + (run-with-idle-timer + semantic-idle-scheduler-idle-time t + #'semantic-idle-scheduler-function))) + (or (timerp semantic-idle-scheduler-work-timer) + (setq semantic-idle-scheduler-work-timer + (run-with-idle-timer + semantic-idle-scheduler-work-idle-time t + #'semantic-idle-scheduler-work-function))) + ) + +(defun semantic-idle-scheduler-kill-timer () + "Kill the auto parse idle timer." + (if (timerp semantic-idle-scheduler-timer) + (cancel-timer semantic-idle-scheduler-timer)) + (setq semantic-idle-scheduler-timer nil)) + + +;;; MINOR MODE +;; +;; The minor mode portion of this code just sets up the minor mode +;; which does the initial scheduling of the idle timers. +;; +;;;###autoload +(defcustom global-semantic-idle-scheduler-mode nil + "*If non-nil, enable global use of idle-scheduler mode." + :group 'semantic + :group 'semantic-modes + :type 'boolean + :require 'semantic/idle + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-semantic-idle-scheduler-mode (if val 1 -1)))) + +;;;###autoload +(defun global-semantic-idle-scheduler-mode (&optional arg) + "Toggle global use of option `semantic-idle-scheduler-mode'. +The idle scheduler with automatically reparse buffers in idle time, +and then schedule other jobs setup with `semantic-idle-scheduler-add'. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle." + (interactive "P") + (setq global-semantic-idle-scheduler-mode + (semantic-toggle-minor-mode-globally + 'semantic-idle-scheduler-mode arg))) + +(defcustom semantic-idle-scheduler-mode-hook nil + "*Hook run at the end of function `semantic-idle-scheduler-mode'." + :group 'semantic + :type 'hook) + +(defvar semantic-idle-scheduler-mode nil + "Non-nil if idle-scheduler minor mode is enabled. +Use the command `semantic-idle-scheduler-mode' to change this variable.") +(make-variable-buffer-local 'semantic-idle-scheduler-mode) + +(defcustom semantic-idle-scheduler-max-buffer-size 0 + "*Maximum size in bytes of buffers where idle-scheduler is enabled. +If this value is less than or equal to 0, idle-scheduler is enabled in +all buffers regardless of their size." + :group 'semantic + :type 'number) + +(defsubst semantic-idle-scheduler-enabled-p () + "Return non-nil if idle-scheduler is enabled for this buffer. +idle-scheduler is disabled when debugging or if the buffer size +exceeds the `semantic-idle-scheduler-max-buffer-size' threshold." + (and semantic-idle-scheduler-mode + (not (and (boundp 'semantic-debug-enabled) + semantic-debug-enabled)) + (not semantic-lex-debug) + (or (<= semantic-idle-scheduler-max-buffer-size 0) + (< (buffer-size) semantic-idle-scheduler-max-buffer-size)))) + +(defun semantic-idle-scheduler-mode-setup () + "Setup option `semantic-idle-scheduler-mode'. +The minor mode can be turned on only if semantic feature is available +and the current buffer was set up for parsing. When minor mode is +enabled parse the current buffer if needed. Return non-nil if the +minor mode is enabled." + (if semantic-idle-scheduler-mode + (if (not (and (featurep 'semantic) (semantic-active-p))) + (progn + ;; Disable minor mode if semantic stuff not available + (setq semantic-idle-scheduler-mode nil) + (error "Buffer %s was not set up idle time scheduling" + (buffer-name))) + (semantic-idle-scheduler-setup-timers))) + semantic-idle-scheduler-mode) + +;;;###autoload +(defun semantic-idle-scheduler-mode (&optional arg) + "Minor mode to auto parse buffer following a change. +When this mode is off, a buffer is only rescanned for tokens when +some command requests the list of available tokens. When idle-scheduler +is enabled, Emacs periodically checks to see if the buffer is out of +date, and reparses while the user is idle (not typing.) + +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled." + (interactive + (list (or current-prefix-arg + (if semantic-idle-scheduler-mode 0 1)))) + (setq semantic-idle-scheduler-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not semantic-idle-scheduler-mode))) + (semantic-idle-scheduler-mode-setup) + (run-hooks 'semantic-idle-scheduler-mode-hook) + (if (interactive-p) + (message "idle-scheduler minor mode %sabled" + (if semantic-idle-scheduler-mode "en" "dis"))) + (semantic-mode-line-update) + semantic-idle-scheduler-mode) + +(semantic-add-minor-mode 'semantic-idle-scheduler-mode + "ARP" + nil) + +;;; SERVICES services +;; +;; These are services for managing idle services. +;; +(defvar semantic-idle-scheduler-queue nil + "List of functions to execute during idle time. +These functions will be called in the current buffer after that +buffer has had its tags made up to date. These functions +will not be called if there are errors parsing the +current buffer.") + +(defun semantic-idle-scheduler-add (function) + "Schedule FUNCTION to occur during idle time." + (add-to-list 'semantic-idle-scheduler-queue function)) + +(defun semantic-idle-scheduler-remove (function) + "Unschedule FUNCTION to occur during idle time." + (setq semantic-idle-scheduler-queue + (delete function semantic-idle-scheduler-queue))) + +;;; IDLE Function +;; +(defun semantic-idle-core-handler () + "Core idle function that handles reparsing. +And also manages services that depend on tag values." + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: Core handler...")) + (semantic-exit-on-input 'idle-timer + (let* ((inhibit-quit nil) + (buffers (delq (current-buffer) + (delq nil + (mapcar #'(lambda (b) + (and (buffer-file-name b) + b)) + (buffer-list))))) + safe ;; This safe is not used, but could be. + others + mode) + (when (semantic-idle-scheduler-enabled-p) + (save-excursion + ;; First, reparse the current buffer. + (setq mode major-mode + safe (semantic-safe "Idle Parse Error: %S" + ;(error "Goofy error 1") + (semantic-idle-scheduler-refresh-tags) + ) + ) + ;; Now loop over other buffers with same major mode, trying to + ;; update them as well. Stop on keypress. + (dolist (b buffers) + (semantic-throw-on-input 'parsing-mode-buffers) + (with-current-buffer b + (if (eq major-mode mode) + (and (semantic-idle-scheduler-enabled-p) + (semantic-safe "Idle Parse Error: %S" + ;(error "Goofy error") + (semantic-idle-scheduler-refresh-tags))) + (push (current-buffer) others)))) + (setq buffers others)) + ;; If re-parse of current buffer completed, evaluate all other + ;; services. Stop on keypress. + + ;; NOTE ON COMMENTED SAFE HERE + ;; We used to not execute the services if the buffer wsa + ;; unparseable. We now assume that they are lexically + ;; safe to do, because we have marked the buffer unparseable + ;; if there was a problem. + ;;(when safe + (dolist (service semantic-idle-scheduler-queue) + (save-excursion + (semantic-throw-on-input 'idle-queue) + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: execture service %s..." service)) + (semantic-safe (format "Idle Service Error %s: %%S" service) + (funcall service)) + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: execture service %s...done" service)) + ))) + ;;) + ;; Finally loop over remaining buffers, trying to update them as + ;; well. Stop on keypress. + (save-excursion + (dolist (b buffers) + (semantic-throw-on-input 'parsing-other-buffers) + (with-current-buffer b + (and (semantic-idle-scheduler-enabled-p) + (semantic-idle-scheduler-refresh-tags))))) + )) + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: Core handler...done"))) + +(defun semantic-debug-idle-function () + "Run the Semantic idle function with debugging turned on." + (interactive) + (let ((debug-on-error t)) + (semantic-idle-core-handler) + )) + +(defun semantic-idle-scheduler-function () + "Function run when after `semantic-idle-scheduler-idle-time'. +This function will reparse the current buffer, and if successful, +call additional functions registered with the timer calls." + (when (zerop (recursion-depth)) + (let ((debug-on-error nil)) + (save-match-data (semantic-idle-core-handler)) + ))) + + +;;; WORK FUNCTION +;; +;; Unlike the shorter timer, the WORK timer will kick of tasks that +;; may take a long time to complete. +(defcustom semantic-idle-work-parse-neighboring-files-flag t + "*Non-nil means to parse files in the same dir as the current buffer. +Disable to prevent lots of excessive parsing in idle time." + :group 'semantic + :type 'boolean) + + +(defun semantic-idle-work-for-one-buffer (buffer) + "Do long-processing work for for BUFFER. +Uses `semantic-safe' and returns the output. +Returns t of all processing succeeded." + (save-excursion + (set-buffer buffer) + (not (and + ;; Just in case + (semantic-safe "Idle Work Parse Error: %S" + (semantic-idle-scheduler-refresh-tags) + t) + + ;; Force all our include files to get read in so we + ;; are ready to provide good smart completion and idle + ;; summary information + (semantic-safe "Idle Work Including Error: %S" + ;; Get the include related path. + (when (and (featurep 'semantic/db) (semanticdb-minor-mode-p)) + (require 'semantic/db-find) + (semanticdb-find-translate-path buffer nil) + ) + t) + + ;; Pre-build the typecaches as needed. + (semantic-safe "Idle Work Typecaching Error: %S" + (when (featurep 'semantic/db-typecache) + (semanticdb-typecache-refresh-for-buffer buffer)) + t) + )) + )) + +(defun semantic-idle-work-core-handler () + "Core handler for idle work processing of long running tasks. +Visits semantic controlled buffers, and makes sure all needed +include files have been parsed, and that the typecache is up to date. +Uses `semantic-idle-work-for-on-buffer' to do the work." + (let ((errbuf nil) + (interrupted + (semantic-exit-on-input 'idle-work-timer + (let* ((inhibit-quit nil) + (cb (current-buffer)) + (buffers (delq (current-buffer) + (delq nil + (mapcar #'(lambda (b) + (and (buffer-file-name b) + b)) + (buffer-list))))) + safe errbuf) + ;; First, handle long tasks in the current buffer. + (when (semantic-idle-scheduler-enabled-p) + (save-excursion + (setq safe (semantic-idle-work-for-one-buffer (current-buffer)) + ))) + (when (not safe) (push (current-buffer) errbuf)) + + ;; Now loop over other buffers with same major mode, trying to + ;; update them as well. Stop on keypress. + (dolist (b buffers) + (semantic-throw-on-input 'parsing-mode-buffers) + (with-current-buffer b + (when (semantic-idle-scheduler-enabled-p) + (and (semantic-idle-scheduler-enabled-p) + (unless (semantic-idle-work-for-one-buffer (current-buffer)) + (push (current-buffer) errbuf))) + )) + ) + + (when (and (featurep 'semantic/db) (semanticdb-minor-mode-p)) + ;; Save everything. + (semanticdb-save-all-db-idle) + + ;; Parse up files near our active buffer + (when semantic-idle-work-parse-neighboring-files-flag + (semantic-safe "Idle Work Parse Neighboring Files: %S" + (set-buffer cb) + (semantic-idle-scheduler-work-parse-neighboring-files)) + t) + + ;; Save everything... again + (semanticdb-save-all-db-idle) + ) + + ;; Done w/ processing + nil)))) + + ;; Done + (if interrupted + "Interrupted" + (cond ((not errbuf) + "done") + ((not (cdr errbuf)) + (format "done with 1 error in %s" (car errbuf))) + (t + (format "done with errors in %d buffers." + (length errbuf))))))) + +(defun semantic-debug-idle-work-function () + "Run the Semantic idle work function with debugging turned on." + (interactive) + (let ((debug-on-error t)) + (semantic-idle-work-core-handler) + )) + +(defun semantic-idle-scheduler-work-function () + "Function run when after `semantic-idle-scheduler-work-idle-time'. +This routine handles difficult tasks that require a lot of parsing, such as +parsing all the header files used by our active sources, or building up complex +datasets." + (when semantic-idle-scheduler-verbose-flag + (message "Long Work Idle Timer...")) + (let ((exit-type (save-match-data + (semantic-idle-work-core-handler)))) + (when semantic-idle-scheduler-verbose-flag + (message "Long Work Idle Timer...%s" exit-type))) + ) + +(defun semantic-idle-scheduler-work-parse-neighboring-files () + "Parse all the files in similar directories to buffers being edited." + ;; Lets check to see if EDE matters. + (let ((ede-auto-add-method 'never)) + (dolist (a auto-mode-alist) + (when (eq (cdr a) major-mode) + (dolist (file (directory-files default-directory t (car a) t)) + (semantic-throw-on-input 'parsing-mode-buffers) + (save-excursion + (semanticdb-file-table-object file) + )))) + )) + + +;;; REPARSING +;; +;; Reparsing is installed as semantic idle service. +;; This part ALWAYS happens, and other services occur +;; afterwards. + +(defvar semantic-before-idle-scheduler-reparse-hook nil + "Hook run before option `semantic-idle-scheduler' begins parsing. +If any hook function throws an error, this variable is reset to nil. +This hook is not protected from lexical errors.") + +(defvar semantic-after-idle-scheduler-reparse-hook nil + "Hook run after option `semantic-idle-scheduler' has parsed. +If any hook function throws an error, this variable is reset to nil. +This hook is not protected from lexical errors.") + +(semantic-varalias-obsolete 'semantic-before-idle-scheduler-reparse-hooks + 'semantic-before-idle-scheduler-reparse-hook) +(semantic-varalias-obsolete 'semantic-after-idle-scheduler-reparse-hooks + 'semantic-after-idle-scheduler-reparse-hook) + +(defun semantic-idle-scheduler-refresh-tags () + "Refreshes the current buffer's tags. +This is called by `semantic-idle-scheduler-function' to update the +tags in the current buffer. + +Return non-nil if the refresh was successful. +Return nil if there is some sort of syntax error preventing a full +reparse. + +Does nothing if the current buffer doesn't need reparsing." + + (prog1 + ;; These checks actually occur in `semantic-fetch-tags', but if we + ;; do them here, then all the bovination hooks are not run, and + ;; we save lots of time. + (cond + ;; If the buffer was previously marked unparseable, + ;; then don't waste our time. + ((semantic-parse-tree-unparseable-p) + nil) + ;; The parse tree is already ok. + ((semantic-parse-tree-up-to-date-p) + t) + (t + ;; If the buffer might need a reparse and it is safe to do so, + ;; give it a try. + (let* (;(semantic-working-type nil) + (inhibit-quit nil) + ;; (working-use-echo-area-p + ;; (not semantic-idle-scheduler-working-in-modeline-flag)) + ;; (working-status-dynamic-type + ;; (if semantic-idle-scheduler-no-working-message + ;; nil + ;; working-status-dynamic-type)) + ;; (working-status-percentage-type + ;; (if semantic-idle-scheduler-no-working-message + ;; nil + ;; working-status-percentage-type)) + (lexically-safe t) + ) + ;; Let people hook into this, but don't let them hose + ;; us over! + (condition-case nil + (run-hooks 'semantic-before-idle-scheduler-reparse-hook) + (error (setq semantic-before-idle-scheduler-reparse-hook nil))) + + (unwind-protect + ;; Perform the parsing. + (progn + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: reparse %s..." (buffer-name))) + (when (semantic-lex-catch-errors idle-scheduler + (save-excursion (semantic-fetch-tags)) + nil) + ;; If we are here, it is because the lexical step failed, + ;; proably due to unterminated lists or something like that. + + ;; We do nothing, and just wait for the next idle timer + ;; to go off. In the meantime, remember this, and make sure + ;; no other idle services can get executed. + (setq lexically-safe nil)) + (when semantic-idle-scheduler-verbose-flag + (message "IDLE: reparse %s...done" (buffer-name)))) + ;; Let people hook into this, but don't let them hose + ;; us over! + (condition-case nil + (run-hooks 'semantic-after-idle-scheduler-reparse-hook) + (error (setq semantic-after-idle-scheduler-reparse-hook nil)))) + ;; Return if we are lexically safe (from prog1) + lexically-safe))) + + ;; After updating the tags, handle any pending decorations for this + ;; buffer. + (require 'semantic/decorate/mode) + (semantic-decorate-flush-pending-decorations (current-buffer)) + )) + + +;;; IDLE SERVICES +;; +;; Idle Services are minor modes which enable or disable a services in +;; the idle scheduler. Creating a new services only requires calling +;; `semantic-create-idle-services' which does all the setup +;; needed to create the minor mode that will enable or disable +;; a services. The services must provide a single function. + +(defmacro define-semantic-idle-service (name doc &rest forms) + "Create a new idle services with NAME. +DOC will be a documentation string describing FORMS. +FORMS will be called during idle time after the current buffer's +semantic tag information has been updated. +This routines creates the following functions and variables:" + (let ((global (intern (concat "global-" (symbol-name name) "-mode"))) + (mode (intern (concat (symbol-name name) "-mode"))) + (hook (intern (concat (symbol-name name) "-mode-hook"))) + (map (intern (concat (symbol-name name) "-mode-map"))) + (setup (intern (concat (symbol-name name) "-mode-setup"))) + (func (intern (concat (symbol-name name) "-idle-function"))) + ) + + `(eval-and-compile + (defun ,global (&optional arg) + ,(concat "Toggle global use of `" (symbol-name mode) "'. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle.") + (interactive "P") + (setq ,global + (semantic-toggle-minor-mode-globally + ',mode arg))) + + (defcustom ,global nil + (concat "*If non-nil, enable global use of `" (symbol-name ',mode) "'. +" ,doc) + :group 'semantic + :group 'semantic-modes + :type 'boolean + :require 'semantic/idle + :initialize 'custom-initialize-default + :set (lambda (sym val) + (,global (if val 1 -1)))) + + (defcustom ,hook nil + (concat "*Hook run at the end of function `" (symbol-name ',mode) "'.") + :group 'semantic + :type 'hook) + + (defvar ,map + (let ((km (make-sparse-keymap))) + km) + (concat "Keymap for `" (symbol-name ',mode) "'.")) + + (defvar ,mode nil + (concat "Non-nil if summary minor mode is enabled. +Use the command `" (symbol-name ',mode) "' to change this variable.")) + (make-variable-buffer-local ',mode) + + (defun ,setup () + ,(concat "Setup option `" (symbol-name mode) "'. +The minor mode can be turned on only if semantic feature is available +and the idle scheduler is active. +Return non-nil if the minor mode is enabled.") + (if ,mode + (if (not (and (featurep 'semantic) (semantic-active-p))) + (progn + ;; Disable minor mode if semantic stuff not available + (setq ,mode nil) + (error "Buffer %s was not set up for parsing" + (buffer-name))) + ;; Enable the mode mode + (semantic-idle-scheduler-add #',func) + ) + ;; Disable the mode mode + (semantic-idle-scheduler-remove #',func) + ) + ,mode) + + (defun ,mode (&optional arg) + ,(concat doc " +This is a minor mode which performs actions during idle time. +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled.") + (interactive + (list (or current-prefix-arg + (if ,mode 0 1)))) + (setq ,mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not ,mode))) + (,setup) + (run-hooks ,hook) + (if (interactive-p) + (message "%s %sabled" + (symbol-name ',mode) + (if ,mode "en" "dis"))) + (semantic-mode-line-update) + ,mode) + + (semantic-add-minor-mode ',mode + "" ; idle schedulers are quiet? + ,map) + + (defun ,func () + ,doc + ,@forms) + + ))) +(put 'define-semantic-idle-service 'lisp-indent-function 1) + + +;;; SUMMARY MODE +;; +;; A mode similar to eldoc using semantic + +(defcustom semantic-idle-summary-function + 'semantic-format-tag-summarize-with-file + "*Function to use when displaying tag information during idle time. +Some useful functions are found in `semantic-format-tag-functions'." + :group 'semantic + :type semantic-format-tag-custom-list) + +(defsubst semantic-idle-summary-find-current-symbol-tag (sym) + "Search for a semantic tag with name SYM in database tables. +Return the tag found or nil if not found. +If semanticdb is not in use, use the current buffer only." + (car (if (and (featurep 'semantic/db) + semanticdb-current-database + (require 'semantic/db-find)) + (cdar (semanticdb-deep-find-tags-by-name sym)) + (semantic-deep-find-tags-by-name sym (current-buffer))))) + +(defun semantic-idle-summary-current-symbol-info-brutish () + "Return a string message describing the current context. +Gets a symbol with `semantic-ctxt-current-thing' and then +trys to find it with a deep targetted search." + ;; Try the current "thing". + (let ((sym (car (semantic-ctxt-current-thing)))) + (when sym + (semantic-idle-summary-find-current-symbol-tag sym)))) + +(defun semantic-idle-summary-current-symbol-keyword () + "Return a string message describing the current symbol. +Returns a value only if it is a keyword." + ;; Try the current "thing". + (let ((sym (car (semantic-ctxt-current-thing)))) + (if (and sym (semantic-lex-keyword-p sym)) + (semantic-lex-keyword-get sym 'summary)))) + +(defun semantic-idle-summary-current-symbol-info-context () + "Return a string message describing the current context. +Use the semantic analyzer to find the symbol information." + (let ((analysis (condition-case nil + (semantic-analyze-current-context (point)) + (error nil)))) + (when analysis + (require 'semantic/analyze) + (semantic-analyze-interesting-tag analysis)))) + +(defun semantic-idle-summary-current-symbol-info-default () + "Return a string message describing the current context. +This functin will disable loading of previously unloaded files +by semanticdb as a time-saving measure." + (let ( + (semanticdb-find-default-throttle + (if (featurep 'semantic/db-find) + (remq 'unloaded semanticdb-find-default-throttle) + nil)) + ) + (save-excursion + ;; use whicever has success first. + (or + (semantic-idle-summary-current-symbol-keyword) + + (semantic-idle-summary-current-symbol-info-context) + + (semantic-idle-summary-current-symbol-info-brutish) + )))) + +(defvar semantic-idle-summary-out-of-context-faces + '( + font-lock-comment-face + font-lock-string-face + font-lock-doc-string-face ; XEmacs. + font-lock-doc-face ; Emacs 21 and later. + ) + "List of font-lock faces that indicate a useless summary context. +Those are generally faces used to highlight comments. + +It might be useful to override this variable to add comment faces +specific to a major mode. For example, in jde mode: + +\(defvar-mode-local jde-mode semantic-idle-summary-out-of-context-faces + (append (default-value 'semantic-idle-summary-out-of-context-faces) + '(jde-java-font-lock-doc-tag-face + jde-java-font-lock-link-face + jde-java-font-lock-bold-face + jde-java-font-lock-underline-face + jde-java-font-lock-pre-face + jde-java-font-lock-code-face)))") + +(defun semantic-idle-summary-useful-context-p () + "Non-nil of we should show a summary based on context." + (if (and (boundp 'font-lock-mode) + font-lock-mode + (memq (get-text-property (point) 'face) + semantic-idle-summary-out-of-context-faces)) + ;; The best I can think of at the moment is to disable + ;; in comments by detecting with font-lock. + nil + t)) + +(define-overloadable-function semantic-idle-summary-current-symbol-info () + "Return a string message describing the current context.") + +(make-obsolete-overload 'semantic-eldoc-current-symbol-info + 'semantic-idle-summary-current-symbol-info) + +(define-semantic-idle-service semantic-idle-summary + "Display a tag summary of the lexical token under the cursor. +Call `semantic-idle-summary-current-symbol-info' for getting the +current tag to display information." + (or (eq major-mode 'emacs-lisp-mode) + (not (semantic-idle-summary-useful-context-p)) + (let* ((found (semantic-idle-summary-current-symbol-info)) + (str (cond ((stringp found) found) + ((semantic-tag-p found) + (funcall semantic-idle-summary-function + found nil t)))) + ) + ;; Show the message with eldoc functions + (require 'eldoc) + (unless (and str (boundp 'eldoc-echo-area-use-multiline-p) + eldoc-echo-area-use-multiline-p) + (let ((w (1- (window-width (minibuffer-window))))) + (if (> (length str) w) + (setq str (substring str 0 w))))) + (eldoc-message str)))) + +;;; Current symbol highlight +;; +;; This mode will use context analysis to perform highlighting +;; of all uses of the symbol that is under the cursor. +;; +;; This is to mimic the Eclipse tool of a similar nature. +(defvar semantic-idle-summary-highlight-face 'region + "Face used for the summary highlight.") + +(defun semantic-idle-summary-maybe-highlight (tag) + "Perhaps add highlighting onto TAG. +TAG was found as the thing under point. If it happens to be +visible, then highlight it." + (require 'pulse) + (let* ((region (when (and (semantic-tag-p tag) + (semantic-tag-with-position-p tag)) + (semantic-tag-overlay tag))) + (file (when (and (semantic-tag-p tag) + (semantic-tag-with-position-p tag)) + (semantic-tag-file-name tag))) + (buffer (when file (get-file-buffer file))) + ;; We use pulse, but we don't want the flashy version, + ;; just the stable version. + (pulse-flag nil) + ) + (cond ((semantic-overlay-p region) + (save-excursion + (set-buffer (semantic-overlay-buffer region)) + (goto-char (semantic-overlay-start region)) + (when (pos-visible-in-window-p + (point) (get-buffer-window (current-buffer) 'visible)) + (if (< (semantic-overlay-end region) (point-at-eol)) + (pulse-momentary-highlight-overlay + region semantic-idle-summary-highlight-face) + ;; Not the same + (pulse-momentary-highlight-region + (semantic-overlay-start region) + (point-at-eol) + semantic-idle-summary-highlight-face))) + )) + ((vectorp region) + (let ((start (aref region 0)) + (end (aref region 1))) + (save-excursion + (when buffer (set-buffer buffer)) + ;; As a vector, we have no filename. Perhaps it is a + ;; local variable? + (when (and (<= end (point-max)) + (pos-visible-in-window-p + start (get-buffer-window (current-buffer) 'visible))) + (goto-char start) + (when (re-search-forward + (regexp-quote (semantic-tag-name tag)) + end t) + ;; This is likely it, give it a try. + (pulse-momentary-highlight-region + start (if (<= end (point-at-eol)) end + (point-at-eol)) + semantic-idle-summary-highlight-face))) + )))) + nil)) + +(define-semantic-idle-service semantic-idle-tag-highlight + "Highlight the tag, and references of the symbol under point. +Call `semantic-analyze-current-context' to find the reference tag. +Call `semantic-symref-hits-in-region' to identify local references." + (require 'pulse) + (when (semantic-idle-summary-useful-context-p) + (let* ((ctxt (semantic-analyze-current-context)) + (Hbounds (when ctxt (oref ctxt bounds))) + (target (when ctxt (car (reverse (oref ctxt prefix))))) + (tag (semantic-current-tag)) + ;; We use pulse, but we don't want the flashy version, + ;; just the stable version. + (pulse-flag nil)) + (when ctxt + ;; Highlight the original tag? Protect against problems. + (condition-case nil + (semantic-idle-summary-maybe-highlight target) + (error nil)) + ;; Identify all hits in this current tag. + (when (semantic-tag-p target) + (require 'semantic/symref/filter) + (semantic-symref-hits-in-region + target (lambda (start end prefix) + (when (/= start (car Hbounds)) + (pulse-momentary-highlight-region + start end)) + (semantic-throw-on-input 'symref-highlight) + ) + (semantic-tag-start tag) + (semantic-tag-end tag))) + )))) + + +;;; Completion Popup Mode +;; +;; This mode uses tooltips to display a (hopefully) short list of possible +;; completions available for the text under point. It provides +;; NO provision for actually filling in the values from those completions. + +(defun semantic-idle-completion-list-default () + "Calculate and display a list of completions." + (when (semantic-idle-summary-useful-context-p) + ;; This mode can be fragile. Ignore problems. + ;; If something doesn't do what you expect, run + ;; the below command by hand instead. + (condition-case nil + (let ( + ;; Don't go loading in oodles of header libraries in + ;; IDLE time. + (semanticdb-find-default-throttle + (if (featurep 'semantic/db-find) + (remq 'unloaded semanticdb-find-default-throttle) + nil)) + ) + ;; Use idle version. + (require 'semantic/complete) + (semantic-complete-analyze-inline-idle) + ) + (error nil)) + )) + +(define-semantic-idle-service semantic-idle-completions + "Display a list of possible completions in a tooltip." + ;; Add the ability to override sometime. + (semantic-idle-completion-list-default)) + +(provide 'semantic/idle) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/idle" +;; End: + +;;; semantic-idle.el ends here diff --git a/lisp/cedet/semantic/java.el b/lisp/cedet/semantic/java.el new file mode 100644 index 00000000000..b7f2e9a16b0 --- /dev/null +++ b/lisp/cedet/semantic/java.el @@ -0,0 +1,462 @@ +;;; semantic/java.el --- Semantic functions for Java + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: David Ponce <david@dponce.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Common function for Java parsers. + +;;; Code: +(require 'semantic) +(require 'semantic/ctxt) +(require 'semantic/doc) +(require 'semantic/format) + +(eval-when-compile + (require 'semantic/find) + (require 'semantic/dep)) + + +;;; Lexical analysis +;; +(defconst semantic-java-number-regexp + (eval-when-compile + (concat "\\(" + "\\<[0-9]+[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>" + "\\|" + "\\<[0-9]+[.][eE][-+]?[0-9]+[fFdD]?\\>" + "\\|" + "\\<[0-9]+[.][fFdD]\\>" + "\\|" + "\\<[0-9]+[.]" + "\\|" + "[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>" + "\\|" + "\\<[0-9]+[eE][-+]?[0-9]+[fFdD]?\\>" + "\\|" + "\\<0[xX][0-9a-fA-F]+[lL]?\\>" + "\\|" + "\\<[0-9]+[lLfFdD]?\\>" + "\\)" + )) + "Lexer regexp to match Java number terminals. +Following is the specification of Java number literals. + +DECIMAL_LITERAL: + [1-9][0-9]* + ; +HEX_LITERAL: + 0[xX][0-9a-fA-F]+ + ; +OCTAL_LITERAL: + 0[0-7]* + ; +INTEGER_LITERAL: + <DECIMAL_LITERAL>[lL]? + | <HEX_LITERAL>[lL]? + | <OCTAL_LITERAL>[lL]? + ; +EXPONENT: + [eE][+-]?[09]+ + ; +FLOATING_POINT_LITERAL: + [0-9]+[.][0-9]*<EXPONENT>?[fFdD]? + | [.][0-9]+<EXPONENT>?[fFdD]? + | [0-9]+<EXPONENT>[fFdD]? + | [0-9]+<EXPONENT>?[fFdD] + ;") + +;;; Parsing +;; +(defsubst semantic-java-dim (id) + "Split ID string into a pair (NAME . DIM). +NAME is ID without trailing brackets: \"[]\". +DIM is the dimension of NAME deduced from the number of trailing +brackets, or 0 if there is no trailing brackets." + (let ((dim (string-match "\\(\\[]\\)+\\'" id))) + (if dim + (cons (substring id 0 dim) + (/ (length (match-string 0 id)) 2)) + (cons id 0)))) + +(defsubst semantic-java-type (tag) + "Return the type of TAG, taking care of array notation." + (let ((type (semantic-tag-type tag)) + (dim (semantic-tag-get-attribute tag :dereference))) + (when dim + (while (> dim 0) + (setq type (concat type "[]") + dim (1- dim)))) + type)) + +(defun semantic-java-expand-tag (tag) + "Expand compound declarations found in TAG into separate tags. +TAG contains compound declarations when its class is `variable', and +its name is a list of elements (NAME START . END), where NAME is a +compound variable name, and START/END are the bounds of the +corresponding compound declaration." + (let* ((class (semantic-tag-class tag)) + (elts (semantic-tag-name tag)) + dim type dim0 elt clone start end xpand) + (cond + ((and (eq class 'function) + (> (cdr (setq dim (semantic-java-dim elts))) 0)) + (setq clone (semantic-tag-clone tag (car dim)) + xpand (cons clone xpand)) + (semantic-tag-put-attribute clone :dereference (cdr dim))) + ((eq class 'variable) + (or (consp elts) (setq elts (list (list elts)))) + (setq dim (semantic-java-dim (semantic-tag-get-attribute tag :type)) + type (car dim) + dim0 (cdr dim)) + (while elts + ;; For each compound element, clone the initial tag with the + ;; name and bounds of the compound variable declaration. + (setq elt (car elts) + elts (cdr elts) + start (if elts (cadr elt) (semantic-tag-start tag)) + end (if xpand (cddr elt) (semantic-tag-end tag)) + dim (semantic-java-dim (car elt)) + clone (semantic-tag-clone tag (car dim)) + xpand (cons clone xpand)) + (semantic-tag-put-attribute clone :type type) + (semantic-tag-put-attribute clone :dereference (+ dim0 (cdr dim))) + (semantic-tag-set-bounds clone start end))) + ) + xpand)) + +;;; Environment +;; +(defcustom-mode-local-semantic-dependency-system-include-path + java-mode semantic-java-dependency-system-include-path + ;; @todo - Use JDEE to get at the include path, or something else? + nil + "The system include path used by Java langauge.") + +;; Local context +;; +(define-mode-local-override semantic-ctxt-scoped-types + java-mode (&optional point) + "Return a list of type names currently in scope at POINT." + (mapcar 'semantic-tag-name + (semantic-find-tags-by-class + 'type (semantic-find-tag-by-overlay point)))) + +;; Prototype handler +;; +(defun semantic-java-prototype-function (tag &optional parent color) + "Return a function (method) prototype for TAG. +Optional argument PARENT is a parent (containing) item. +Optional argument COLOR indicates that color should be mixed in. +See also `semantic-format-tag-prototype'." + (let ((name (semantic-tag-name tag)) + (type (semantic-java-type tag)) + (tmpl (semantic-tag-get-attribute tag :template-specifier)) + (args (semantic-tag-function-arguments tag)) + (argp "") + arg argt) + (while args + (setq arg (car args) + args (cdr args)) + (if (semantic-tag-p arg) + (setq argt (if color + (semantic--format-colorize-text + (semantic-java-type arg) 'type) + (semantic-java-type arg)) + argp (concat argp argt (if args "," ""))))) + (when color + (when type + (setq type (semantic--format-colorize-text type 'type))) + (setq name (semantic--format-colorize-text name 'function))) + (concat (or tmpl "") (if tmpl " " "") + (or type "") (if type " " "") + name "(" argp ")"))) + +(defun semantic-java-prototype-variable (tag &optional parent color) + "Return a variable (field) prototype for TAG. +Optional argument PARENT is a parent (containing) item. +Optional argument COLOR indicates that color should be mixed in. +See also `semantic-format-tag-prototype'." + (let ((name (semantic-tag-name tag)) + (type (semantic-java-type tag))) + (concat (if color + (semantic--format-colorize-text type 'type) + type) + " " + (if color + (semantic--format-colorize-text name 'variable) + name)))) + +(defun semantic-java-prototype-type (tag &optional parent color) + "Return a type (class/interface) prototype for TAG. +Optional argument PARENT is a parent (containing) item. +Optional argument COLOR indicates that color should be mixed in. +See also `semantic-format-tag-prototype'." + (let ((name (semantic-tag-name tag)) + (type (semantic-tag-type tag)) + (tmpl (semantic-tag-get-attribute tag :template-specifier))) + (concat type " " + (if color + (semantic--format-colorize-text name 'type) + name) + (or tmpl "")))) + +(define-mode-local-override semantic-format-tag-prototype + java-mode (tag &optional parent color) + "Return a prototype for TOKEN. +Optional argument PARENT is a parent (containing) item. +Optional argument COLOR indicates that color should be mixed in." + (let ((f (intern-soft (format "semantic-java-prototype-%s" + (semantic-tag-class tag))))) + (funcall (if (fboundp f) + f + 'semantic-format-tag-prototype-default) + tag parent color))) + +(semantic-alias-obsolete 'semantic-java-prototype-nonterminal + 'semantic-format-tag-prototype-java-mode) + +;; Include Tag Name +;; + +;; Thanks Bruce Stephens +(define-mode-local-override semantic-tag-include-filename java-mode (tag) + "Return a suitable path for (some) Java imports" + (let ((name (semantic-tag-name tag))) + (concat (mapconcat 'identity (split-string name "\\.") "/") ".java"))) + + +;; Documentation handler +;; +(defsubst semantic-java-skip-spaces-backward () + "Move point backward, skipping Java whitespaces." + (skip-chars-backward " \n\r\t")) + +(defsubst semantic-java-skip-spaces-forward () + "Move point forward, skipping Java whitespaces." + (skip-chars-forward " \n\r\t")) + +(define-mode-local-override semantic-documentation-for-tag + java-mode (&optional tag nosnarf) + "Find documentation from TAG and return it as a clean string. +Java have documentation set in a comment preceeding TAG's definition. +Attempt to strip out comment syntactic sugar, unless optional argument +NOSNARF is non-nil. +If NOSNARF is 'lex, then return the semantic lex token." + (when (or tag (setq tag (semantic-current-tag))) + (with-current-buffer (semantic-tag-buffer tag) + (save-excursion + ;; Move the point at token start + (goto-char (semantic-tag-start tag)) + (semantic-java-skip-spaces-forward) + ;; If the point already at "/**" (this occurs after a doc fix) + (if (looking-at "/\\*\\*") + nil + ;; Skip previous spaces + (semantic-java-skip-spaces-backward) + ;; Ensure point is after "*/" (javadoc block comment end) + (condition-case nil + (backward-char 2) + (error nil)) + (when (looking-at "\\*/") + ;; Move the point backward across the comment + (forward-char 2) ; return just after "*/" + (forward-comment -1) ; to skip the entire block + )) + ;; Verify the point is at "/**" (javadoc block comment start) + (if (looking-at "/\\*\\*") + (let ((p (point)) + (c (semantic-doc-snarf-comment-for-tag 'lex))) + (when c + ;; Verify that the token just following the doc + ;; comment is the current one! + (goto-char (semantic-lex-token-end c)) + (semantic-java-skip-spaces-forward) + (when (eq tag (semantic-current-tag)) + (goto-char p) + (semantic-doc-snarf-comment-for-tag nosnarf))))) + )))) + +;;; Javadoc facilities +;; + +;; Javadoc elements +;; +(defvar semantic-java-doc-line-tags nil + "Valid javadoc line tags. +Ordered following Sun's Tag Convention at +<http://java.sun.com/products/jdk/javadoc/writingdoccomments/index.html>") + +(defvar semantic-java-doc-with-name-tags nil + "Javadoc tags which have a name.") + +(defvar semantic-java-doc-with-ref-tags nil + "Javadoc tags which have a reference.") + +;; Optional javadoc tags by classes of semantic tag +;; +(defvar semantic-java-doc-extra-type-tags nil + "Optional tags used in class/interface documentation. +Ordered following Sun's Tag Convention.") + +(defvar semantic-java-doc-extra-function-tags nil + "Optional tags used in method/constructor documentation. +Ordered following Sun's Tag Convention.") + +(defvar semantic-java-doc-extra-variable-tags nil + "Optional tags used in field documentation. +Ordered following Sun's Tag Convention.") + +;; All javadoc tags by classes of semantic tag +;; +(defvar semantic-java-doc-type-tags nil + "Tags allowed in class/interface documentation. +Ordered following Sun's Tag Convention.") + +(defvar semantic-java-doc-function-tags nil + "Tags allowed in method/constructor documentation. +Ordered following Sun's Tag Convention.") + +(defvar semantic-java-doc-variable-tags nil + "Tags allowed in field documentation. +Ordered following Sun's Tag Convention.") + +;; Access to Javadoc elements +;; +(defmacro semantic-java-doc-tag (name) + "Return doc tag from NAME. +That is @NAME." + `(concat "@" ,name)) + +(defsubst semantic-java-doc-tag-name (tag) + "Return name of the doc TAG symbol. +That is TAG `symbol-name' without the leading '@'." + (substring (symbol-name tag) 1)) + +(defun semantic-java-doc-keyword-before-p (k1 k2) + "Return non-nil if javadoc keyword K1 is before K2." + (let* ((t1 (semantic-java-doc-tag k1)) + (t2 (semantic-java-doc-tag k2)) + (seq1 (and (semantic-lex-keyword-p t1) + (plist-get (semantic-lex-keyword-get t1 'javadoc) + 'seq))) + (seq2 (and (semantic-lex-keyword-p t2) + (plist-get (semantic-lex-keyword-get t2 'javadoc) + 'seq)))) + (if (and (numberp seq1) (numberp seq2)) + (<= seq1 seq2) + ;; Unknown tags (probably custom ones) are always after official + ;; ones and are not themselves ordered. + (or (numberp seq1) + (and (not seq1) (not seq2)))))) + +(defun semantic-java-doc-keywords-map (fun &optional property) + "Run function FUN for each javadoc keyword. +Return the list of FUN results. If optional PROPERTY is non nil only +call FUN for javadoc keyword which have a value for PROPERTY. FUN +receives two arguments: the javadoc keyword and its associated +'javadoc property list. It can return any value. Nil values are +removed from the result list." + (delq nil + (mapcar + #'(lambda (k) + (let* ((tag (semantic-java-doc-tag k)) + (plist (semantic-lex-keyword-get tag 'javadoc))) + (if (or (not property) (plist-get plist property)) + (funcall fun k plist)))) + semantic-java-doc-line-tags))) + + +;;; Mode setup +;; + +(defun semantic-java-doc-setup () + "Lazy initialization of javadoc elements." + (or semantic-java-doc-line-tags + (setq semantic-java-doc-line-tags + (sort (mapcar #'semantic-java-doc-tag-name + (semantic-lex-keywords 'javadoc)) + #'semantic-java-doc-keyword-before-p))) + + (or semantic-java-doc-with-name-tags + (setq semantic-java-doc-with-name-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + k) + 'with-name))) + + (or semantic-java-doc-with-ref-tags + (setq semantic-java-doc-with-ref-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + k) + 'with-ref))) + + (or semantic-java-doc-extra-type-tags + (setq semantic-java-doc-extra-type-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'type (plist-get p 'usage)) + k)) + 'opt))) + + (or semantic-java-doc-extra-function-tags + (setq semantic-java-doc-extra-function-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'function (plist-get p 'usage)) + k)) + 'opt))) + + (or semantic-java-doc-extra-variable-tags + (setq semantic-java-doc-extra-variable-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'variable (plist-get p 'usage)) + k)) + 'opt))) + + (or semantic-java-doc-type-tags + (setq semantic-java-doc-type-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'type (plist-get p 'usage)) + k))))) + + (or semantic-java-doc-function-tags + (setq semantic-java-doc-function-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'function (plist-get p 'usage)) + k))))) + + (or semantic-java-doc-variable-tags + (setq semantic-java-doc-variable-tags + (semantic-java-doc-keywords-map + #'(lambda (k p) + (if (memq 'variable (plist-get p 'usage)) + k))))) + + ) + +(provide 'semantic/java) + +;;; semantic/java.el ends here diff --git a/lisp/cedet/semantic/lex-spp.el b/lisp/cedet/semantic/lex-spp.el new file mode 100644 index 00000000000..edd377f2ab4 --- /dev/null +++ b/lisp/cedet/semantic/lex-spp.el @@ -0,0 +1,1198 @@ +;;; lex-spp.el --- Semantic Lexical Pre-processor + +;;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; The Semantic Preprocessor works with semantic-lex to provide a phase +;; during lexical analysis to do the work of a pre-processor. +;; +;; A pre-processor identifies lexical syntax mixed in with another language +;; and replaces some keyword tokens with streams of alternate tokens. +;; +;; If you use SPP in your language, be sure to specify this in your +;; semantic language setup function: +;; +;; (add-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook nil t) +;; +;; +;; Special Lexical Tokens: +;; +;; There are several special lexical tokens that are used by the +;; Semantic PreProcessor lexer. They are: +;; +;; Declarations: +;; spp-macro-def - A definition of a lexical macro. +;; spp-macro-undef - A removal of a definition of a lexical macro. +;; spp-system-include - A system level include file +;; spp-include - An include file +;; spp-concat - A lexical token representing textual concatenation +;; of symbol parts. +;; +;; Operational tokens: +;; spp-arg-list - Represents an argument list to a macro. +;; spp-symbol-merge - A request for multiple symbols to be textually merged. +;; +;;; TODO: +;; +;; Use `semantic-push-parser-warning' for situations where there are likely +;; macros that are undefined unexpectedly, or other problem. +;; +;; TODO: +;; +;; Try to handle the case of: +;; +;; #define NN namespace nn { +;; #define NN_END } +;; +;; NN +;; int mydecl() {} +;; NN_END +;; + +(require 'semantic) +(require 'semantic/lex) + +;;; Code: +(defvar semantic-lex-spp-macro-symbol-obarray nil + "Table of macro keywords used by the Semantic Preprocessor. +These symbols will be used in addition to those in +`semantic-lex-spp-dynamic-macro-symbol-obarray'.") +(make-variable-buffer-local 'semantic-lex-spp-macro-symbol-obarray) + +(defvar semantic-lex-spp-project-macro-symbol-obarray nil + "Table of macro keywords for this project. +These symbols will be used in addition to those in +`semantic-lex-spp-dynamic-macro-symbol-obarray'.") +(make-variable-buffer-local 'semantic-lex-spp-project-macro-symbol-obarray) + +(defvar semantic-lex-spp-dynamic-macro-symbol-obarray nil + "Table of macro keywords used during lexical analysis. +Macros are lexical symbols which are replaced by other lexical +tokens during lexical analysis. During analysis symbols can be +added and removed from this symbol table.") +(make-variable-buffer-local 'semantic-lex-spp-dynamic-macro-symbol-obarray) + +(defvar semantic-lex-spp-dynamic-macro-symbol-obarray-stack nil + "A stack of obarrays for temporarilly scoped macro values.") +(make-variable-buffer-local 'semantic-lex-spp-dynamic-macro-symbol-obarray-stack) + +(defvar semantic-lex-spp-expanded-macro-stack nil + "The stack of lexical SPP macros we have expanded.") +;; The above is not buffer local. Some macro expansions need to be +;; dumped into a secondary buffer for re-lexing. + +;;; NON-RECURSIVE MACRO STACK +;; C Pre-processor does not allow recursive macros. Here are some utils +;; for managing the symbol stack of where we've been. + +(defmacro semantic-lex-with-macro-used (name &rest body) + "With the macro NAME currently being expanded, execute BODY. +Pushes NAME into the macro stack. The above stack is checked +by `semantic-lex-spp-symbol' to not return true for any symbol +currently being expanded." + `(unwind-protect + (progn + (push ,name semantic-lex-spp-expanded-macro-stack) + ,@body) + (pop semantic-lex-spp-expanded-macro-stack))) +(put 'semantic-lex-with-macro-used 'lisp-indent-function 1) + +(add-hook + 'edebug-setup-hook + #'(lambda () + + (def-edebug-spec semantic-lex-with-macro-used + (symbolp def-body) + ) + + )) + +;;; MACRO TABLE UTILS +;; +;; The dynamic macro table is a buffer local variable that is modified +;; during the analysis. OBARRAYs are used, so the language must +;; have symbols that are compatible with Emacs Lisp symbols. +;; +(defsubst semantic-lex-spp-symbol (name) + "Return spp symbol with NAME or nil if not found. +The searcy priority is: + 1. DYNAMIC symbols + 2. PROJECT specified symbols. + 3. SYSTEM specified symbols." + (and + ;; Only strings... + (stringp name) + ;; Make sure we don't recurse. + (not (member name semantic-lex-spp-expanded-macro-stack)) + ;; Do the check of the various tables. + (or + ;; DYNAMIC + (and (arrayp semantic-lex-spp-dynamic-macro-symbol-obarray) + (intern-soft name semantic-lex-spp-dynamic-macro-symbol-obarray)) + ;; PROJECT + (and (arrayp semantic-lex-spp-project-macro-symbol-obarray) + (intern-soft name semantic-lex-spp-project-macro-symbol-obarray)) + ;; SYSTEM + (and (arrayp semantic-lex-spp-macro-symbol-obarray) + (intern-soft name semantic-lex-spp-macro-symbol-obarray)) + ;; ... + ))) + +(defsubst semantic-lex-spp-symbol-p (name) + "Return non-nil if a keyword with NAME exists in any keyword table." + (if (semantic-lex-spp-symbol name) + t)) + +(defsubst semantic-lex-spp-dynamic-map () + "Return the dynamic macro map for the current buffer." + (or semantic-lex-spp-dynamic-macro-symbol-obarray + (setq semantic-lex-spp-dynamic-macro-symbol-obarray + (make-vector 13 0)))) + +(defsubst semantic-lex-spp-dynamic-map-stack () + "Return the dynamic macro map for the current buffer." + (or semantic-lex-spp-dynamic-macro-symbol-obarray-stack + (setq semantic-lex-spp-dynamic-macro-symbol-obarray-stack + (make-vector 13 0)))) + +(defun semantic-lex-spp-symbol-set (name value &optional obarray-in) + "Set value of spp symbol with NAME to VALUE and return VALUE. +If optional OBARRAY-IN is non-nil, then use that obarray instead of +the dynamic map." + (if (and (stringp value) (string= value "")) (setq value nil)) + (set (intern name (or obarray-in + (semantic-lex-spp-dynamic-map))) + value)) + +(defsubst semantic-lex-spp-symbol-remove (name &optional obarray) + "Remove the spp symbol with NAME. +If optional OBARRAY is non-nil, then use that obarray instead of +the dynamic map." + (unintern name (or obarray + (semantic-lex-spp-dynamic-map)))) + +(defun semantic-lex-spp-symbol-push (name value) + "Push macro NAME with VALUE into the map. +Reverse with `semantic-lex-spp-symbol-pop'." + (let* ((map (semantic-lex-spp-dynamic-map)) + (stack (semantic-lex-spp-dynamic-map-stack)) + (mapsym (intern name map)) + (stacksym (intern name stack)) + (mapvalue (when (boundp mapsym) (symbol-value mapsym))) + ) + (when (boundp mapsym) + ;; Make sure there is a stack + (if (not (boundp stacksym)) (set stacksym nil)) + ;; If there is a value to push, then push it. + (set stacksym (cons mapvalue (symbol-value stacksym))) + ) + ;; Set our new value here. + (set mapsym value) + )) + +(defun semantic-lex-spp-symbol-pop (name) + "Pop macro NAME from the stackmap into the orig map. +Reverse with `semantic-lex-spp-symbol-pop'." + (let* ((map (semantic-lex-spp-dynamic-map)) + (stack (semantic-lex-spp-dynamic-map-stack)) + (mapsym (intern name map)) + (stacksym (intern name stack)) + (oldvalue nil) + ) + (if (or (not (boundp stacksym) ) + (= (length (symbol-value stacksym)) 0)) + ;; Nothing to pop, remove it. + (unintern name map) + ;; If there is a value to pop, then add it to the map. + (set mapsym (car (symbol-value stacksym))) + (set stacksym (cdr (symbol-value stacksym))) + ))) + +(defsubst semantic-lex-spp-symbol-stream (name) + "Return replacement stream of macro with NAME." + (let ((spp (semantic-lex-spp-symbol name))) + (if spp + (symbol-value spp)))) + +(defun semantic-lex-make-spp-table (specs) + "Convert spp macro list SPECS into an obarray and return it. +SPECS must be a list of (NAME . REPLACEMENT) elements, where: + +NAME is the name of the spp macro symbol to define. +REPLACEMENT a string that would be substituted in for NAME." + + ;; Create the symbol hash table + (let ((semantic-lex-spp-macro-symbol-obarray (make-vector 13 0)) + spec) + ;; fill it with stuff + (while specs + (setq spec (car specs) + specs (cdr specs)) + (semantic-lex-spp-symbol-set + (car spec) + (cdr spec) + semantic-lex-spp-macro-symbol-obarray)) + semantic-lex-spp-macro-symbol-obarray)) + +(defun semantic-lex-spp-save-table () + "Return a list of spp macros and values. +The return list is meant to be saved in a semanticdb table." + (let (macros) + (when (arrayp semantic-lex-spp-dynamic-macro-symbol-obarray) + (mapatoms + #'(lambda (symbol) + (setq macros (cons (cons (symbol-name symbol) + (symbol-value symbol)) + macros))) + semantic-lex-spp-dynamic-macro-symbol-obarray)) + macros)) + +(defun semantic-lex-spp-macros () + "Return a list of spp macros as Lisp symbols. +The value of each symbol is the replacement stream." + (let (macros) + (when (arrayp semantic-lex-spp-macro-symbol-obarray) + (mapatoms + #'(lambda (symbol) + (setq macros (cons symbol macros))) + semantic-lex-spp-macro-symbol-obarray)) + (when (arrayp semantic-lex-spp-project-macro-symbol-obarray) + (mapatoms + #'(lambda (symbol) + (setq macros (cons symbol macros))) + semantic-lex-spp-project-macro-symbol-obarray)) + (when (arrayp semantic-lex-spp-dynamic-macro-symbol-obarray) + (mapatoms + #'(lambda (symbol) + (setq macros (cons symbol macros))) + semantic-lex-spp-dynamic-macro-symbol-obarray)) + macros)) + +(defun semantic-lex-spp-set-dynamic-table (new-entries) + "Set the dynamic symbol table to NEW-ENTRIES. +For use with semanticdb restoration of state." + (dolist (e new-entries) + ;; Default obarray for below is the dynamic map. + (semantic-lex-spp-symbol-set (car e) (cdr e)))) + +(defun semantic-lex-spp-reset-hook (start end) + "Reset anything needed by SPP for parsing. +In this case, reset the dynamic macro symbol table if +START is (point-min). +END is not used." + (when (= start (point-min)) + (setq semantic-lex-spp-dynamic-macro-symbol-obarray nil + semantic-lex-spp-dynamic-macro-symbol-obarray-stack nil + ;; This shouldn't not be nil, but reset just in case. + semantic-lex-spp-expanded-macro-stack nil) + )) + +;;; MACRO EXPANSION: Simple cases +;; +;; If a user fills in the table with simple strings, we can +;; support that by converting them into tokens with the +;; various analyzers that are available. + +(defun semantic-lex-spp-extract-regex-and-compare (analyzer value) + "Extract a regexp from an ANALYZER and use to match VALUE. +Return non-nil if it matches" + (let* ((condition (car analyzer)) + (regex (cond ((eq (car condition) 'looking-at) + (nth 1 condition)) + (t + nil)))) + (when regex + (string-match regex value)) + )) + +(defun semantic-lex-spp-simple-macro-to-macro-stream (val beg end argvalues) + "Convert lexical macro contents VAL into a macro expansion stream. +These are for simple macro expansions that a user may have typed in directly. +As such, we need to analyze the input text, to figure out what kind of real +lexical token we should be inserting in its place. + +Argument VAL is the value of some macro to be converted into a stream. +BEG and END are the token bounds of the macro to be expanded +that will somehow gain a much longer token stream. +ARGVALUES are values for any arg list, or nil." + (cond + ;; We perform a replacement. Technically, this should + ;; be a full lexical step over the "val" string, but take + ;; a guess that its just a keyword or existing symbol. + ;; + ;; Probably a really bad idea. See how it goes. + ((semantic-lex-spp-extract-regex-and-compare + semantic-lex-symbol-or-keyword val) + (semantic-lex-push-token + (semantic-lex-token (or (semantic-lex-keyword-p val) 'symbol) + beg end + val))) + + ;; Ok, the rest of these are various types of syntax. + ;; Conveniences for users that type in their symbol table. + ((semantic-lex-spp-extract-regex-and-compare + semantic-lex-punctuation val) + (semantic-lex-token 'punctuation beg end val)) + ((semantic-lex-spp-extract-regex-and-compare + semantic-lex-number val) + (semantic-lex-token 'number beg end val)) + ((semantic-lex-spp-extract-regex-and-compare + semantic-lex-paren-or-list val) + (semantic-lex-token 'semantic-list beg end val)) + ((semantic-lex-spp-extract-regex-and-compare + semantic-lex-string val) + (semantic-lex-token 'string beg end val)) + (t nil) + )) + +;;; MACRO EXPANSION : Lexical token replacement +;; +;; When substituting in a macro from a token stream of formatted +;; semantic lex tokens, things can be much more complicated. +;; +;; Some macros have arguments that get set into the dynamic macro +;; table during replacement. +;; +;; In general, the macro tokens are substituted into the regular +;; token stream, but placed under the characters of the original +;; macro symbol. +;; +;; Argument lists are saved as a lexical token at the beginning +;; of a replacement value. + +(defun semantic-lex-spp-one-token-to-txt (tok &optional blocktok) + "Convert the token TOK into a string. +If TOK is made of multiple tokens, convert those to text. This +conversion is needed if a macro has a merge symbol in it that +combines the text of two previously distinct symbols. For +exampe, in c: + +#define (a,b) a ## b; + +If optional string BLOCKTOK matches the expanded value, then do not +continue processing recursively." + (let ((txt (semantic-lex-token-text tok)) + (sym nil) + ) + (cond + ;; Recursion prevention + ((and (stringp blocktok) (string= txt blocktok)) + blocktok) + ;; A complex symbol + ((and (eq (car tok) 'symbol) + (setq sym (semantic-lex-spp-symbol txt)) + (not (semantic-lex-spp-macro-with-args (symbol-value sym))) + ) + ;; Now that we have a symbol, + (let ((val (symbol-value sym))) + (cond + ;; This is another lexical token. + ((and (consp val) + (symbolp (car val))) + (semantic-lex-spp-one-token-to-txt val txt)) + ;; This is a list of tokens. + ((and (consp val) + (consp (car val)) + (symbolp (car (car val)))) + (mapconcat (lambda (subtok) + (semantic-lex-spp-one-token-to-txt subtok)) + val + "")) + ;; If val is nil, that's probably wrong. + ;; Found a system header case where this was true. + ((null val) "") + ;; Debug wierd stuff. + (t (debug))) + )) + ((stringp txt) + txt) + (t nil)) + )) + +(defun semantic-lex-spp-macro-with-args (val) + "If the macro value VAL has an argument list, return the arglist." + (when (and val (consp val) (consp (car val)) + (eq 'spp-arg-list (car (car val)))) + (car (cdr (car val))))) + +(defun semantic-lex-spp-token-macro-to-macro-stream (val beg end argvalues) + "Convert lexical macro contents VAL into a macro expansion stream. +Argument VAL is the value of some macro to be converted into a stream. +BEG and END are the token bounds of the macro to be expanded +that will somehow gain a much longer token stream. +ARGVALUES are values for any arg list, or nil. +See comments in code for information about how token streams are processed +and what valid VAL values are." + + ;; A typical VAL value might be either a stream of tokens. + ;; Tokens saved into a macro stream always includes the text from the + ;; buffer, since the locations specified probably don't represent + ;; that text anymore, or even the same buffer. + ;; + ;; CASE 1: Simple token stream + ;; + ;; #define SUPER mysuper:: + ;; ==> + ;;((symbol "mysuper" 480 . 487) + ;; (punctuation ":" 487 . 488) + ;; (punctuation ":" 488 . 489)) + ;; + ;; CASE 2: Token stream with argument list + ;; + ;; #define INT_FCN(name) int name (int in) + ;; ==> + ;; ((spp-arg-list ("name") 558 . 564) + ;; (INT "int" 565 . 568) + ;; (symbol "name" 569 . 573) + ;; (semantic-list "(int in)" 574 . 582)) + ;; + ;; In the second case, a macro with an argument list as the a rgs as the + ;; first entry. + ;; + ;; CASE 3: Symbol text merge + ;; + ;; #define TMP(a) foo_ ## a + ;; ==> + ;; ((spp-arg-list ("a") 20 . 23) + ;; (spp-symbol-merge ((symbol "foo_" 24 . 28) (symbol "a" 32 . 33)) + ;; 24 . 33)) + ;; + ;; Usually in conjunction with a macro with an argument, merging symbol + ;; parts is a way of fabricating new symbols from pieces inside the macro. + ;; These macros use `spp-symbol-merge' tokens whose TEXT part is another + ;; token stream. This sub-stream ought to consist of only 2 SYMBOL pieces, + ;; though I suppose keywords might be ok. The end result of this example + ;; merge symbol would be (symbol "foo_A" 24 . 33) where A is the symbol + ;; passed in from the arg list "a". + ;; + ;; CASE 4: Nested token streams + ;; + ;; #define FOO(f) f + ;; #define BLA bla FOO(foo) + ;; ==> + ;; ((INT "int" 82 . 85) + ;; (symbol "FOO" 86 . 89) + ;; (semantic-list "(foo)" 89 . 94)) + ;; + ;; Nested token FOO shows up in the table of macros, and gets replace + ;; inline. This is the same as case 2. + + (let ((arglist (semantic-lex-spp-macro-with-args val)) + (argalist nil) + (val-tmp nil) + (v nil) + ) + ;; CASE 2: Dealing with the arg list. + (when arglist + ;; Skip the arg list. + (setq val (cdr val)) + + ;; Push args into the replacement list. + (let ((AV argvalues)) + (dolist (A arglist) + (let* ((argval (car AV))) + + (semantic-lex-spp-symbol-push A argval) + (setq argalist (cons (cons A argval) argalist)) + (setq AV (cdr AV))))) + ) + + ;; Set val-tmp after stripping arguments. + (setq val-tmp val) + + ;; CASE 1: Push everything else onto the list. + ;; Once the arg list is stripped off, CASE 2 is the same + ;; as CASE 1. + (while val-tmp + (setq v (car val-tmp)) + (setq val-tmp (cdr val-tmp)) + + (let* (;; The text of the current lexical token. + (txt (car (cdr v))) + ;; Try to convert txt into a macro declaration. If it is + ;; not a macro, use nil. + (txt-macro-or-nil (semantic-lex-spp-symbol txt)) + ;; If our current token is a macro, then pull off the argument + ;; list. + (macro-and-args + (when txt-macro-or-nil + (semantic-lex-spp-macro-with-args (symbol-value txt-macro-or-nil))) + ) + ;; We need to peek at the next token when testing for + ;; used macros with arg lists. + (next-tok-class (semantic-lex-token-class (car val-tmp))) + ) + + (cond + ;; CASE 3: Merge symbols together. + ((eq (semantic-lex-token-class v) 'spp-symbol-merge) + ;; We need to merge the tokens in the 'text segement together, + ;; and produce a single symbol from it. + (let ((newsym + (mapconcat (lambda (tok) + (semantic-lex-spp-one-token-to-txt tok)) + txt + ""))) + (semantic-lex-push-token + (semantic-lex-token 'symbol beg end newsym)) + )) + + ;; CASE 2: Argument replacement. If a discovered symbol is in + ;; the active list of arguments, then we need to substitute + ;; in the new value. + ((and (eq (semantic-lex-token-class v) 'symbol) txt-macro-or-nil + (or (and macro-and-args (eq next-tok-class 'semantic-list)) + (not macro-and-args)) + ) + (let ((AV nil)) + (when macro-and-args + (setq AV + (semantic-lex-spp-stream-for-arglist (car val-tmp))) + ;; We used up these args. Pull from the stream. + (setq val-tmp (cdr val-tmp)) + ) + + (semantic-lex-with-macro-used txt + ;; Don't recurse directly into this same fcn, because it is + ;; convenient to have plain string replacements too. + (semantic-lex-spp-macro-to-macro-stream + (symbol-value txt-macro-or-nil) + beg end AV)) + )) + + ;; This is a HACK for the C parser. The 'macros text + ;; property is some storage so that the parser can do + ;; some C specific text manipulations. + ((eq (semantic-lex-token-class v) 'semantic-list) + ;; Push our arg list onto the semantic list. + (when argalist + (setq txt (concat txt)) ; Copy the text. + (put-text-property 0 1 'macros argalist txt)) + (semantic-lex-push-token + (semantic-lex-token (semantic-lex-token-class v) beg end txt)) + ) + + ;; CASE 1: Just another token in the stream. + (t + ;; Nothing new. + (semantic-lex-push-token + (semantic-lex-token (semantic-lex-token-class v) beg end txt)) + ) + ))) + + ;; CASE 2: The arg list we pushed onto the symbol table + ;; must now be removed. + (dolist (A arglist) + (semantic-lex-spp-symbol-pop A)) + )) + +;;; Macro Merging +;; +;; Used when token streams from different macros include eachother. +;; Merged macro streams perform in place replacements. + +(defun semantic-lex-spp-merge-streams (raw-stream) + "Merge elements from the RAW-STREAM together. +Handle spp-concat symbol concatenation. +Handle Nested macro replacements. +Return the cooked stream." + (let ((cooked-stream nil)) + ;; Merge the stream + (while raw-stream + (cond ((eq (semantic-lex-token-class (car raw-stream)) 'spp-concat) + ;; handle hashhash, by skipping it. + (setq raw-stream (cdr raw-stream)) + ;; Now merge the symbols. + (let ((prev-tok (car cooked-stream)) + (next-tok (car raw-stream))) + (setq cooked-stream (cdr cooked-stream)) + (push (semantic-lex-token + 'spp-symbol-merge + (semantic-lex-token-start prev-tok) + (semantic-lex-token-end next-tok) + (list prev-tok next-tok)) + cooked-stream) + )) + (t + (push (car raw-stream) cooked-stream)) + ) + (setq raw-stream (cdr raw-stream)) + ) + + (nreverse cooked-stream)) + ) + +;;; MACRO EXPANSION +;; +;; There are two types of expansion. +;; +;; 1. Expansion using a value made up of lexical tokens. +;; 2. User input replacement from a plain string. + +(defun semantic-lex-spp-macro-to-macro-stream (val beg end argvalues) + "Convert lexical macro contents VAL into a macro expansion stream. +Argument VAL is the value of some macro to be converted into a stream. +BEG and END are the token bounds of the macro to be expanded +that will somehow gain a much longer token stream. +ARGVALUES are values for any arg list, or nil." + (cond + ;; If val is nil, then just skip it. + ((null val) t) + ;; If it is a token, then return that token rebuilt. + ((and (consp val) (car val) (symbolp (car val))) + (semantic-lex-push-token + (semantic-lex-token (car val) beg end (semantic-lex-token-text val)))) + ;; Test for a token list. + ((and (consp val) (consp (car val)) (car (car val)) + (symbolp (car (car val)))) + (semantic-lex-spp-token-macro-to-macro-stream val beg end argvalues)) + ;; Test for miscellaneous strings. + ((stringp val) + (semantic-lex-spp-simple-macro-to-macro-stream val beg end argvalues)) + )) + +;;; -------------------------------------------------------- +;;; +;;; ANALYZERS: +;;; + +;;; Symbol Is Macro +;; +;; An analyser that will push tokens from a macro in place +;; of the macro symbol. +;; +(defun semantic-lex-spp-anlyzer-do-replace (sym val beg end) + "Do the lexical replacement for SYM with VAL. +Argument BEG and END specify the bounds of SYM in the buffer." + (if (not val) + (setq semantic-lex-end-point end) + (let ((arg-in nil) + (arg-parsed nil) + (arg-split nil) + ) + + ;; Check for arguments. + (setq arg-in (semantic-lex-spp-macro-with-args val)) + + (when arg-in + (save-excursion + (goto-char end) + (setq arg-parsed + (semantic-lex-spp-one-token-and-move-for-macro + (point-at-eol))) + (setq end (semantic-lex-token-end arg-parsed)) + + (when (and (listp arg-parsed) (eq (car arg-parsed) 'semantic-list)) + (setq arg-split + ;; Use lex to split up the contents of the argument list. + (semantic-lex-spp-stream-for-arglist arg-parsed) + )) + )) + + ;; if we have something to sub in, then do it. + (semantic-lex-spp-macro-to-macro-stream val beg end arg-split) + (setq semantic-lex-end-point end) + ) + )) + +(defvar semantic-lex-spp-replacements-enabled t + "Non-nil means do replacements when finding keywords. +Disable this only to prevent recursive expansion issues.") + +(defun semantic-lex-spp-analyzer-push-tokens-for-symbol (str beg end) + "Push lexical tokens for the symbol or keyword STR. +STR occurs in the current buffer between BEG and END." + (let (sym val count) + (cond + ;; + ;; It is a macro. Prepare for a replacement. + ((and semantic-lex-spp-replacements-enabled + (semantic-lex-spp-symbol-p str)) + (setq sym (semantic-lex-spp-symbol str) + val (symbol-value sym) + count 0) + + (let ((semantic-lex-spp-expanded-macro-stack + semantic-lex-spp-expanded-macro-stack)) + + (semantic-lex-with-macro-used str + ;; Do direct replacements of single value macros of macros. + ;; This solves issues with a macro containing one symbol that + ;; is another macro, and get arg lists passed around. + (while (and val (consp val) + (semantic-lex-token-p (car val)) + (eq (length val) 1) + (eq (semantic-lex-token-class (car val)) 'symbol) + (semantic-lex-spp-symbol-p (semantic-lex-token-text (car val))) + (< count 10) + ) + (setq str (semantic-lex-token-text (car val))) + (setq sym (semantic-lex-spp-symbol str) + val (symbol-value sym)) + ;; Prevent recursion + (setq count (1+ count)) + ;; This prevents a different kind of recursion. + (push str semantic-lex-spp-expanded-macro-stack) + ) + + (semantic-lex-spp-anlyzer-do-replace sym val beg end)) + + )) + ;; Anything else. + (t + ;; A regular keyword. + (semantic-lex-push-token + (semantic-lex-token (or (semantic-lex-keyword-p str) 'symbol) + beg end)))) + )) + +(define-lex-regex-analyzer semantic-lex-spp-replace-or-symbol-or-keyword + "Like 'semantic-lex-symbol-or-keyword' plus preprocessor macro replacement." + "\\(\\sw\\|\\s_\\)+" + (let ((str (match-string 0)) + (beg (match-beginning 0)) + (end (match-end 0))) + (semantic-lex-spp-analyzer-push-tokens-for-symbol str beg end))) + +;;; ANALYZERS FOR NEW MACROS +;; +;; These utilities and analyzer declaration function are for +;; creating an analyzer which produces new macros in the macro table. +;; +;; There are two analyzers. One for new macros, and one for removing +;; a macro. + +(defun semantic-lex-spp-first-token-arg-list (token) + "If TOKEN is a semantic-list, turn it into a an SPP ARG LIST." + (when (and (consp token) + (symbolp (car token)) + (eq 'semantic-list (car token))) + ;; Convert TOKEN in place. + (let ((argsplit (split-string (semantic-lex-token-text token) + "[(), ]" t))) + (setcar token 'spp-arg-list) + (setcar (nthcdr 1 token) argsplit)) + )) + +(defun semantic-lex-spp-one-token-and-move-for-macro (max) + "Lex up one token, and move to end of that token. +Don't go past MAX." + (let ((ans (semantic-lex (point) max 0 0))) + (if (not ans) + (progn (goto-char max) + nil) + (when (> (semantic-lex-token-end (car ans)) max) + (let ((bounds (semantic-lex-token-bounds (car ans)))) + (setcdr bounds max))) + (goto-char (semantic-lex-token-end (car ans))) + (car ans)) + )) + +(defun semantic-lex-spp-stream-for-arglist (token) + "Lex up the contents of the arglist TOKEN. +Parsing starts inside the parens, and ends at the end of TOKEN." + (let ((end (semantic-lex-token-end token)) + (fresh-toks nil) + (toks nil)) + (save-excursion + + (if (stringp (nth 1 token)) + ;; If the 2nd part of the token is a string, then we have + ;; a token specifically extracted from a buffer. Possibly + ;; a different buffer. This means we need to do something + ;; nice to parse its contents. + (let ((txt (semantic-lex-token-text token))) + (semantic-lex-spp-lex-text-string + (substring txt 1 (1- (length txt))))) + + ;; This part is like the original + (goto-char (semantic-lex-token-start token)) + ;; A cheat for going into the semantic list. + (forward-char 1) + (setq fresh-toks (semantic-lex-spp-stream-for-macro (1- end))) + (dolist (tok fresh-toks) + (when (memq (semantic-lex-token-class tok) '(symbol semantic-list)) + (setq toks (cons tok toks)))) + + (nreverse toks))))) + +(defvar semantic-lex-spp-hack-depth 0 + "Current depth of recursive calls to `semantic-lex-spp-lex-text-string'.") + +(defun semantic-lex-spp-lex-text-string (text) + "Lex the text string TEXT using the current buffer's state. +Use this to parse text extracted from a macro as if it came from +the current buffer. Since the lexer is designed to only work in +a buffer, we need to create a new buffer, and populate it with rules +and variable state from the current buffer." + (let* ((semantic-lex-spp-hack-depth (1+ semantic-lex-spp-hack-depth)) + (buf (get-buffer-create (format " *SPP parse hack %d*" + semantic-lex-spp-hack-depth))) + (mode major-mode) + (fresh-toks nil) + (toks nil) + (origbuff (current-buffer)) + (important-vars '(semantic-lex-spp-macro-symbol-obarray + semantic-lex-spp-project-macro-symbol-obarray + semantic-lex-spp-dynamic-macro-symbol-obarray + semantic-lex-spp-dynamic-macro-symbol-obarray-stack + semantic-lex-spp-expanded-macro-stack + )) + ) + (save-excursion + (set-buffer buf) + (erase-buffer) + ;; Below is a painful hack to make sure everything is setup correctly. + (when (not (eq major-mode mode)) + (save-match-data + + ;; Protect against user-hooks that throw errors. + (condition-case nil + (funcall mode) + (error nil)) + + ;; Hack in mode-local + (activate-mode-local-bindings) + ;; CHEATER! The following 3 lines are from + ;; `semantic-new-buffer-fcn', but we don't want to turn + ;; on all the other annoying modes for this little task. + (setq semantic-new-buffer-fcn-was-run t) + (semantic-lex-init) + (semantic-clear-toplevel-cache) + (remove-hook 'semantic-lex-reset-hooks 'semantic-lex-spp-reset-hook + t) + )) + + ;; Second Cheat: copy key variables regarding macro state from the + ;; the originating buffer we are parsing. We need to do this every time + ;; since the state changes. + (dolist (V important-vars) + (set V (semantic-buffer-local-value V origbuff))) + (insert text) + (goto-char (point-min)) + + (setq fresh-toks (semantic-lex-spp-stream-for-macro (point-max)))) + + (dolist (tok fresh-toks) + (when (memq (semantic-lex-token-class tok) '(symbol semantic-list)) + (setq toks (cons tok toks)))) + + (nreverse toks))) + +;;;; FIRST DRAFT +;; This is the fist version of semantic-lex-spp-stream-for-arglist +;; that worked pretty well. It doesn't work if the TOKEN was derived +;; from some other buffer, in which case it can get the wrong answer +;; or throw an error if the token location in the originating buffer is +;; larger than the current buffer. +;;(defun semantic-lex-spp-stream-for-arglist-orig (token) +;; "Lex up the contents of the arglist TOKEN. +;; Parsing starts inside the parens, and ends at the end of TOKEN." +;; (save-excursion +;; (let ((end (semantic-lex-token-end token)) +;; (fresh-toks nil) +;; (toks nil)) +;; (goto-char (semantic-lex-token-start token)) +;; ;; A cheat for going into the semantic list. +;; (forward-char 1) +;; (setq fresh-toks (semantic-lex-spp-stream-for-macro (1- end))) +;; (dolist (tok fresh-toks) +;; (when (memq (semantic-lex-token-class tok) '(symbol semantic-list)) +;; (setq toks (cons tok toks)))) +;; (nreverse toks)) +;; )) + +;;;; USING SPLIT +;; This doesn't work, because some arguments passed into a macro +;; might contain non-simple symbol words, which this doesn't handle. +;; +;; Thus, you need a full lex to occur. +;; (defun semantic-lex-spp-stream-for-arglist-split (token) +;; "Lex up the contents of the arglist TOKEN. +;; Parsing starts inside the parens, and ends at the end of TOKEN." +;; (let* ((txt (semantic-lex-token-text token)) +;; (split (split-string (substring txt 1 (1- (length txt))) +;; "(), " t)) +;; ;; Hack for lexing. +;; (semantic-lex-spp-analyzer-push-tokens-for-symbol nil)) +;; (dolist (S split) +;; (semantic-lex-spp-analyzer-push-tokens-for-symbol S 0 1)) +;; (reverse semantic-lex-spp-analyzer-push-tokens-for-symbol))) + + +(defun semantic-lex-spp-stream-for-macro (eos) + "Lex up a stream of tokens for a #define statement. +Parsing starts at the current point location. +EOS is the end of the stream to lex for this macro." + (let ((stream nil)) + (while (< (point) eos) + (let* ((tok (semantic-lex-spp-one-token-and-move-for-macro eos)) + (str (when tok + (semantic-lex-token-text tok))) + ) + (if str + (push (semantic-lex-token (semantic-lex-token-class tok) + (semantic-lex-token-start tok) + (semantic-lex-token-end tok) + str) + stream) + ;; Nothing to push. + nil))) + (goto-char eos) + ;; Fix the order + (nreverse stream) + )) + +(defmacro define-lex-spp-macro-declaration-analyzer (name doc regexp tokidx + &rest valform) + "Define a lexical analyzer for defining new MACROS. +NAME is the name of the analyzer. +DOC is the documentation for the analyzer. +REGEXP is a regular expression for the analyzer to match. +See `define-lex-regex-analyzer' for more on regexp. +TOKIDX is an index into REGEXP for which a new lexical token +of type `spp-macro-def' is to be created. +VALFORM are forms that return the value to be saved for this macro, or nil. +When implementing a macro, you can use `semantic-lex-spp-stream-for-macro' +to convert text into a lexical stream for storage in the macro." + (let ((start (make-symbol "start")) + (end (make-symbol "end")) + (val (make-symbol "val")) + (startpnt (make-symbol "startpnt")) + (endpnt (make-symbol "endpnt"))) + `(define-lex-regex-analyzer ,name + ,doc + ,regexp + (let ((,start (match-beginning ,tokidx)) + (,end (match-end ,tokidx)) + (,startpnt semantic-lex-end-point) + (,val (save-match-data ,@valform)) + (,endpnt semantic-lex-end-point)) + (semantic-lex-spp-symbol-set + (buffer-substring-no-properties ,start ,end) + ,val) + (semantic-lex-push-token + (semantic-lex-token 'spp-macro-def + ,start ,end)) + ;; Preserve setting of the end point from the calling macro. + (when (and (/= ,startpnt ,endpnt) + (/= ,endpnt semantic-lex-end-point)) + (setq semantic-lex-end-point ,endpnt)) + )))) + +(defmacro define-lex-spp-macro-undeclaration-analyzer (name doc regexp tokidx) + "Undefine a lexical analyzer for defining new MACROS. +NAME is the name of the analyzer. +DOC is the documentation for the analyzer. +REGEXP is a regular expression for the analyzer to match. +See `define-lex-regex-analyzer' for more on regexp. +TOKIDX is an index into REGEXP for which a new lexical token +of type `spp-macro-undef' is to be created." + (let ((start (make-symbol "start")) + (end (make-symbol "end"))) + `(define-lex-regex-analyzer ,name + ,doc + ,regexp + (let ((,start (match-beginning ,tokidx)) + (,end (match-end ,tokidx)) + ) + (semantic-lex-spp-symbol-remove + (buffer-substring-no-properties ,start ,end)) + (semantic-lex-push-token + (semantic-lex-token 'spp-macro-undef + ,start ,end)) + )))) + +;;; INCLUDES +;; +;; These analyzers help a language define how include files +;; are identified. These are ONLY for languages that perform +;; an actual textual includesion, and not for imports. +;; +;; This section is supposed to allow the macros from the headers to be +;; added to the local dynamic macro table, but that hasn't been +;; written yet. +;; +(defcustom semantic-lex-spp-use-headers-flag nil + "*Non-nil means to pre-parse headers as we go. +For languages that use the Semantic pre-processor, this can +improve the accuracy of parsed files where include files +can change the state of what's parsed in the current file. + +Note: Note implemented yet" + :group 'semantic + :type 'boolean) + +(defun semantic-lex-spp-merge-header (name) + "Extract and merge any macros from the header with NAME. +Finds the header file belonging to NAME, gets the macros +from that file, and then merge the macros with our current +symbol table." + (when semantic-lex-spp-use-headers-flag + ;; @todo - do this someday, ok? + )) + +(defmacro define-lex-spp-include-analyzer (name doc regexp tokidx + &rest valform) + "Define a lexical analyzer for defining a new INCLUDE lexical token. +Macros defined in the found include will be added to our running table +at the time the include statement is found. +NAME is the name of the analyzer. +DOC is the documentation for the analyzer. +REGEXP is a regular expression for the analyzer to match. +See `define-lex-regex-analyzer' for more on regexp. +TOKIDX is an index into REGEXP for which a new lexical token +of type `spp-macro-include' is to be created. +VALFORM are forms that return the name of the thing being included, and the +type of include. The return value should be of the form: + (NAME . TYPE) +where NAME is the name of the include, and TYPE is the type of the include, +where a valid symbol is 'system, or nil." + (let ((start (make-symbol "start")) + (end (make-symbol "end")) + (val (make-symbol "val")) + (startpnt (make-symbol "startpnt")) + (endpnt (make-symbol "endpnt"))) + `(define-lex-regex-analyzer ,name + ,doc + ,regexp + (let ((,start (match-beginning ,tokidx)) + (,end (match-end ,tokidx)) + (,startpnt semantic-lex-end-point) + (,val (save-match-data ,@valform)) + (,endpnt semantic-lex-end-point)) + ;;(message "(car ,val) -> %S" (car ,val)) + (semantic-lex-spp-merge-header (car ,val)) + (semantic-lex-push-token + (semantic-lex-token (if (eq (cdr ,val) 'system) + 'spp-system-include + 'spp-include) + ,start ,end + (car ,val))) + ;; Preserve setting of the end point from the calling macro. + (when (and (/= ,startpnt ,endpnt) + (/= ,endpnt semantic-lex-end-point)) + (setq semantic-lex-end-point ,endpnt)) + )))) + +;;; EIEIO USAGE +;; +;; Semanticdb can save off macro tables for quick lookup later. +;; +;; These routines are for saving macro lists into an EIEIO persistent +;; file. +(defvar semantic-lex-spp-macro-max-length-to-save 200 + "*Maximum length of an SPP macro before we opt to not save it.") + +;;;###autoload +(defun semantic-lex-spp-table-write-slot-value (value) + "Write out the VALUE of a slot for EIEIO. +The VALUE is a spp lexical table." + (if (not value) + (princ "nil") + (princ "\n '(") + ;(princ value) + (dolist (sym value) + (princ "(") + (prin1 (car sym)) + (let* ((first (car (cdr sym))) + (rest (cdr sym))) + (when (not (listp first)) + (error "Error in macro \"%s\"" (car sym))) + (when (eq (car first) 'spp-arg-list) + (princ " ") + (prin1 first) + (setq rest (cdr rest)) + ) + + (when rest + (princ " . ") + (let ((len (length (cdr rest)))) + (cond ((< len 2) + (condition-case nil + (prin1 rest) + (error + (princ "nil ;; Error writing macro\n")))) + ((< len semantic-lex-spp-macro-max-length-to-save) + (princ "\n ") + (condition-case nil + (prin1 rest) + (error + (princ "nil ;; Error writing macro\n "))) + ) + (t ;; Too Long! + (princ "nil ;; Too Long!\n ") + )))) + ) + (princ ")\n ") + ) + (princ ")\n")) +) + +;;; MACRO TABLE DEBUG +;; +(defun semantic-lex-spp-describe (&optional buffer) + "Describe the current list of spp macros for BUFFER. +If BUFFER is not provided, use the current buffer." + (interactive) + (let ((syms (save-excursion + (if buffer (set-buffer buffer)) + (semantic-lex-spp-macros))) + (sym nil)) + (with-output-to-temp-buffer "*SPP MACROS*" + (princ "Macro\t\tValue\n") + (while syms + (setq sym (car syms) + syms (cdr syms)) + (princ (symbol-name sym)) + (princ "\t") + (if (< (length (symbol-name sym)) 8) + (princ "\t")) + (prin1 (symbol-value sym)) + (princ "\n") + )))) + +;;; EDEBUG Handlers +;; +(add-hook + 'edebug-setup-hook + #'(lambda () + + (def-edebug-spec define-lex-spp-macro-declaration-analyzer + (&define name stringp stringp form def-body) + ) + + (def-edebug-spec define-lex-spp-macro-undeclaration-analyzer + (&define name stringp stringp form) + ) + + (def-edebug-spec define-lex-spp-include-analyzer + (&define name stringp stringp form def-body)))) + +(provide 'semantic/lex-spp) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/lex-spp" +;; End: + +;;; semantic-lex-spp.el ends here diff --git a/lisp/cedet/semantic/lex.el b/lisp/cedet/semantic/lex.el new file mode 100644 index 00000000000..eb6d46df473 --- /dev/null +++ b/lisp/cedet/semantic/lex.el @@ -0,0 +1,2053 @@ +;;; semantic/lex.el --- Lexical Analyzer builder + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file handles the creation of lexical analyzers for different +;; languages in Emacs Lisp. The purpose of a lexical analyzer is to +;; convert a buffer into a list of lexical tokens. Each token +;; contains the token class (such as 'number, 'symbol, 'IF, etc) and +;; the location in the buffer it was found. Optionally, a token also +;; contains a string representing what is at the designated buffer +;; location. +;; +;; Tokens are pushed onto a token stream, which is basically a list of +;; all the lexical tokens from the analyzed region. The token stream +;; is then handed to the grammar which parsers the file. +;; +;;; How it works +;; +;; Each analyzer specifies a condition and forms. These conditions +;; and forms are assembled into a function by `define-lex' that does +;; the lexical analysis. +;; +;; In the lexical analyzer created with `define-lex', each condition +;; is tested for a given point. When the conditin is true, the forms +;; run. +;; +;; The forms can push a lexical token onto the token stream. The +;; analyzer forms also must move the current analyzer point. If the +;; analyzer point is moved without pushing a token, then tne matched +;; syntax is effectively ignored, or skipped. +;; +;; Thus, starting at the beginning of a region to be analyzed, each +;; condition is tested. One will match, and a lexical token might be +;; pushed, and the point is moved to the end of the lexical token +;; identified. At the new position, the process occurs again until +;; the end of the specified region is reached. +;; +;;; How to use semantic-lex +;; +;; To create a lexer for a language, use the `define-lex' macro. +;; +;; The `define-lex' macro accepts a list of lexical analyzers. Each +;; analyzer is created with `define-lex-analyzer', or one of the +;; derivitive macros. A single analyzer defines a regular expression +;; to match text in a buffer, and a short segment of code to create +;; one lexical token. +;; +;; Each analyzer has a NAME, DOC, a CONDITION, and possibly some +;; FORMS. The NAME is the name used in `define-lex'. The DOC +;; describes what the analyzer should do. +;; +;; The CONDITION evaluates the text at the current point in the +;; current buffer. If CONDITION is true, then the FORMS will be +;; executed. +;; +;; The purpose of the FORMS is to push new lexical tokens onto the +;; list of tokens for the current buffer, and to move point after the +;; matched text. +;; +;; Some macros for creating one analyzer are: +;; +;; define-lex-analyzer - A generic analyzer associating any style of +;; condition to forms. +;; define-lex-regex-analyzer - Matches a regular expression. +;; define-lex-simple-regex-analyzer - Matches a regular expressions, +;; and pushes the match. +;; define-lex-block-analyzer - Matches list syntax, and defines +;; handles open/close delimiters. +;; +;; These macros are used by the grammar compiler when lexical +;; information is specified in a grammar: +;; define-lex- * -type-analyzer - Matches syntax specified in +;; a grammar, and pushes one token for it. The * would +;; be `sexp' for things like lists or strings, and +;; `string' for things that need to match some special +;; string, such as "\\." where a literal match is needed. +;; +;;; Lexical Tables +;; +;; There are tables of different symbols managed in semantic-lex.el. +;; They are: +;; +;; Lexical keyword table - A Table of symbols declared in a grammar +;; file with the %keyword declaration. +;; Keywords are used by `semantic-lex-symbol-or-keyword' +;; to create lexical tokens based on the keyword. +;; +;; Lexical type table - A table of symbols declared in a grammer +;; file with the %type declaration. +;; The grammar compiler uses the type table to create new +;; lexical analyzers. These analyzers are then used to when +;; a new lexical analyzer is made for a language. +;; +;;; Lexical Types +;; +;; A lexical type defines a kind of lexical analyzer that will be +;; automatically generated from a grammar file based on some +;; predetermined attributes. For now these two attributes are +;; recognized : +;; +;; * matchdatatype : define the kind of lexical analyzer. That is : +;; +;; - regexp : define a regexp analyzer (see +;; `define-lex-regex-type-analyzer') +;; +;; - string : define a string analyzer (see +;; `define-lex-string-type-analyzer') +;; +;; - block : define a block type analyzer (see +;; `define-lex-block-type-analyzer') +;; +;; - sexp : define a sexp analyzer (see +;; `define-lex-sexp-type-analyzer') +;; +;; - keyword : define a keyword analyzer (see +;; `define-lex-keyword-type-analyzer') +;; +;; * syntax : define the syntax that matches a syntactic +;; expression. When syntax is matched the corresponding type +;; analyzer is entered and the resulting match data will be +;; interpreted based on the kind of analyzer (see matchdatatype +;; above). +;; +;; The following lexical types are predefined : +;; +;; +-------------+---------------+--------------------------------+ +;; | type | matchdatatype | syntax | +;; +-------------+---------------+--------------------------------+ +;; | punctuation | string | "\\(\\s.\\|\\s$\\|\\s'\\)+" | +;; | keyword | keyword | "\\(\\sw\\|\\s_\\)+" | +;; | symbol | regexp | "\\(\\sw\\|\\s_\\)+" | +;; | string | sexp | "\\s\"" | +;; | number | regexp | semantic-lex-number-expression | +;; | block | block | "\\s(\\|\\s)" | +;; +-------------+---------------+--------------------------------+ +;; +;; In a grammar you must use a %type expression to automatically generate +;; the corresponding analyzers of that type. +;; +;; Here is an example to auto-generate punctuation analyzers +;; with 'matchdatatype and 'syntax predefined (see table above) +;; +;; %type <punctuation> ;; will auto-generate this kind of analyzers +;; +;; It is equivalent to write : +;; +;; %type <punctuation> syntax "\\(\\s.\\|\\s$\\|\\s'\\)+" matchdatatype string +;; +;; ;; Some punctuations based on the type defines above +;; +;; %token <punctuation> NOT "!" +;; %token <punctuation> NOTEQ "!=" +;; %token <punctuation> MOD "%" +;; %token <punctuation> MODEQ "%=" +;; + +;;; On the Semantic 1.x lexer +;; +;; In semantic 1.x, the lexical analyzer was an all purpose routine. +;; To boost efficiency, the analyzer is now a series of routines that +;; are constructed at build time into a single routine. This will +;; eliminate unneeded if statements to speed the lexer. + +(require 'semantic/fw) + +;;; Code: + +;;; Semantic 2.x lexical analysis +;; +(defun semantic-lex-map-symbols (fun table &optional property) + "Call function FUN on every symbol in TABLE. +If optional PROPERTY is non-nil, call FUN only on every symbol which +as a PROPERTY value. FUN receives a symbol as argument." + (if (arrayp table) + (mapatoms + #'(lambda (symbol) + (if (or (null property) (get symbol property)) + (funcall fun symbol))) + table))) + +;;; Lexical keyword table handling. +;; +;; These keywords are keywords defined for using in a grammar with the +;; %keyword declaration, and are not keywords used in Emacs Lisp. + +(defvar semantic-flex-keywords-obarray nil + "Buffer local keyword obarray for the lexical analyzer. +These keywords are matched explicitly, and converted into special symbols.") +(make-variable-buffer-local 'semantic-flex-keywords-obarray) + +(defmacro semantic-lex-keyword-invalid (name) + "Signal that NAME is an invalid keyword name." + `(signal 'wrong-type-argument '(semantic-lex-keyword-p ,name))) + +(defsubst semantic-lex-keyword-symbol (name) + "Return keyword symbol with NAME or nil if not found." + (and (arrayp semantic-flex-keywords-obarray) + (stringp name) + (intern-soft name semantic-flex-keywords-obarray))) + +(defsubst semantic-lex-keyword-p (name) + "Return non-nil if a keyword with NAME exists in the keyword table. +Return nil otherwise." + (and (setq name (semantic-lex-keyword-symbol name)) + (symbol-value name))) + +(defsubst semantic-lex-keyword-set (name value) + "Set value of keyword with NAME to VALUE and return VALUE." + (set (intern name semantic-flex-keywords-obarray) value)) + +(defsubst semantic-lex-keyword-value (name) + "Return value of keyword with NAME. +Signal an error if a keyword with NAME does not exist." + (let ((keyword (semantic-lex-keyword-symbol name))) + (if keyword + (symbol-value keyword) + (semantic-lex-keyword-invalid name)))) + +(defsubst semantic-lex-keyword-put (name property value) + "For keyword with NAME, set its PROPERTY to VALUE." + (let ((keyword (semantic-lex-keyword-symbol name))) + (if keyword + (put keyword property value) + (semantic-lex-keyword-invalid name)))) + +(defsubst semantic-lex-keyword-get (name property) + "For keyword with NAME, return its PROPERTY value." + (let ((keyword (semantic-lex-keyword-symbol name))) + (if keyword + (get keyword property) + (semantic-lex-keyword-invalid name)))) + +(defun semantic-lex-make-keyword-table (specs &optional propspecs) + "Convert keyword SPECS into an obarray and return it. +SPECS must be a list of (NAME . TOKSYM) elements, where: + + NAME is the name of the keyword symbol to define. + TOKSYM is the lexical token symbol of that keyword. + +If optional argument PROPSPECS is non nil, then interpret it, and +apply those properties. +PROPSPECS must be a list of (NAME PROPERTY VALUE) elements." + ;; Create the symbol hash table + (let ((semantic-flex-keywords-obarray (make-vector 13 0)) + spec) + ;; fill it with stuff + (while specs + (setq spec (car specs) + specs (cdr specs)) + (semantic-lex-keyword-set (car spec) (cdr spec))) + ;; Apply all properties + (while propspecs + (setq spec (car propspecs) + propspecs (cdr propspecs)) + (semantic-lex-keyword-put (car spec) (nth 1 spec) (nth 2 spec))) + semantic-flex-keywords-obarray)) + +(defsubst semantic-lex-map-keywords (fun &optional property) + "Call function FUN on every lexical keyword. +If optional PROPERTY is non-nil, call FUN only on every keyword which +as a PROPERTY value. FUN receives a lexical keyword as argument." + (semantic-lex-map-symbols + fun semantic-flex-keywords-obarray property)) + +(defun semantic-lex-keywords (&optional property) + "Return a list of lexical keywords. +If optional PROPERTY is non-nil, return only keywords which have a +PROPERTY set." + (let (keywords) + (semantic-lex-map-keywords + #'(lambda (symbol) (setq keywords (cons symbol keywords))) + property) + keywords)) + +;;; Inline functions: + +(defvar semantic-lex-unterminated-syntax-end-function) +(defvar semantic-lex-analysis-bounds) +(defvar semantic-lex-end-point) + +(defsubst semantic-lex-token-bounds (token) + "Fetch the start and end locations of the lexical token TOKEN. +Return a pair (START . END)." + (if (not (numberp (car (cdr token)))) + (cdr (cdr token)) + (cdr token))) + +(defsubst semantic-lex-token-start (token) + "Fetch the start position of the lexical token TOKEN. +See also the function `semantic-lex-token'." + (car (semantic-lex-token-bounds token))) + +(defsubst semantic-lex-token-end (token) + "Fetch the end position of the lexical token TOKEN. +See also the function `semantic-lex-token'." + (cdr (semantic-lex-token-bounds token))) + +(defsubst semantic-lex-unterminated-syntax-detected (syntax) + "Inside a lexical analyzer, use this when unterminated syntax was found. +Argument SYNTAX indicates the type of syntax that is unterminated. +The job of this function is to move (point) to a new logical location +so that analysis can continue, if possible." + (goto-char + (funcall semantic-lex-unterminated-syntax-end-function + syntax + (car semantic-lex-analysis-bounds) + (cdr semantic-lex-analysis-bounds) + )) + (setq semantic-lex-end-point (point))) + +;;; Type table handling. +;; +;; The lexical type table manages types that occur in a grammar file +;; with the %type declaration. Types represent different syntaxes. +;; See code for `semantic-lex-preset-default-types' for the classic +;; types of syntax. +(defvar semantic-lex-types-obarray nil + "Buffer local types obarray for the lexical analyzer.") +(make-variable-buffer-local 'semantic-lex-types-obarray) + +(defmacro semantic-lex-type-invalid (type) + "Signal that TYPE is an invalid lexical type name." + `(signal 'wrong-type-argument '(semantic-lex-type-p ,type))) + +(defsubst semantic-lex-type-symbol (type) + "Return symbol with TYPE or nil if not found." + (and (arrayp semantic-lex-types-obarray) + (stringp type) + (intern-soft type semantic-lex-types-obarray))) + +(defsubst semantic-lex-type-p (type) + "Return non-nil if a symbol with TYPE name exists." + (and (setq type (semantic-lex-type-symbol type)) + (symbol-value type))) + +(defsubst semantic-lex-type-set (type value) + "Set value of symbol with TYPE name to VALUE and return VALUE." + (set (intern type semantic-lex-types-obarray) value)) + +(defsubst semantic-lex-type-value (type &optional noerror) + "Return value of symbol with TYPE name. +If optional argument NOERROR is non-nil return nil if a symbol with +TYPE name does not exist. Otherwise signal an error." + (let ((sym (semantic-lex-type-symbol type))) + (if sym + (symbol-value sym) + (unless noerror + (semantic-lex-type-invalid type))))) + +(defsubst semantic-lex-type-put (type property value &optional add) + "For symbol with TYPE name, set its PROPERTY to VALUE. +If optional argument ADD is non-nil, create a new symbol with TYPE +name if it does not already exist. Otherwise signal an error." + (let ((sym (semantic-lex-type-symbol type))) + (unless sym + (or add (semantic-lex-type-invalid type)) + (semantic-lex-type-set type nil) + (setq sym (semantic-lex-type-symbol type))) + (put sym property value))) + +(defsubst semantic-lex-type-get (type property &optional noerror) + "For symbol with TYPE name, return its PROPERTY value. +If optional argument NOERROR is non-nil return nil if a symbol with +TYPE name does not exist. Otherwise signal an error." + (let ((sym (semantic-lex-type-symbol type))) + (if sym + (get sym property) + (unless noerror + (semantic-lex-type-invalid type))))) + +(defun semantic-lex-preset-default-types () + "Install useful default properties for well known types." + (semantic-lex-type-put "punctuation" 'matchdatatype 'string t) + (semantic-lex-type-put "punctuation" 'syntax "\\(\\s.\\|\\s$\\|\\s'\\)+") + (semantic-lex-type-put "keyword" 'matchdatatype 'keyword t) + (semantic-lex-type-put "keyword" 'syntax "\\(\\sw\\|\\s_\\)+") + (semantic-lex-type-put "symbol" 'matchdatatype 'regexp t) + (semantic-lex-type-put "symbol" 'syntax "\\(\\sw\\|\\s_\\)+") + (semantic-lex-type-put "string" 'matchdatatype 'sexp t) + (semantic-lex-type-put "string" 'syntax "\\s\"") + (semantic-lex-type-put "number" 'matchdatatype 'regexp t) + (semantic-lex-type-put "number" 'syntax 'semantic-lex-number-expression) + (semantic-lex-type-put "block" 'matchdatatype 'block t) + (semantic-lex-type-put "block" 'syntax "\\s(\\|\\s)") + ) + +(defun semantic-lex-make-type-table (specs &optional propspecs) + "Convert type SPECS into an obarray and return it. +SPECS must be a list of (TYPE . TOKENS) elements, where: + + TYPE is the name of the type symbol to define. + TOKENS is an list of (TOKSYM . MATCHER) elements, where: + + TOKSYM is any lexical token symbol. + MATCHER is a string or regexp a text must match to be a such + lexical token. + +If optional argument PROPSPECS is non nil, then interpret it, and +apply those properties. +PROPSPECS must be a list of (TYPE PROPERTY VALUE)." + ;; Create the symbol hash table + (let* ((semantic-lex-types-obarray (make-vector 13 0)) + spec type tokens token alist default) + ;; fill it with stuff + (while specs + (setq spec (car specs) + specs (cdr specs) + type (car spec) + tokens (cdr spec) + default nil + alist nil) + (while tokens + (setq token (car tokens) + tokens (cdr tokens)) + (if (cdr token) + (setq alist (cons token alist)) + (setq token (car token)) + (if default + (message + "*Warning* default value of <%s> tokens changed to %S, was %S" + type default token)) + (setq default token))) + ;; Ensure the default matching spec is the first one. + (semantic-lex-type-set type (cons default (nreverse alist)))) + ;; Install useful default types & properties + (semantic-lex-preset-default-types) + ;; Apply all properties + (while propspecs + (setq spec (car propspecs) + propspecs (cdr propspecs)) + ;; Create the type if necessary. + (semantic-lex-type-put (car spec) (nth 1 spec) (nth 2 spec) t)) + semantic-lex-types-obarray)) + +(defsubst semantic-lex-map-types (fun &optional property) + "Call function FUN on every lexical type. +If optional PROPERTY is non-nil, call FUN only on every type symbol +which as a PROPERTY value. FUN receives a type symbol as argument." + (semantic-lex-map-symbols + fun semantic-lex-types-obarray property)) + +(defun semantic-lex-types (&optional property) + "Return a list of lexical type symbols. +If optional PROPERTY is non-nil, return only type symbols which have +PROPERTY set." + (let (types) + (semantic-lex-map-types + #'(lambda (symbol) (setq types (cons symbol types))) + property) + types)) + +;;; Lexical Analyzer framework settings +;; + +(defvar semantic-lex-analyzer 'semantic-flex + "The lexical analyzer used for a given buffer. +See `semantic-lex' for documentation. +For compatibility with Semantic 1.x it defaults to `semantic-flex'.") +(make-variable-buffer-local 'semantic-lex-analyzer) + +(defvar semantic-lex-tokens + '( + (bol) + (charquote) + (close-paren) + (comment) + (newline) + (open-paren) + (punctuation) + (semantic-list) + (string) + (symbol) + (whitespace) + ) + "An alist of of semantic token types. +As of December 2001 (semantic 1.4beta13), this variable is not used in +any code. The only use is to refer to the doc-string from elsewhere. + +The key to this alist is the symbol representing token type that +\\[semantic-flex] returns. These are + + - bol: Empty string matching a beginning of line. + This token is produced with + `semantic-lex-beginning-of-line'. + + - charquote: String sequences that match `\\s\\+' regexp. + This token is produced with `semantic-lex-charquote'. + + - close-paren: Characters that match `\\s)' regexp. + These are typically `)', `}', `]', etc. + This token is produced with + `semantic-lex-close-paren'. + + - comment: A comment chunk. These token types are not + produced by default. + This token is produced with `semantic-lex-comments'. + Comments are ignored with `semantic-lex-ignore-comments'. + Comments are treated as whitespace with + `semantic-lex-comments-as-whitespace'. + + - newline Characters matching `\\s-*\\(\n\\|\\s>\\)' regexp. + This token is produced with `semantic-lex-newline'. + + - open-paren: Characters that match `\\s(' regexp. + These are typically `(', `{', `[', etc. + If `semantic-lex-paren-or-list' is used, + then `open-paren' is not usually generated unless + the `depth' argument to \\[semantic-lex] is + greater than 0. + This token is always produced if the analyzer + `semantic-lex-open-paren' is used. + + - punctuation: Characters matching `{\\(\\s.\\|\\s$\\|\\s'\\)' + regexp. + This token is produced with `semantic-lex-punctuation'. + Always specify this analyzer after the comment + analyzer. + + - semantic-list: String delimited by matching parenthesis, braces, + etc. that the lexer skipped over, because the + `depth' parameter to \\[semantic-flex] was not high + enough. + This token is produced with `semantic-lex-paren-or-list'. + + - string: Quoted strings, i.e., string sequences that start + and end with characters matching `\\s\"' + regexp. The lexer relies on @code{forward-sexp} to + find the matching end. + This token is produced with `semantic-lex-string'. + + - symbol: String sequences that match `\\(\\sw\\|\\s_\\)+' + regexp. + This token is produced with + `semantic-lex-symbol-or-keyword'. Always add this analyzer + after `semantic-lex-number', or other analyzers that + match its regular expression. + + - whitespace: Characters that match `\\s-+' regexp. + This token is produced with `semantic-lex-whitespace'.") + +(defvar semantic-lex-syntax-modifications nil + "Changes to the syntax table for this buffer. +These changes are active only while the buffer is being flexed. +This is a list where each element has the form: + (CHAR CLASS) +CHAR is the char passed to `modify-syntax-entry', +and CLASS is the string also passed to `modify-syntax-entry' to define +what syntax class CHAR has.") +(make-variable-buffer-local 'semantic-lex-syntax-modifications) + +(defvar semantic-lex-syntax-table nil + "Syntax table used by lexical analysis. +See also `semantic-lex-syntax-modifications'.") +(make-variable-buffer-local 'semantic-lex-syntax-table) + +(defvar semantic-lex-comment-regex nil + "Regular expression for identifying comment start during lexical analysis. +This may be automatically set when semantic initializes in a mode, but +may need to be overriden for some special languages.") +(make-variable-buffer-local 'semantic-lex-comment-regex) + +(defvar semantic-lex-number-expression + ;; This expression was written by David Ponce for Java, and copied + ;; here for C and any other similar language. + (eval-when-compile + (concat "\\(" + "\\<[0-9]+[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>" + "\\|" + "\\<[0-9]+[.][eE][-+]?[0-9]+[fFdD]?\\>" + "\\|" + "\\<[0-9]+[.][fFdD]\\>" + "\\|" + "\\<[0-9]+[.]" + "\\|" + "[.][0-9]+\\([eE][-+]?[0-9]+\\)?[fFdD]?\\>" + "\\|" + "\\<[0-9]+[eE][-+]?[0-9]+[fFdD]?\\>" + "\\|" + "\\<0[xX][0-9a-fA-F]+[lL]?\\>" + "\\|" + "\\<[0-9]+[lLfFdD]?\\>" + "\\)" + )) + "Regular expression for matching a number. +If this value is nil, no number extraction is done during lex. +This expression tries to match C and Java like numbers. + +DECIMAL_LITERAL: + [1-9][0-9]* + ; +HEX_LITERAL: + 0[xX][0-9a-fA-F]+ + ; +OCTAL_LITERAL: + 0[0-7]* + ; +INTEGER_LITERAL: + <DECIMAL_LITERAL>[lL]? + | <HEX_LITERAL>[lL]? + | <OCTAL_LITERAL>[lL]? + ; +EXPONENT: + [eE][+-]?[09]+ + ; +FLOATING_POINT_LITERAL: + [0-9]+[.][0-9]*<EXPONENT>?[fFdD]? + | [.][0-9]+<EXPONENT>?[fFdD]? + | [0-9]+<EXPONENT>[fFdD]? + | [0-9]+<EXPONENT>?[fFdD] + ;") +(make-variable-buffer-local 'semantic-lex-number-expression) + +(defvar semantic-lex-depth 0 + "Default lexing depth. +This specifies how many lists to create tokens in.") +(make-variable-buffer-local 'semantic-lex-depth) + +(defvar semantic-lex-unterminated-syntax-end-function + (lambda (syntax syntax-start lex-end) lex-end) + "Function called when unterminated syntax is encountered. +This should be set to one function. That function should take three +parameters. The SYNTAX, or type of syntax which is unterminated. +SYNTAX-START where the broken syntax begins. +LEX-END is where the lexical analysis was asked to end. +This function can be used for languages that can intelligently fix up +broken syntax, or the exit lexical analysis via `throw' or `signal' +when finding unterminated syntax.") + +;;; Interactive testing commands + +(declare-function semantic-elapsed-time "semantic") + +(defun semantic-lex-test (arg) + "Test the semantic lexer in the current buffer. +If universal argument ARG, then try the whole buffer." + (interactive "P") + (require 'semantic) + (let* ((start (current-time)) + (result (semantic-lex + (if arg (point-min) (point)) + (point-max))) + (end (current-time))) + (message "Elapsed Time: %.2f seconds." + (semantic-elapsed-time start end)) + (pop-to-buffer "*Lexer Output*") + (require 'pp) + (erase-buffer) + (insert (pp-to-string result)) + (goto-char (point-min)) + )) + +(defvar semantic-lex-debug nil + "When non-nil, debug the local lexical analyzer.") + +(defun semantic-lex-debug (arg) + "Debug the semantic lexer in the current buffer. +Argument ARG specifies of the analyze the whole buffer, or start at point. +While engaged, each token identified by the lexer will be highlighted +in the target buffer A description of the current token will be +displayed in the minibuffer. Press SPC to move to the next lexical token." + (interactive "P") + (require 'semantic/debug) + (let ((semantic-lex-debug t)) + (semantic-lex-test arg))) + +(defun semantic-lex-highlight-token (token) + "Highlight the lexical TOKEN. +TOKEN is a lexical token with a START And END position. +Return the overlay." + (let ((o (semantic-make-overlay (semantic-lex-token-start token) + (semantic-lex-token-end token)))) + (semantic-overlay-put o 'face 'highlight) + o)) + +(defsubst semantic-lex-debug-break (token) + "Break during lexical analysis at TOKEN." + (when semantic-lex-debug + (let ((o nil)) + (unwind-protect + (progn + (when token + (setq o (semantic-lex-highlight-token token))) + (semantic-read-event + (format "%S :: SPC - continue" token)) + ) + (when o + (semantic-overlay-delete o)))))) + +;;; Lexical analyzer creation +;; +;; Code for creating a lex function from lists of analyzers. +;; +;; A lexical analyzer is created from a list of individual analyzers. +;; Each individual analyzer specifies a single match, and code that +;; goes with it. +;; +;; Creation of an analyzer assembles these analyzers into a new function +;; with the behaviors of all the individual analyzers. +;; +(defmacro semantic-lex-one-token (analyzers) + "Calculate one token from the current buffer at point. +Uses locally bound variables from `define-lex'. +Argument ANALYZERS is the list of analyzers being used." + (cons 'cond (mapcar #'symbol-value analyzers))) + +(defvar semantic-lex-end-point nil + "The end point as tracked through lexical functions.") + +(defvar semantic-lex-current-depth nil + "The current depth as tracked through lexical functions.") + +(defvar semantic-lex-maximum-depth nil + "The maximum depth of parenthisis as tracked through lexical functions.") + +(defvar semantic-lex-token-stream nil + "The current token stream we are collecting.") + +(defvar semantic-lex-analysis-bounds nil + "The bounds of the current analysis.") + +(defvar semantic-lex-block-streams nil + "Streams of tokens inside collapsed blocks. +This is an alist of (ANCHOR . STREAM) elements where ANCHOR is the +start position of the block, and STREAM is the list of tokens in that +block.") + +(defvar semantic-lex-reset-hooks nil + "Abnormal hook used by major-modes to reset lexical analyzers. +Hook functions are called with START and END values for the +current lexical pass. Should be set with `add-hook', specifying +a LOCAL option.") + +;; Stack of nested blocks. +(defvar semantic-lex-block-stack nil) +;;(defvar semantic-lex-timeout 5 +;; "*Number of sections of lexing before giving up.") + +(defmacro define-lex (name doc &rest analyzers) + "Create a new lexical analyzer with NAME. +DOC is a documentation string describing this analyzer. +ANALYZERS are small code snippets of analyzers to use when +building the new NAMED analyzer. Only use analyzers which +are written to be used in `define-lex'. +Each analyzer should be an analyzer created with `define-lex-analyzer'. +Note: The order in which analyzers are listed is important. +If two analyzers can match the same text, it is important to order the +analyzers so that the one you want to match first occurs first. For +example, it is good to put a numbe analyzer in front of a symbol +analyzer which might mistake a number for as a symbol." + `(defun ,name (start end &optional depth length) + ,(concat doc "\nSee `semantic-lex' for more information.") + ;; Make sure the state of block parsing starts over. + (setq semantic-lex-block-streams nil) + ;; Allow specialty reset items. + (run-hook-with-args 'semantic-lex-reset-hooks start end) + ;; Lexing state. + (let* (;(starttime (current-time)) + (starting-position (point)) + (semantic-lex-token-stream nil) + (semantic-lex-block-stack nil) + (tmp-start start) + (semantic-lex-end-point start) + (semantic-lex-current-depth 0) + ;; Use the default depth when not specified. + (semantic-lex-maximum-depth + (or depth semantic-lex-depth)) + ;; Bounds needed for unterminated syntax + (semantic-lex-analysis-bounds (cons start end)) + ;; This entry prevents text properties from + ;; confusing our lexical analysis. See Emacs 22 (CVS) + ;; version of C++ mode with template hack text properties. + (parse-sexp-lookup-properties nil) + ) + ;; Maybe REMOVE THIS LATER. + ;; Trying to find incremental parser bug. + (when (> end (point-max)) + (error ,(format "%s: end (%%d) > point-max (%%d)" name) + end (point-max))) + (with-syntax-table semantic-lex-syntax-table + (goto-char start) + (while (and (< (point) end) + (or (not length) + (<= (length semantic-lex-token-stream) length))) + (semantic-lex-one-token ,analyzers) + (when (eq semantic-lex-end-point tmp-start) + (error ,(format "%s: endless loop at %%d, after %%S" name) + tmp-start (car semantic-lex-token-stream))) + (setq tmp-start semantic-lex-end-point) + (goto-char semantic-lex-end-point) + ;;(when (> (semantic-elapsed-time starttime (current-time)) + ;; semantic-lex-timeout) + ;; (error "Timeout during lex at char %d" (point))) + (semantic-throw-on-input 'lex) + (semantic-lex-debug-break (car semantic-lex-token-stream)) + )) + ;; Check that there is no unterminated block. + (when semantic-lex-block-stack + (let* ((last (pop semantic-lex-block-stack)) + (blk last)) + (while blk + (message + ,(format "%s: `%%s' block from %%S is unterminated" name) + (car blk) (cadr blk)) + (setq blk (pop semantic-lex-block-stack))) + (semantic-lex-unterminated-syntax-detected (car last)))) + ;; Return to where we started. + ;; Do not wrap in protective stuff so that if there is an error + ;; thrown, the user knows where. + (goto-char starting-position) + ;; Return the token stream + (nreverse semantic-lex-token-stream)))) + +;;; Collapsed block tokens delimited by any tokens. +;; +(defun semantic-lex-start-block (syntax) + "Mark the last read token as the beginning of a SYNTAX block." + (if (or (not semantic-lex-maximum-depth) + (< semantic-lex-current-depth semantic-lex-maximum-depth)) + (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)) + (push (list syntax (car semantic-lex-token-stream)) + semantic-lex-block-stack))) + +(defun semantic-lex-end-block (syntax) + "Process the end of a previously marked SYNTAX block. +That is, collapse the tokens inside that block, including the +beginning and end of block tokens, into a high level block token of +class SYNTAX. +The token at beginning of block is the one marked by a previous call +to `semantic-lex-start-block'. The current token is the end of block. +The collapsed tokens are saved in `semantic-lex-block-streams'." + (if (null semantic-lex-block-stack) + (setq semantic-lex-current-depth (1- semantic-lex-current-depth)) + (let* ((stream semantic-lex-token-stream) + (blk (pop semantic-lex-block-stack)) + (bstream (cdr blk)) + (first (car bstream)) + (last (pop stream)) ;; The current token mark the EOBLK + tok) + (if (not (eq (car blk) syntax)) + ;; SYNTAX doesn't match the syntax of the current block in + ;; the stack. So we encountered the end of the SYNTAX block + ;; before the end of the current one in the stack which is + ;; signaled unterminated. + (semantic-lex-unterminated-syntax-detected (car blk)) + ;; Move tokens found inside the block from the main stream + ;; into a separate block stream. + (while (and stream (not (eq (setq tok (pop stream)) first))) + (push tok bstream)) + ;; The token marked as beginning of block was not encountered. + ;; This should not happen! + (or (eq tok first) + (error "Token %S not found at beginning of block `%s'" + first syntax)) + ;; Save the block stream for future reuse, to avoid to redo + ;; the lexical analysis of the block content! + ;; Anchor the block stream with its start position, so we can + ;; use: (cdr (assq start semantic-lex-block-streams)) to + ;; quickly retrieve the lexical stream associated to a block. + (setcar blk (semantic-lex-token-start first)) + (setcdr blk (nreverse bstream)) + (push blk semantic-lex-block-streams) + ;; In the main stream, replace the tokens inside the block by + ;; a high level block token of class SYNTAX. + (setq semantic-lex-token-stream stream) + (semantic-lex-push-token + (semantic-lex-token + syntax (car blk) (semantic-lex-token-end last))) + )))) + +;;; Lexical token API +;; +;; Functions for accessing parts of a token. Use these functions +;; instead of accessing the list structure directly because the +;; contents of the lexical may change. +;; +(defmacro semantic-lex-token (symbol start end &optional str) + "Create a lexical token. +SYMBOL is a symbol representing the class of syntax found. +START and END define the bounds of the token in the current buffer. +Optional STR is the string for the token iff the the bounds +in the buffer do not cover the string they represent. (As from +macro expansion.)" + ;; This if statement checks the existance of a STR argument at + ;; compile time, where STR is some symbol or constant. If the + ;; variable STr (runtime) is nil, this will make an incorrect decision. + ;; + ;; It is like this to maintain the original speed of the compiled + ;; code. + (if str + `(cons ,symbol (cons ,str (cons ,start ,end))) + `(cons ,symbol (cons ,start ,end)))) + +(defun semantic-lex-token-p (thing) + "Return non-nil if THING is a semantic lex token. +This is an exhaustively robust check." + (and (consp thing) + (symbolp (car thing)) + (or (and (numberp (nth 1 thing)) + (numberp (nthcdr 2 thing))) + (and (stringp (nth 1 thing)) + (numberp (nth 2 thing)) + (numberp (nthcdr 3 thing))) + )) + ) + +(defun semantic-lex-token-with-text-p (thing) + "Return non-nil if THING is a semantic lex token. +This is an exhaustively robust check." + (and (consp thing) + (symbolp (car thing)) + (= (length thing) 4) + (stringp (nth 1 thing)) + (numberp (nth 2 thing)) + (numberp (nth 3 thing))) + ) + +(defun semantic-lex-token-without-text-p (thing) + "Return non-nil if THING is a semantic lex token. +This is an exhaustively robust check." + (and (consp thing) + (symbolp (car thing)) + (= (length thing) 3) + (numberp (nth 1 thing)) + (numberp (nth 2 thing))) + ) + +(eval-and-compile + +(defun semantic-lex-expand-block-specs (specs) + "Expand block specifications SPECS into a Lisp form. +SPECS is a list of (BLOCK BEGIN END) elements where BLOCK, BEGIN, and +END are token class symbols that indicate to produce one collapsed +BLOCK token from tokens found between BEGIN and END ones. +BLOCK must be a non-nil symbol, and at least one of the BEGIN or END +symbols must be non-nil too. +When BEGIN is non-nil, generate a call to `semantic-lex-start-block' +when a BEGIN token class is encountered. +When END is non-nil, generate a call to `semantic-lex-end-block' when +an END token class is encountered." + (let ((class (make-symbol "class")) + (form nil)) + (dolist (spec specs) + (when (car spec) + (when (nth 1 spec) + (push `((eq ',(nth 1 spec) ,class) + (semantic-lex-start-block ',(car spec))) + form)) + (when (nth 2 spec) + (push `((eq ',(nth 2 spec) ,class) + (semantic-lex-end-block ',(car spec))) + form)))) + (when form + `((let ((,class (semantic-lex-token-class + (car semantic-lex-token-stream)))) + (cond ,@(nreverse form)))) + ))) +) + +(defmacro semantic-lex-push-token (token &rest blockspecs) + "Push TOKEN in the lexical analyzer token stream. +Return the lexical analysis current end point. +If optional arguments BLOCKSPECS is non-nil, it specifies to process +collapsed block tokens. See `semantic-lex-expand-block-specs' for +more details. +This macro should only be called within the bounds of +`define-lex-analyzer'. It changes the values of the lexical analyzer +variables `token-stream' and `semantic-lex-end-point'. If you need to +move `semantic-lex-end-point' somewhere else, just modify this +variable after calling `semantic-lex-push-token'." + `(progn + (push ,token semantic-lex-token-stream) + ,@(semantic-lex-expand-block-specs blockspecs) + (setq semantic-lex-end-point + (semantic-lex-token-end (car semantic-lex-token-stream))) + )) + +(defsubst semantic-lex-token-class (token) + "Fetch the class of the lexical token TOKEN. +See also the function `semantic-lex-token'." + (car token)) + +(defsubst semantic-lex-token-text (token) + "Fetch the text associated with the lexical token TOKEN. +See also the function `semantic-lex-token'." + (if (stringp (car (cdr token))) + (car (cdr token)) + (buffer-substring-no-properties + (semantic-lex-token-start token) + (semantic-lex-token-end token)))) + +(defun semantic-lex-init () + "Initialize any lexical state for this buffer." + (unless semantic-lex-comment-regex + (setq semantic-lex-comment-regex + (if comment-start-skip + (concat "\\(\\s<\\|" comment-start-skip "\\)") + "\\(\\s<\\)"))) + ;; Setup the lexer syntax-table + (setq semantic-lex-syntax-table (copy-syntax-table (syntax-table))) + (dolist (mod semantic-lex-syntax-modifications) + (modify-syntax-entry + (car mod) (nth 1 mod) semantic-lex-syntax-table))) + +;;;###autoload +(define-overloadable-function semantic-lex (start end &optional depth length) + "Lexically analyze text in the current buffer between START and END. +Optional argument DEPTH indicates at what level to scan over entire +lists. The last argument, LENGTH specifies that `semantic-lex' +should only return LENGTH tokens. The return value is a token stream. +Each element is a list, such of the form + (symbol start-expression . end-expression) +where SYMBOL denotes the token type. +See `semantic-lex-tokens' variable for details on token types. END +does not mark the end of the text scanned, only the end of the +beginning of text scanned. Thus, if a string extends past END, the +end of the return token will be larger than END. To truly restrict +scanning, use `narrow-to-region'." + (funcall semantic-lex-analyzer start end depth length)) + +(defsubst semantic-lex-buffer (&optional depth) + "Lex the current buffer. +Optional argument DEPTH is the depth to scan into lists." + (semantic-lex (point-min) (point-max) depth)) + +(defsubst semantic-lex-list (semlist depth) + "Lex the body of SEMLIST to DEPTH." + (semantic-lex (semantic-lex-token-start semlist) + (semantic-lex-token-end semlist) + depth)) + +;;; Analyzer creation macros +;; +;; An individual analyzer is a condition and code that goes with it. +;; +;; Created analyzers become variables with the code associated with them +;; as the symbol value. These analyzers are assembled into a lexer +;; to create new lexical analyzers. + +(defcustom semantic-lex-debug-analyzers nil + "Non nil means to debug analyzers with syntax protection. +Only in effect if `debug-on-error' is also non-nil." + :group 'semantic + :type 'boolean) + +(defmacro semantic-lex-unterminated-syntax-protection (syntax &rest forms) + "For SYNTAX, execute FORMS with protection for unterminated syntax. +If FORMS throws an error, treat this as a syntax problem, and +execute the unterminated syntax code. FORMS should return a position. +Irreguardless of an error, the cursor should be moved to the end of +the desired syntax, and a position returned. +If `debug-on-error' is set, errors are not caught, so that you can +debug them. +Avoid using a large FORMS since it is duplicated." + `(if (and debug-on-error semantic-lex-debug-analyzers) + (progn ,@forms) + (condition-case nil + (progn ,@forms) + (error + (semantic-lex-unterminated-syntax-detected ,syntax))))) +(put 'semantic-lex-unterminated-syntax-protection + 'lisp-indent-function 1) + +(defmacro define-lex-analyzer (name doc condition &rest forms) + "Create a single lexical analyzer NAME with DOC. +When an analyzer is called, the current buffer and point are +positioned in a buffer at the location to be analyzed. +CONDITION is an expression which returns t if FORMS should be run. +Within the bounds of CONDITION and FORMS, the use of backquote +can be used to evaluate expressions at compile time. +While forms are running, the following variables will be locally bound: + `semantic-lex-analysis-bounds' - The bounds of the current analysis. + of the form (START . END) + `semantic-lex-maximum-depth' - The maximum depth of semantic-list + for the current analysis. + `semantic-lex-current-depth' - The current depth of `semantic-list' that has + been decended. + `semantic-lex-end-point' - End Point after match. + Analyzers should set this to a buffer location if their + match string does not represent the end of the matched text. + `semantic-lex-token-stream' - The token list being collected. + Add new lexical tokens to this list. +Proper action in FORMS is to move the value of `semantic-lex-end-point' to +after the location of the analyzed entry, and to add any discovered tokens +at the beginning of `semantic-lex-token-stream'. +This can be done by using `semantic-lex-push-token'." + `(eval-and-compile + (defvar ,name nil ,doc) + (defun ,name nil) + ;; Do this part separately so that re-evaluation rebuilds this code. + (setq ,name '(,condition ,@forms)) + ;; Build a single lexical analyzer function, so the doc for + ;; function help is automatically provided, and perhaps the + ;; function could be useful for testing and debugging one + ;; analyzer. + (fset ',name (lambda () ,doc + (let ((semantic-lex-token-stream nil) + (semantic-lex-end-point (point)) + (semantic-lex-analysis-bounds + (cons (point) (point-max))) + (semantic-lex-current-depth 0) + (semantic-lex-maximum-depth + semantic-lex-depth) + ) + (when ,condition ,@forms) + semantic-lex-token-stream))) + )) + +(defmacro define-lex-regex-analyzer (name doc regexp &rest forms) + "Create a lexical analyzer with NAME and DOC that will match REGEXP. +FORMS are evaluated upon a successful match. +See `define-lex-analyzer' for more about analyzers." + `(define-lex-analyzer ,name + ,doc + (looking-at ,regexp) + ,@forms + )) + +(defmacro define-lex-simple-regex-analyzer (name doc regexp toksym + &optional index + &rest forms) + "Create a lexical analyzer with NAME and DOC that match REGEXP. +TOKSYM is the symbol to use when creating a semantic lexical token. +INDEX is the index into the match that defines the bounds of the token. +Index should be a plain integer, and not specified in the macro as an +expression. +FORMS are evaluated upon a successful match BEFORE the new token is +created. It is valid to ignore FORMS. +See `define-lex-analyzer' for more about analyzers." + `(define-lex-analyzer ,name + ,doc + (looking-at ,regexp) + ,@forms + (semantic-lex-push-token + (semantic-lex-token ,toksym + (match-beginning ,(or index 0)) + (match-end ,(or index 0)))) + )) + +(defmacro define-lex-block-analyzer (name doc spec1 &rest specs) + "Create a lexical analyzer NAME for paired delimiters blocks. +It detects a paired delimiters block or the corresponding open or +close delimiter depending on the value of the variable +`semantic-lex-current-depth'. DOC is the documentation string of the lexical +analyzer. SPEC1 and SPECS specify the token symbols and open, close +delimiters used. Each SPEC has the form: + +\(BLOCK-SYM (OPEN-DELIM OPEN-SYM) (CLOSE-DELIM CLOSE-SYM)) + +where BLOCK-SYM is the symbol returned in a block token. OPEN-DELIM +and CLOSE-DELIM are respectively the open and close delimiters +identifying a block. OPEN-SYM and CLOSE-SYM are respectively the +symbols returned in open and close tokens." + (let ((specs (cons spec1 specs)) + spec open olist clist) + (while specs + (setq spec (car specs) + specs (cdr specs) + open (nth 1 spec) + ;; build alist ((OPEN-DELIM OPEN-SYM BLOCK-SYM) ...) + olist (cons (list (car open) (cadr open) (car spec)) olist) + ;; build alist ((CLOSE-DELIM CLOSE-SYM) ...) + clist (cons (nth 2 spec) clist))) + `(define-lex-analyzer ,name + ,doc + (and + (looking-at "\\(\\s(\\|\\s)\\)") + (let ((text (match-string 0)) match) + (cond + ((setq match (assoc text ',olist)) + (if (or (not semantic-lex-maximum-depth) + (< semantic-lex-current-depth semantic-lex-maximum-depth)) + (progn + (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)) + (semantic-lex-push-token + (semantic-lex-token + (nth 1 match) + (match-beginning 0) (match-end 0)))) + (semantic-lex-push-token + (semantic-lex-token + (nth 2 match) + (match-beginning 0) + (save-excursion + (semantic-lex-unterminated-syntax-protection (nth 2 match) + (forward-list 1) + (point))) + )) + )) + ((setq match (assoc text ',clist)) + (setq semantic-lex-current-depth (1- semantic-lex-current-depth)) + (semantic-lex-push-token + (semantic-lex-token + (nth 1 match) + (match-beginning 0) (match-end 0))))))) + ))) + +;;; Analyzers +;; +;; Pre-defined common analyzers. +;; +(define-lex-analyzer semantic-lex-default-action + "The default action when no other lexical actions match text. +This action will just throw an error." + t + (error "Unmatched Text during Lexical Analysis")) + +(define-lex-analyzer semantic-lex-beginning-of-line + "Detect and create a beginning of line token (BOL)." + (and (bolp) + ;; Just insert a (bol N . N) token in the token stream, + ;; without moving the point. N is the point at the + ;; beginning of line. + (semantic-lex-push-token (semantic-lex-token 'bol (point) (point))) + nil) ;; CONTINUE + ;; We identify and add the BOL token onto the stream, but since + ;; semantic-lex-end-point doesn't move, we always fail CONDITION, and have no + ;; FORMS body. + nil) + +(define-lex-simple-regex-analyzer semantic-lex-newline + "Detect and create newline tokens." + "\\s-*\\(\n\\|\\s>\\)" 'newline 1) + +(define-lex-regex-analyzer semantic-lex-newline-as-whitespace + "Detect and create newline tokens. +Use this ONLY if newlines are not whitespace characters (such as when +they are comment end characters) AND when you want whitespace tokens." + "\\s-*\\(\n\\|\\s>\\)" + ;; Language wants whitespaces. Create a token for it. + (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) + 'whitespace) + ;; Merge whitespace tokens together if they are adjacent. Two + ;; whitespace tokens may be sperated by a comment which is not in + ;; the token stream. + (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream)) + (match-end 0)) + (semantic-lex-push-token + (semantic-lex-token + 'whitespace (match-beginning 0) (match-end 0))))) + +(define-lex-regex-analyzer semantic-lex-ignore-newline + "Detect and ignore newline tokens. +Use this ONLY if newlines are not whitespace characters (such as when +they are comment end characters)." + "\\s-*\\(\n\\|\\s>\\)" + (setq semantic-lex-end-point (match-end 0))) + +(define-lex-regex-analyzer semantic-lex-whitespace + "Detect and create whitespace tokens." + ;; catch whitespace when needed + "\\s-+" + ;; Language wants whitespaces. Create a token for it. + (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) + 'whitespace) + ;; Merge whitespace tokens together if they are adjacent. Two + ;; whitespace tokens may be sperated by a comment which is not in + ;; the token stream. + (progn + (setq semantic-lex-end-point (match-end 0)) + (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream)) + semantic-lex-end-point)) + (semantic-lex-push-token + (semantic-lex-token + 'whitespace (match-beginning 0) (match-end 0))))) + +(define-lex-regex-analyzer semantic-lex-ignore-whitespace + "Detect and skip over whitespace tokens." + ;; catch whitespace when needed + "\\s-+" + ;; Skip over the detected whitespace, do not create a token for it. + (setq semantic-lex-end-point (match-end 0))) + +(define-lex-simple-regex-analyzer semantic-lex-number + "Detect and create number tokens. +See `semantic-lex-number-expression' for details on matching numbers, +and number formats." + semantic-lex-number-expression 'number) + +(define-lex-regex-analyzer semantic-lex-symbol-or-keyword + "Detect and create symbol and keyword tokens." + "\\(\\sw\\|\\s_\\)+" + (semantic-lex-push-token + (semantic-lex-token + (or (semantic-lex-keyword-p (match-string 0)) 'symbol) + (match-beginning 0) (match-end 0)))) + +(define-lex-simple-regex-analyzer semantic-lex-charquote + "Detect and create charquote tokens." + ;; Character quoting characters (ie, \n as newline) + "\\s\\+" 'charquote) + +(define-lex-simple-regex-analyzer semantic-lex-punctuation + "Detect and create punctuation tokens." + "\\(\\s.\\|\\s$\\|\\s'\\)" 'punctuation) + +(define-lex-analyzer semantic-lex-punctuation-type + "Detect and create a punctuation type token. +Recognized punctuations are defined in the current table of lexical +types, as the value of the `punctuation' token type." + (and (looking-at "\\(\\s.\\|\\s$\\|\\s'\\)+") + (let* ((key (match-string 0)) + (pos (match-beginning 0)) + (end (match-end 0)) + (len (- end pos)) + (lst (semantic-lex-type-value "punctuation" t)) + (def (car lst)) ;; default lexical symbol or nil + (lst (cdr lst)) ;; alist of (LEX-SYM . PUNCT-STRING) + (elt nil)) + (if lst + ;; Starting with the longest one, search if the + ;; punctuation string is defined for this language. + (while (and (> len 0) (not (setq elt (rassoc key lst)))) + (setq len (1- len) + key (substring key 0 len)))) + (if elt ;; Return the punctuation token found + (semantic-lex-push-token + (semantic-lex-token (car elt) pos (+ pos len))) + (if def ;; Return a default generic token + (semantic-lex-push-token + (semantic-lex-token def pos end)) + ;; Nothing match + ))))) + +(define-lex-regex-analyzer semantic-lex-paren-or-list + "Detect open parenthesis. +Return either a paren token or a semantic list token depending on +`semantic-lex-current-depth'." + "\\s(" + (if (or (not semantic-lex-maximum-depth) + (< semantic-lex-current-depth semantic-lex-maximum-depth)) + (progn + (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)) + (semantic-lex-push-token + (semantic-lex-token + 'open-paren (match-beginning 0) (match-end 0)))) + (semantic-lex-push-token + (semantic-lex-token + 'semantic-list (match-beginning 0) + (save-excursion + (semantic-lex-unterminated-syntax-protection 'semantic-list + (forward-list 1) + (point)) + ))) + )) + +(define-lex-simple-regex-analyzer semantic-lex-open-paren + "Detect and create an open parenthisis token." + "\\s(" 'open-paren 0 (setq semantic-lex-current-depth (1+ semantic-lex-current-depth))) + +(define-lex-simple-regex-analyzer semantic-lex-close-paren + "Detect and create a close paren token." + "\\s)" 'close-paren 0 (setq semantic-lex-current-depth (1- semantic-lex-current-depth))) + +(define-lex-regex-analyzer semantic-lex-string + "Detect and create a string token." + "\\s\"" + ;; Zing to the end of this string. + (semantic-lex-push-token + (semantic-lex-token + 'string (point) + (save-excursion + (semantic-lex-unterminated-syntax-protection 'string + (forward-sexp 1) + (point)) + )))) + +(define-lex-regex-analyzer semantic-lex-comments + "Detect and create a comment token." + semantic-lex-comment-regex + (save-excursion + (forward-comment 1) + ;; Generate newline token if enabled + (if (bolp) (backward-char 1)) + (setq semantic-lex-end-point (point)) + ;; Language wants comments or want them as whitespaces, + ;; link them together. + (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) 'comment) + (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream)) + semantic-lex-end-point) + (semantic-lex-push-token + (semantic-lex-token + 'comment (match-beginning 0) semantic-lex-end-point))))) + +(define-lex-regex-analyzer semantic-lex-comments-as-whitespace + "Detect comments and create a whitespace token." + semantic-lex-comment-regex + (save-excursion + (forward-comment 1) + ;; Generate newline token if enabled + (if (bolp) (backward-char 1)) + (setq semantic-lex-end-point (point)) + ;; Language wants comments or want them as whitespaces, + ;; link them together. + (if (eq (semantic-lex-token-class (car semantic-lex-token-stream)) 'whitespace) + (setcdr (semantic-lex-token-bounds (car semantic-lex-token-stream)) + semantic-lex-end-point) + (semantic-lex-push-token + (semantic-lex-token + 'whitespace (match-beginning 0) semantic-lex-end-point))))) + +(define-lex-regex-analyzer semantic-lex-ignore-comments + "Detect and create a comment token." + semantic-lex-comment-regex + (let ((comment-start-point (point))) + (forward-comment 1) + (if (eq (point) comment-start-point) + ;; In this case our start-skip string failed + ;; to work properly. Lets try and move over + ;; whatever white space we matched to begin + ;; with. + (skip-syntax-forward "-.'" + (save-excursion + (end-of-line) + (point))) + ;; We may need to back up so newlines or whitespace is generated. + (if (bolp) + (backward-char 1))) + (if (eq (point) comment-start-point) + (error "Strange comment syntax prevents lexical analysis")) + (setq semantic-lex-end-point (point)))) + +;;; Comment lexer +;; +;; Predefined lexers that could be used instead of creating new +;; analyers. + +(define-lex semantic-comment-lexer + "A simple lexical analyzer that handles comments. +This lexer will only return comment tokens. It is the default lexer +used by `semantic-find-doc-snarf-comment' to snarf up the comment at +point." + semantic-lex-ignore-whitespace + semantic-lex-ignore-newline + semantic-lex-comments + semantic-lex-default-action) + +;;; Test Lexer +;; +(define-lex semantic-simple-lexer + "A simple lexical analyzer that handles simple buffers. +This lexer ignores comments and whitespace, and will return +syntax as specified by the syntax table." + semantic-lex-ignore-whitespace + semantic-lex-ignore-newline + semantic-lex-number + semantic-lex-symbol-or-keyword + semantic-lex-charquote + semantic-lex-paren-or-list + semantic-lex-close-paren + semantic-lex-string + semantic-lex-ignore-comments + semantic-lex-punctuation + semantic-lex-default-action) + +;;; Analyzers generated from grammar. +;; +;; Some analyzers are hand written. Analyzers created with these +;; functions are generated from the grammar files. + +(defmacro define-lex-keyword-type-analyzer (name doc syntax) + "Define a keyword type analyzer NAME with DOC string. +SYNTAX is the regexp that matches a keyword syntactic expression." + (let ((key (make-symbol "key"))) + `(define-lex-analyzer ,name + ,doc + (and (looking-at ,syntax) + (let ((,key (semantic-lex-keyword-p (match-string 0)))) + (when ,key + (semantic-lex-push-token + (semantic-lex-token + ,key (match-beginning 0) (match-end 0))))))) + )) + +(defmacro define-lex-sexp-type-analyzer (name doc syntax token) + "Define a sexp type analyzer NAME with DOC string. +SYNTAX is the regexp that matches the beginning of the s-expression. +TOKEN is the lexical token returned when SYNTAX matches." + `(define-lex-regex-analyzer ,name + ,doc + ,syntax + (semantic-lex-push-token + (semantic-lex-token + ,token (point) + (save-excursion + (semantic-lex-unterminated-syntax-protection ,token + (forward-sexp 1) + (point)))))) + ) + +(defmacro define-lex-regex-type-analyzer (name doc syntax matches default) + "Define a regexp type analyzer NAME with DOC string. +SYNTAX is the regexp that matches a syntactic expression. +MATCHES is an alist of lexical elements used to refine the syntactic +expression. +DEFAULT is the default lexical token returned when no MATCHES." + (if matches + (let* ((val (make-symbol "val")) + (lst (make-symbol "lst")) + (elt (make-symbol "elt")) + (pos (make-symbol "pos")) + (end (make-symbol "end"))) + `(define-lex-analyzer ,name + ,doc + (and (looking-at ,syntax) + (let* ((,val (match-string 0)) + (,pos (match-beginning 0)) + (,end (match-end 0)) + (,lst ,matches) + ,elt) + (while (and ,lst (not ,elt)) + (if (string-match (cdar ,lst) ,val) + (setq ,elt (caar ,lst)) + (setq ,lst (cdr ,lst)))) + (semantic-lex-push-token + (semantic-lex-token (or ,elt ,default) ,pos ,end)))) + )) + `(define-lex-simple-regex-analyzer ,name + ,doc + ,syntax ,default) + )) + +(defmacro define-lex-string-type-analyzer (name doc syntax matches default) + "Define a string type analyzer NAME with DOC string. +SYNTAX is the regexp that matches a syntactic expression. +MATCHES is an alist of lexical elements used to refine the syntactic +expression. +DEFAULT is the default lexical token returned when no MATCHES." + (if matches + (let* ((val (make-symbol "val")) + (lst (make-symbol "lst")) + (elt (make-symbol "elt")) + (pos (make-symbol "pos")) + (end (make-symbol "end")) + (len (make-symbol "len"))) + `(define-lex-analyzer ,name + ,doc + (and (looking-at ,syntax) + (let* ((,val (match-string 0)) + (,pos (match-beginning 0)) + (,end (match-end 0)) + (,len (- ,end ,pos)) + (,lst ,matches) + ,elt) + ;; Starting with the longest one, search if a lexical + ;; value match a token defined for this language. + (while (and (> ,len 0) (not (setq ,elt (rassoc ,val ,lst)))) + (setq ,len (1- ,len) + ,val (substring ,val 0 ,len))) + (when ,elt ;; Adjust token end position. + (setq ,elt (car ,elt) + ,end (+ ,pos ,len))) + (semantic-lex-push-token + (semantic-lex-token (or ,elt ,default) ,pos ,end)))) + )) + `(define-lex-simple-regex-analyzer ,name + ,doc + ,syntax ,default) + )) + +(defmacro define-lex-block-type-analyzer (name doc syntax matches) + "Define a block type analyzer NAME with DOC string. + +SYNTAX is the regexp that matches block delimiters, typically the +open (`\\\\s(') and close (`\\\\s)') parenthesis syntax classes. + +MATCHES is a pair (OPEN-SPECS . CLOSE-SPECS) that defines blocks. + + OPEN-SPECS is a list of (OPEN-DELIM OPEN-TOKEN BLOCK-TOKEN) elements + where: + + OPEN-DELIM is a string: the block open delimiter character. + + OPEN-TOKEN is the lexical token class associated to the OPEN-DELIM + delimiter. + + BLOCK-TOKEN is the lexical token class associated to the block + that starts at the OPEN-DELIM delimiter. + + CLOSE-SPECS is a list of (CLOSE-DELIM CLOSE-TOKEN) elements where: + + CLOSE-DELIM is a string: the block end delimiter character. + + CLOSE-TOKEN is the lexical token class associated to the + CLOSE-DELIM delimiter. + +Each element in OPEN-SPECS must have a corresponding element in +CLOSE-SPECS. + +The lexer will return a BLOCK-TOKEN token when the value of +`semantic-lex-current-depth' is greater than or equal to the maximum +depth of parenthesis tracking (see also the function `semantic-lex'). +Otherwise it will return OPEN-TOKEN and CLOSE-TOKEN tokens. + +TO DO: Put the following in the developer's guide and just put a +reference here. + +In the grammar: + +The value of a block token must be a string that contains a readable +sexp of the form: + + \"(OPEN-TOKEN CLOSE-TOKEN)\" + +OPEN-TOKEN and CLOSE-TOKEN represent the block delimiters, and must be +lexical tokens of respectively `open-paren' and `close-paren' types. +Their value is the corresponding delimiter character as a string. + +Here is a small example to analyze a parenthesis block: + + %token <block> PAREN_BLOCK \"(LPAREN RPAREN)\" + %token <open-paren> LPAREN \"(\" + %token <close-paren> RPAREN \")\" + +When the lexer encounters the open-paren delimiter \"(\": + + - If the maximum depth of parenthesis tracking is not reached (that + is, current depth < max depth), it returns a (LPAREN start . end) + token, then continue analysis inside the block. Later, when the + corresponding close-paren delimiter \")\" will be encountered, it + will return a (RPAREN start . end) token. + + - If the maximum depth of parenthesis tracking is reached (current + depth >= max depth), it returns the whole parenthesis block as + a (PAREN_BLOCK start . end) token." + (let* ((val (make-symbol "val")) + (lst (make-symbol "lst")) + (elt (make-symbol "elt"))) + `(define-lex-analyzer ,name + ,doc + (and + (looking-at ,syntax) ;; "\\(\\s(\\|\\s)\\)" + (let ((,val (match-string 0)) + (,lst ,matches) + ,elt) + (cond + ((setq ,elt (assoc ,val (car ,lst))) + (if (or (not semantic-lex-maximum-depth) + (< semantic-lex-current-depth semantic-lex-maximum-depth)) + (progn + (setq semantic-lex-current-depth (1+ semantic-lex-current-depth)) + (semantic-lex-push-token + (semantic-lex-token + (nth 1 ,elt) + (match-beginning 0) (match-end 0)))) + (semantic-lex-push-token + (semantic-lex-token + (nth 2 ,elt) + (match-beginning 0) + (save-excursion + (semantic-lex-unterminated-syntax-protection (nth 2 ,elt) + (forward-list 1) + (point))))))) + ((setq ,elt (assoc ,val (cdr ,lst))) + (setq semantic-lex-current-depth (1- semantic-lex-current-depth)) + (semantic-lex-push-token + (semantic-lex-token + (nth 1 ,elt) + (match-beginning 0) (match-end 0)))) + )))) + )) + +;;; Lexical Safety +;; +;; The semantic lexers, unlike other lexers, can throw errors on +;; unbalanced syntax. Since editing is all about changeging test +;; we need to provide a convenient way to protect against syntactic +;; inequalities. + +(defmacro semantic-lex-catch-errors (symbol &rest forms) + "Using SYMBOL, execute FORMS catching lexical errors. +If FORMS results in a call to the parser that throws a lexical error, +the error will be caught here without the buffer's cache being thrown +out of date. +If there is an error, the syntax that failed is returned. +If there is no error, then the last value of FORMS is returned." + (let ((ret (make-symbol "ret")) + (syntax (make-symbol "syntax")) + (start (make-symbol "start")) + (end (make-symbol "end"))) + `(let* ((semantic-lex-unterminated-syntax-end-function + (lambda (,syntax ,start ,end) + (throw ',symbol ,syntax))) + ;; Delete the below when semantic-flex is fully retired. + (semantic-flex-unterminated-syntax-end-function + semantic-lex-unterminated-syntax-end-function) + (,ret (catch ',symbol + (save-excursion + ,@forms + nil)))) + ;; Great Sadness. Assume that FORMS execute within the + ;; confines of the current buffer only! Mark this thing + ;; unparseable iff the special symbol was thrown. This + ;; will prevent future calls from parsing, but will allow + ;; then to still return the cache. + (when ,ret + ;; Leave this message off. If an APP using this fcn wants + ;; a message, they can do it themselves. This cleans up + ;; problems with the idle scheduler obscuring useful data. + ;;(message "Buffer not currently parsable (%S)." ,ret) + (semantic-parse-tree-unparseable)) + ,ret))) +(put 'semantic-lex-catch-errors 'lisp-indent-function 1) + + +;;; Interfacing with edebug +;; +(add-hook + 'edebug-setup-hook + #'(lambda () + + (def-edebug-spec define-lex + (&define name stringp (&rest symbolp)) + ) + (def-edebug-spec define-lex-analyzer + (&define name stringp form def-body) + ) + (def-edebug-spec define-lex-regex-analyzer + (&define name stringp form def-body) + ) + (def-edebug-spec define-lex-simple-regex-analyzer + (&define name stringp form symbolp [ &optional form ] def-body) + ) + (def-edebug-spec define-lex-block-analyzer + (&define name stringp form (&rest form)) + ) + (def-edebug-spec semantic-lex-catch-errors + (symbolp def-body) + ) + + )) + +;;; Compatibility with Semantic 1.x lexical analysis +;; +;; NOTE: DELETE THIS SOMEDAY SOON + +(semantic-alias-obsolete 'semantic-flex-start 'semantic-lex-token-start) +(semantic-alias-obsolete 'semantic-flex-end 'semantic-lex-token-end) +(semantic-alias-obsolete 'semantic-flex-text 'semantic-lex-token-text) +(semantic-alias-obsolete 'semantic-flex-make-keyword-table 'semantic-lex-make-keyword-table) +(semantic-alias-obsolete 'semantic-flex-keyword-p 'semantic-lex-keyword-p) +(semantic-alias-obsolete 'semantic-flex-keyword-put 'semantic-lex-keyword-put) +(semantic-alias-obsolete 'semantic-flex-keyword-get 'semantic-lex-keyword-get) +(semantic-alias-obsolete 'semantic-flex-map-keywords 'semantic-lex-map-keywords) +(semantic-alias-obsolete 'semantic-flex-keywords 'semantic-lex-keywords) +(semantic-alias-obsolete 'semantic-flex-buffer 'semantic-lex-buffer) +(semantic-alias-obsolete 'semantic-flex-list 'semantic-lex-list) + +;; This simple scanner uses the syntax table to generate a stream of +;; simple tokens of the form: +;; +;; (SYMBOL START . END) +;; +;; Where symbol is the type of thing it is. START and END mark that +;; objects boundary. + +(defvar semantic-flex-tokens semantic-lex-tokens + "An alist of of semantic token types. +See variable `semantic-lex-tokens'.") + +(defvar semantic-flex-unterminated-syntax-end-function + (lambda (syntax syntax-start flex-end) flex-end) + "Function called when unterminated syntax is encountered. +This should be set to one function. That function should take three +parameters. The SYNTAX, or type of syntax which is unterminated. +SYNTAX-START where the broken syntax begins. +FLEX-END is where the lexical analysis was asked to end. +This function can be used for languages that can intelligently fix up +broken syntax, or the exit lexical analysis via `throw' or `signal' +when finding unterminated syntax.") + +(defvar semantic-flex-extensions nil + "Buffer local extensions to the lexical analyzer. +This should contain an alist with a key of a regex and a data element of +a function. The function should both move point, and return a lexical +token of the form: + ( TYPE START . END) +nil is also a valid return value. +TYPE can be any type of symbol, as long as it doesn't occur as a +nonterminal in the language definition.") +(make-variable-buffer-local 'semantic-flex-extensions) + +(defvar semantic-flex-syntax-modifications nil + "Changes to the syntax table for this buffer. +These changes are active only while the buffer is being flexed. +This is a list where each element has the form: + (CHAR CLASS) +CHAR is the char passed to `modify-syntax-entry', +and CLASS is the string also passed to `modify-syntax-entry' to define +what syntax class CHAR has.") +(make-variable-buffer-local 'semantic-flex-syntax-modifications) + +(defvar semantic-ignore-comments t + "Default comment handling. +t means to strip comments when flexing. Nil means to keep comments +as part of the token stream.") +(make-variable-buffer-local 'semantic-ignore-comments) + +(defvar semantic-flex-enable-newlines nil + "When flexing, report 'newlines as syntactic elements. +Useful for languages where the newline is a special case terminator. +Only set this on a per mode basis, not globally.") +(make-variable-buffer-local 'semantic-flex-enable-newlines) + +(defvar semantic-flex-enable-whitespace nil + "When flexing, report 'whitespace as syntactic elements. +Useful for languages where the syntax is whitespace dependent. +Only set this on a per mode basis, not globally.") +(make-variable-buffer-local 'semantic-flex-enable-whitespace) + +(defvar semantic-flex-enable-bol nil + "When flexing, report beginning of lines as syntactic elements. +Useful for languages like python which are indentation sensitive. +Only set this on a per mode basis, not globally.") +(make-variable-buffer-local 'semantic-flex-enable-bol) + +(defvar semantic-number-expression semantic-lex-number-expression + "See variable `semantic-lex-number-expression'.") +(make-variable-buffer-local 'semantic-number-expression) + +(defvar semantic-flex-depth 0 + "Default flexing depth. +This specifies how many lists to create tokens in.") +(make-variable-buffer-local 'semantic-flex-depth) + +(defun semantic-flex (start end &optional depth length) + "Using the syntax table, do something roughly equivalent to flex. +Semantically check between START and END. Optional argument DEPTH +indicates at what level to scan over entire lists. +The return value is a token stream. Each element is a list, such of +the form (symbol start-expression . end-expression) where SYMBOL +denotes the token type. +See `semantic-flex-tokens' variable for details on token types. +END does not mark the end of the text scanned, only the end of the +beginning of text scanned. Thus, if a string extends past END, the +end of the return token will be larger than END. To truly restrict +scanning, use `narrow-to-region'. +The last argument, LENGTH specifies that `semantic-flex' should only +return LENGTH tokens." + (message "`semantic-flex' is an obsolete function. Use `define-lex' to create lexers.") + (if (not semantic-flex-keywords-obarray) + (setq semantic-flex-keywords-obarray [ nil ])) + (let ((ts nil) + (pos (point)) + (ep nil) + (curdepth 0) + (cs (if comment-start-skip + (concat "\\(\\s<\\|" comment-start-skip "\\)") + (concat "\\(\\s<\\)"))) + (newsyntax (copy-syntax-table (syntax-table))) + (mods semantic-flex-syntax-modifications) + ;; Use the default depth if it is not specified. + (depth (or depth semantic-flex-depth))) + ;; Update the syntax table + (while mods + (modify-syntax-entry (car (car mods)) (car (cdr (car mods))) newsyntax) + (setq mods (cdr mods))) + (with-syntax-table newsyntax + (goto-char start) + (while (and (< (point) end) (or (not length) (<= (length ts) length))) + (cond + ;; catch beginning of lines when needed. + ;; Must be done before catching any other tokens! + ((and semantic-flex-enable-bol + (bolp) + ;; Just insert a (bol N . N) token in the token stream, + ;; without moving the point. N is the point at the + ;; beginning of line. + (setq ts (cons (cons 'bol (cons (point) (point))) ts)) + nil)) ;; CONTINUE + ;; special extensions, includes whitespace, nl, etc. + ((and semantic-flex-extensions + (let ((fe semantic-flex-extensions) + (r nil)) + (while fe + (if (looking-at (car (car fe))) + (setq ts (cons (funcall (cdr (car fe))) ts) + r t + fe nil + ep (point))) + (setq fe (cdr fe))) + (if (and r (not (car ts))) (setq ts (cdr ts))) + r))) + ;; catch newlines when needed + ((looking-at "\\s-*\\(\n\\|\\s>\\)") + (if semantic-flex-enable-newlines + (setq ep (match-end 1) + ts (cons (cons 'newline + (cons (match-beginning 1) ep)) + ts)))) + ;; catch whitespace when needed + ((looking-at "\\s-+") + (if semantic-flex-enable-whitespace + ;; Language wants whitespaces, link them together. + (if (eq (car (car ts)) 'whitespace) + (setcdr (cdr (car ts)) (match-end 0)) + (setq ts (cons (cons 'whitespace + (cons (match-beginning 0) + (match-end 0))) + ts))))) + ;; numbers + ((and semantic-number-expression + (looking-at semantic-number-expression)) + (setq ts (cons (cons 'number + (cons (match-beginning 0) + (match-end 0))) + ts))) + ;; symbols + ((looking-at "\\(\\sw\\|\\s_\\)+") + (setq ts (cons (cons + ;; Get info on if this is a keyword or not + (or (semantic-lex-keyword-p (match-string 0)) + 'symbol) + (cons (match-beginning 0) (match-end 0))) + ts))) + ;; Character quoting characters (ie, \n as newline) + ((looking-at "\\s\\+") + (setq ts (cons (cons 'charquote + (cons (match-beginning 0) (match-end 0))) + ts))) + ;; Open parens, or semantic-lists. + ((looking-at "\\s(") + (if (or (not depth) (< curdepth depth)) + (progn + (setq curdepth (1+ curdepth)) + (setq ts (cons (cons 'open-paren + (cons (match-beginning 0) (match-end 0))) + ts))) + (setq ts (cons + (cons 'semantic-list + (cons (match-beginning 0) + (save-excursion + (condition-case nil + (forward-list 1) + ;; This case makes flex robust + ;; to broken lists. + (error + (goto-char + (funcall + semantic-flex-unterminated-syntax-end-function + 'semantic-list + start end)))) + (setq ep (point))))) + ts)))) + ;; Close parens + ((looking-at "\\s)") + (setq ts (cons (cons 'close-paren + (cons (match-beginning 0) (match-end 0))) + ts)) + (setq curdepth (1- curdepth))) + ;; String initiators + ((looking-at "\\s\"") + ;; Zing to the end of this string. + (setq ts (cons (cons 'string + (cons (match-beginning 0) + (save-excursion + (condition-case nil + (forward-sexp 1) + ;; This case makes flex + ;; robust to broken strings. + (error + (goto-char + (funcall + semantic-flex-unterminated-syntax-end-function + 'string + start end)))) + (setq ep (point))))) + ts))) + ;; comments + ((looking-at cs) + (if (and semantic-ignore-comments + (not semantic-flex-enable-whitespace)) + ;; If the language doesn't deal with comments nor + ;; whitespaces, ignore them here. + (let ((comment-start-point (point))) + (forward-comment 1) + (if (eq (point) comment-start-point) + ;; In this case our start-skip string failed + ;; to work properly. Lets try and move over + ;; whatever white space we matched to begin + ;; with. + (skip-syntax-forward "-.'" + (save-excursion + (end-of-line) + (point))) + ;;(forward-comment 1) + ;; Generate newline token if enabled + (if (and semantic-flex-enable-newlines + (bolp)) + (backward-char 1))) + (if (eq (point) comment-start-point) + (error "Strange comment syntax prevents lexical analysis")) + (setq ep (point))) + (let ((tk (if semantic-ignore-comments 'whitespace 'comment))) + (save-excursion + (forward-comment 1) + ;; Generate newline token if enabled + (if (and semantic-flex-enable-newlines + (bolp)) + (backward-char 1)) + (setq ep (point))) + ;; Language wants comments or want them as whitespaces, + ;; link them together. + (if (eq (car (car ts)) tk) + (setcdr (cdr (car ts)) ep) + (setq ts (cons (cons tk (cons (match-beginning 0) ep)) + ts)))))) + ;; punctuation + ((looking-at "\\(\\s.\\|\\s$\\|\\s'\\)") + (setq ts (cons (cons 'punctuation + (cons (match-beginning 0) (match-end 0))) + ts))) + ;; unknown token + (t + (error "What is that?"))) + (goto-char (or ep (match-end 0))) + (setq ep nil))) + ;; maybe catch the last beginning of line when needed + (and semantic-flex-enable-bol + (= (point) end) + (bolp) + (setq ts (cons (cons 'bol (cons (point) (point))) ts))) + (goto-char pos) + ;;(message "Flexing muscles...done") + (nreverse ts))) + +(provide 'semantic/lex) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/lex" +;; End: + +;;; semantic/lex.el ends here diff --git a/lisp/cedet/semantic/mru-bookmark.el b/lisp/cedet/semantic/mru-bookmark.el new file mode 100644 index 00000000000..66da681e3b4 --- /dev/null +++ b/lisp/cedet/semantic/mru-bookmark.el @@ -0,0 +1,435 @@ +;;; semantic/mru-bookmark.el --- Automatic bookmark tracking + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Using editing hooks, track the most recently visited or poked tags, +;; and keep a list of them, with the current point in from, and sorted +;; by most recently used. +;; +;; I envision this would be used in place of switch-buffers once +;; someone got the hang of it. +;; +;; I'd also like to see this used to provide some nice defaults for +;; other programs where logical destinations or targets are the tags +;; that have been recently edited. +;; +;; Quick Start: +;; +;; M-x global-semantic-mru-bookmark-mode RET +;; +;; < edit some code > +;; +;; C-x B <select a tag name> RET +;; +;; In the above, the history is pre-filled with the tags you recenetly +;; edited in the order you edited them. + +;;; Code: + +(require 'semantic) +(require 'eieio-base) +(require 'ring) + +(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") + +;;; TRACKING CORE +;; +;; Data structure for tracking MRU tag locations + +(defclass semantic-bookmark (eieio-named) + ((tag :initarg :tag + :type semantic-tag + :documentation "The TAG this bookmark belongs to.") + (parent :type (or semantic-tag null) + :documentation "The tag that is the parent of :tag.") + (offset :type number + :documentation "The offset from `tag' start that is +somehow interesting.") + (filename :type string + :documentation "String the tag belongs to. +Set this when the tag gets unlinked from the buffer it belongs to.") + (frequency :type number + :initform 0 + :documentation "Track the frequency this tag is visited.") + (reason :type symbol + :initform t + :documentation + "The reason this tag is interesting. +Nice values are 'edit, 'read, 'jump, and 'mark. + edit - created because the tag text was edited. + read - created because point lingered in tag text. + jump - jumped to another tag from this tag. + mark - created a regular mark in this tag.") + ) + "A single bookmark.") + +(defmethod initialize-instance :AFTER ((sbm semantic-bookmark) &rest fields) + "Initialize the bookmark SBM with details about :tag." + (condition-case nil + (save-excursion + (oset sbm filename (semantic-tag-file-name (oref sbm tag))) + (semantic-go-to-tag (oref sbm tag)) + (oset sbm parent (semantic-current-tag-parent))) + (error (message "Error bookmarking tag."))) + ) + +(defmethod semantic-mrub-visit ((sbm semantic-bookmark)) + "Visit the semantic tag bookmark SBM. +Uses `semantic-go-to-tag' and highlighting." + (require 'semantic/decorate) + (with-slots (tag filename) sbm + ;; Go to the tag + (when (not (semantic-tag-in-buffer-p tag)) + (let ((fn (or (semantic-tag-file-name tag) + filename))) + (set-buffer (find-file-noselect fn)))) + (semantic-go-to-tag (oref sbm tag) (oref sbm parent)) + ;; Go back to the offset. + (condition-case nil + (let ((o (oref sbm offset))) + (forward-char o)) + (error nil)) + ;; make it visible + (switch-to-buffer (current-buffer)) + (semantic-momentary-highlight-tag tag) + )) + +(defmethod semantic-mrub-update ((sbm semantic-bookmark) point reason) + "Update the existing bookmark SBM. +POINT is some important location. +REASON is a symbol. See slot `reason' on `semantic-bookmark'." + (condition-case nil + (progn + (with-slots (tag offset frequency) sbm + (setq offset (- point (semantic-tag-start tag))) + (setq frequency (1+ frequency)) + ) + (oset sbm reason reason)) + ;; This can fail on XEmacs at miscelaneous times. + (error nil)) + ) + +(defmethod semantic-mrub-preflush ((sbm semantic-bookmark)) + "Method called on a tag before the current buffer list of tags is flushed. +If there is a buffer match, unlink the tag." + (let ((tag (oref sbm tag)) + (parent (when (slot-boundp sbm 'parent) + (oref sbm parent)))) + (let ((b (semantic-tag-in-buffer-p tag))) + (when (and b (eq b (current-buffer))) + (semantic--tag-unlink-from-buffer tag))) + + (when parent + (let ((b (semantic-tag-in-buffer-p parent))) + (when (and b (eq b (current-buffer))) + (semantic--tag-unlink-from-buffer parent)))))) + +(defclass semantic-bookmark-ring () + ((ring :initarg :ring + :type ring + :documentation + "List of `semantic-bookmark' objects. +This list is maintained as a list with the first item +being the current location, and the rest being a list of +items that were recently visited.") + (current-index :initform 0 + :type number + :documentation + "The current index into RING for some operation. +User commands use this to move through the ring, or reset.") + ) + "Track the current MRU stack of bookmarks. +We can't use the built-in ring data structure because we need +to delete some items from the ring when we don't have the data.") + +(defvar semantic-mru-bookmark-ring (semantic-bookmark-ring + "Ring" + :ring (make-ring 20)) + "The MRU bookmark ring. +This ring tracks the most recent active tags of interest.") + +(defun semantic-mrub-find-nearby-tag (point) + "Find a nearby tag to be pushed for this current location. +Argument POINT is where to find the tag near." + ;; I thought this was a good idea, but it is not! + ;;(semantic-fetch-tags) ;; Make sure everything is up-to-date. + (let ((tag (semantic-current-tag))) + (when (or (not tag) (semantic-tag-of-class-p tag 'type)) + (let ((nearby (or (semantic-find-tag-by-overlay-next point) + (semantic-find-tag-by-overlay-prev point)))) + (when nearby (setq tag nearby)))) + tag)) + +(defmethod semantic-mrub-push ((sbr semantic-bookmark-ring) point + &optional reason) + "Add a bookmark to the ring SBR from POINT. +REASON is why it is being pushed. See doc for `semantic-bookmark' +for possible reasons. +The resulting bookmark is then sorted within the ring." + (let* ((ring (oref sbr ring)) + (tag (semantic-mrub-find-nearby-tag (point))) + (idx 0)) + (when tag + (while (and (not (ring-empty-p ring)) (< idx (ring-size ring))) + (if (semantic-tag-similar-p (oref (ring-ref ring idx) tag) + tag) + (ring-remove ring idx)) + (setq idx (1+ idx))) + ;; Create a new mark + (let ((sbm (semantic-bookmark (semantic-tag-name tag) + :tag tag))) + ;; Take the mark, and update it for the current state. + (ring-insert ring sbm) + (semantic-mrub-update sbm point reason)) + ))) + +(defun semantic-mrub-cache-flush-fcn () + "Function called in the `semantic-before-toplevel-cache-flush-hook`. +Cause tags in the ring to become unlinked." + (let* ((ring (oref semantic-mru-bookmark-ring ring)) + (len (ring-length ring)) + (idx 0) + ) + (while (< idx len) + (semantic-mrub-preflush (ring-ref ring idx)) + (setq idx (1+ idx))))) + +(add-hook 'semantic-before-toplevel-cache-flush-hook + 'semantic-mrub-cache-flush-fcn) + +;;; EDIT tracker +;; +(defvar semantic-mrub-last-overlay nil + "The last overlay bumped by `semantic-mru-bookmark-change-hook-fcn'.") + +(defun semantic-mru-bookmark-change-hook-fcn (overlay) + "Function set into `semantic-edits-new/move-change-hook's. +Argument OVERLAY is the overlay created to mark the change. +This function pushes tags onto the tag ring." + ;; Dup? + (when (not (eq overlay semantic-mrub-last-overlay)) + (setq semantic-mrub-last-overlay overlay) + (semantic-mrub-push semantic-mru-bookmark-ring + (point) + 'edit))) + +;;; MINOR MODE +;; +;; Tracking minor mode. + +(defcustom global-semantic-mru-bookmark-mode nil + "*If non-nil enable global use of variable `semantic-mru-bookmark-mode'. +When this mode is enabled, changes made to a buffer are highlighted +until the buffer is reparsed." + :group 'semantic + :group 'semantic-modes + :type 'boolean + :require 'semantic-util-modes + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-semantic-mru-bookmark-mode (if val 1 -1)))) + +;;;###autoload +(defun global-semantic-mru-bookmark-mode (&optional arg) + "Toggle global use of option `semantic-mru-bookmark-mode'. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle." + (interactive "P") + (setq global-semantic-mru-bookmark-mode + (semantic-toggle-minor-mode-globally + 'semantic-mru-bookmark-mode arg))) + +(defcustom semantic-mru-bookmark-mode-hook nil + "*Hook run at the end of function `semantic-mru-bookmark-mode'." + :group 'semantic + :type 'hook) + +(defvar semantic-mru-bookmark-mode-map + (let ((km (make-sparse-keymap))) + (define-key km "\C-xB" 'semantic-mrub-switch-tags) + km) + "Keymap for mru-bookmark minor mode.") + +(defvar semantic-mru-bookmark-mode nil + "Non-nil if mru-bookmark minor mode is enabled. +Use the command `semantic-mru-bookmark-mode' to change this variable.") +(make-variable-buffer-local 'semantic-mru-bookmark-mode) + +(defun semantic-mru-bookmark-mode-setup () + "Setup option `semantic-mru-bookmark-mode'. +The minor mode can be turned on only if semantic feature is available +and the current buffer was set up for parsing. When minor mode is +enabled parse the current buffer if needed. Return non-nil if the +minor mode is enabled." + (if semantic-mru-bookmark-mode + (if (not (and (featurep 'semantic) (semantic-active-p))) + (progn + ;; Disable minor mode if semantic stuff not available + (setq semantic-mru-bookmark-mode nil) + (error "Buffer %s was not set up for parsing" + (buffer-name))) + (semantic-make-local-hook 'semantic-edits-new-change-hooks) + (add-hook 'semantic-edits-new-change-hooks + 'semantic-mru-bookmark-change-hook-fcn nil t) + (add-hook 'semantic-edits-move-change-hooks + 'semantic-mru-bookmark-change-hook-fcn nil t) + ) + ;; Remove hooks + (remove-hook 'semantic-edits-new-change-hooks + 'semantic-mru-bookmark-change-hook-fcn t) + (remove-hook 'semantic-edits-move-change-hooks + 'semantic-mru-bookmark-change-hook-fcn t) + ) + semantic-mru-bookmark-mode) + +(defun semantic-mru-bookmark-mode (&optional arg) + "Minor mode for tracking tag-based bookmarks automatically. +Tag based bookmarks a tracked based on editing and viewing habits +and can then be navigated via the MRU bookmark keymap. + +\\{semantic-mru-bookmark-mode-map} + +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled." + (interactive + (list (or current-prefix-arg + (if semantic-mru-bookmark-mode 0 1)))) + (setq semantic-mru-bookmark-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not semantic-mru-bookmark-mode))) + (semantic-mru-bookmark-mode-setup) + (run-hooks 'semantic-mru-bookmark-mode-hook) + (if (interactive-p) + (message "mru-bookmark minor mode %sabled" + (if semantic-mru-bookmark-mode "en" "dis"))) + (semantic-mode-line-update) + semantic-mru-bookmark-mode) + +(semantic-add-minor-mode 'semantic-mru-bookmark-mode + "k" + semantic-mru-bookmark-mode-map) + +;;; COMPLETING READ +;; +;; Ask the user for a tag in MRU order. +(defun semantic-mrub-read-history nil + "History of `semantic-mrub-completing-read'.") + +(defun semantic-mrub-ring-to-assoc-list (ring) + "Convert RING into an association list for completion." + (let ((idx 0) + (len (ring-length ring)) + (al nil)) + (while (< idx len) + (let ((r (ring-ref ring idx))) + (setq al (cons (cons (oref r :object-name) r) + al))) + (setq idx (1+ idx))) + (nreverse al))) + +(defun semantic-mrub-completing-read (prompt) + "Do a `completing-read' on elements from the mru bookmark ring. +Argument PROMPT is the promot to use when reading." + (if (ring-empty-p (oref semantic-mru-bookmark-ring ring)) + (error "Semantic Bookmark ring is currently empty")) + (let* ((ring (oref semantic-mru-bookmark-ring ring)) + (ans nil) + (alist (semantic-mrub-ring-to-assoc-list ring)) + (first (cdr (car alist))) + (semantic-mrub-read-history nil) + ) + ;; Don't include the current tag.. only those that come after. + (if (semantic-equivalent-tag-p (oref first tag) + (semantic-current-tag)) + (setq first (cdr (car (cdr alist))))) + ;; Create a fake history list so we don't have to bind + ;; M-p and M-n to our special cause. + (let ((elts (reverse alist))) + (while elts + (setq semantic-mrub-read-history + (cons (car (car elts)) semantic-mrub-read-history)) + (setq elts (cdr elts)))) + (setq semantic-mrub-read-history (nreverse semantic-mrub-read-history)) + + ;; Do the read/prompt + (let ((prompt (if first (format "%s (%s): " prompt + (semantic-format-tag-name + (oref first tag) t) + ) + (concat prompt ": "))) + ) + (setq ans + (completing-read prompt alist nil nil nil 'semantic-mrub-read-history))) + ;; Calculate the return tag. + (if (string= ans "") + (setq ans first) + ;; Return the bookmark object. + (setq ans (assoc ans alist)) + (if ans + (cdr ans) + ;; no match. Custom word. Look it up somwhere? + nil) + ))) + +(defun semantic-mrub-switch-tags (tagmark) + "Switch tags to TAGMARK. +Selects a new tag via promt through the mru tag ring. +Jumps to the tag and highlights it briefly." + (interactive (list (semantic-mrub-completing-read "Switch to tag"))) + (if (not (semantic-bookmark-p tagmark)) + (signal 'wrong-type-argument tagmark)) + + (semantic-mrub-push semantic-mru-bookmark-ring + (point) + 'jump) + (semantic-mrub-visit tagmark) + ) + +;;; Debugging +;; +(defun semantic-adebug-mrub () + "Display a list of items in the MRU bookmarks list. +Useful for debugging mrub problems." + (interactive) + (require 'eieio-datadebug) + (let* ((out semantic-mru-bookmark-ring)) + (data-debug-new-buffer "*TAG RING ADEBUG*") + (data-debug-insert-object-slots out "]") + )) + + +(provide 'semantic/mru-bookmark) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/mru-bookmark" +;; End: + +;;; semantic/mru-bookmark.el ends here diff --git a/lisp/cedet/semantic/sb.el b/lisp/cedet/semantic/sb.el new file mode 100644 index 00000000000..3300d09b3b1 --- /dev/null +++ b/lisp/cedet/semantic/sb.el @@ -0,0 +1,420 @@ +;;; semantic/sb.el --- Semantic tag display for speedbar + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;;; 2007, 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Convert a tag table into speedbar buttons. + +;;; TODO: + +;; Use semanticdb to find which semanticdb-table is being used for each +;; file/tag. Replace `semantic-sb-with-tag-buffer' to instead call +;; children with the new `with-mode-local' instead. + +(require 'semantic) +(require 'semantic/format) +(require 'semantic/sort) +(require 'semantic/util) +(require 'speedbar) +(declare-function semanticdb-file-stream "semantic/db") + +(defcustom semantic-sb-autoexpand-length 1 + "*Length of a semantic bucket to autoexpand in place. +This will replace the named bucket that would have usually occured here." + :group 'speedbar + :type 'integer) + +(defcustom semantic-sb-button-format-tag-function 'semantic-format-tag-abbreviate + "*Function called to create the text for a but from a token." + :group 'speedbar + :type semantic-format-tag-custom-list) + +(defcustom semantic-sb-info-format-tag-function 'semantic-format-tag-summarize + "*Function called to create the text for info display from a token." + :group 'speedbar + :type semantic-format-tag-custom-list) + +;;; Code: +;; + +;;; Buffer setting for correct mode manipulation. +(defun semantic-sb-tag-set-buffer (tag) + "Set the current buffer to something associated with TAG. +use the `speedbar-line-file' to get this info if needed." + (if (semantic-tag-buffer tag) + (set-buffer (semantic-tag-buffer tag)) + (let ((f (speedbar-line-file))) + (set-buffer (find-file-noselect f))))) + +(defmacro semantic-sb-with-tag-buffer (tag &rest forms) + "Set the current buffer to the origin of TAG and execute FORMS. +Restore the old current buffer when completed." + `(save-excursion + (semantic-sb-tag-set-buffer ,tag) + ,@forms)) +(put 'semantic-sb-with-tag-buffer 'lisp-indent-function 1) + +;;; Button Generation +;; +;; Here are some button groups: +;; +;; +> Function () +;; @ return_type +;; +( arg1 +;; +| arg2 +;; +) arg3 +;; +;; +> Variable[1] = +;; @ type +;; = default value +;; +;; +> keywrd Type +;; +> type part +;; +;; +> -> click to see additional information + +(define-overloadable-function semantic-sb-tag-children-to-expand (tag) + "For TAG, return a list of children that TAG expands to. +If this returns a value, then a +> icon is created. +If it returns nil, then a => icon is created.") + +(defun semantic-sb-tag-children-to-expand-default (tag) + "For TAG, the children for type, variable, and function classes." + (semantic-sb-with-tag-buffer tag + (semantic-tag-components tag))) + +(defun semantic-sb-one-button (tag depth &optional prefix) + "Insert TAG as a speedbar button at DEPTH. +Optional PREFIX is used to specify special marker characters." + (let* ((class (semantic-tag-class tag)) + (edata (semantic-sb-tag-children-to-expand tag)) + (type (semantic-tag-type tag)) + (abbrev (semantic-sb-with-tag-buffer tag + (funcall semantic-sb-button-format-tag-function tag))) + (start (point)) + (end (progn + (insert (int-to-string depth) ":") + (point)))) + (insert-char ? (1- depth) nil) + (put-text-property end (point) 'invisible nil) + ;; take care of edata = (nil) -- a yucky but hard to clean case + (if (and edata (listp edata) (and (<= (length edata) 1) (not (car edata)))) + (setq edata nil)) + (if (and (not edata) + (member class '(variable function)) + type) + (setq edata t)) + ;; types are a bit unique. Variable types can have special meaning. + (if edata + (speedbar-insert-button (if prefix (concat " +" prefix) " +>") + 'speedbar-button-face + 'speedbar-highlight-face + 'semantic-sb-show-extra + tag t) + (speedbar-insert-button (if prefix (concat " " prefix) " =>") + nil nil nil nil t)) + (speedbar-insert-button abbrev + 'speedbar-tag-face + 'speedbar-highlight-face + 'semantic-sb-token-jump + tag t) + ;; This is very bizarre. When this was just after the insertion + ;; of the depth: text, the : would get erased, but only for the + ;; auto-expanded short- buckets. Move back for a later version + ;; version of Emacs 21 CVS + (put-text-property start end 'invisible t) + )) + +(defun semantic-sb-speedbar-data-line (depth button text &optional + text-fun text-data) + "Insert a semantic token data element. +DEPTH is the current depth. BUTTON is the text for the button. +TEXT is the actual info with TEXT-FUN to occur when it happens. +Argument TEXT-DATA is the token data to pass to TEXT-FUN." + (let ((start (point)) + (end (progn + (insert (int-to-string depth) ":") + (point)))) + (put-text-property start end 'invisible t) + (insert-char ? depth nil) + (put-text-property end (point) 'invisible nil) + (speedbar-insert-button button nil nil nil nil t) + (speedbar-insert-button text + 'speedbar-tag-face + (if text-fun 'speedbar-highlight-face) + text-fun text-data t) + )) + +(defun semantic-sb-maybe-token-to-button (obj indent &optional + prefix modifiers) + "Convert OBJ, which was returned from the semantic parser, into a button. +This OBJ might be a plain string (simple type or untyped variable) +or a complete tag. +Argument INDENT is the indentation used when making the button. +Optional PREFIX is the character to use when marking the line. +Optional MODIFIERS is additional text needed for variables." + (let ((myprefix (or prefix ">"))) + (if (stringp obj) + (semantic-sb-speedbar-data-line indent myprefix obj) + (if (listp obj) + (progn + (if (and (stringp (car obj)) + (= (length obj) 1)) + (semantic-sb-speedbar-data-line indent myprefix + (concat + (car obj) + (or modifiers ""))) + (semantic-sb-one-button obj indent prefix))))))) + +(defun semantic-sb-insert-details (tag indent) + "Insert details about TAG at level INDENT." + (let ((tt (semantic-tag-class tag)) + (type (semantic-tag-type tag))) + (cond ((eq tt 'type) + (let ((parts (semantic-tag-type-members tag)) + (newparts nil)) + ;; Lets expect PARTS to be a list of either strings, + ;; or variable tokens. + (when (semantic-tag-p (car parts)) + ;; Bucketize into groups + (semantic-sb-with-tag-buffer (car parts) + (setq newparts (semantic-bucketize parts))) + (when (> (length newparts) semantic-sb-autoexpand-length) + ;; More than one bucket, insert inline + (semantic-sb-insert-tag-table (1- indent) newparts) + (setq parts nil)) + ;; Dump the strings in. + (while parts + (semantic-sb-maybe-token-to-button (car parts) indent) + (setq parts (cdr parts)))))) + ((eq tt 'variable) + (if type + (semantic-sb-maybe-token-to-button type indent "@")) + (let ((default (semantic-tag-variable-default tag))) + (if default + (semantic-sb-maybe-token-to-button default indent "="))) + ) + ((eq tt 'function) + (if type + (semantic-sb-speedbar-data-line + indent "@" + (if (stringp type) type + (semantic-tag-name type)))) + ;; Arguments to the function + (let ((args (semantic-tag-function-arguments tag))) + (if (and args (car args)) + (progn + (semantic-sb-maybe-token-to-button (car args) indent "(") + (setq args (cdr args)) + (while (> (length args) 1) + (semantic-sb-maybe-token-to-button (car args) + indent + "|") + (setq args (cdr args))) + (if args + (semantic-sb-maybe-token-to-button + (car args) indent ")")) + )))) + (t + (let ((components + (save-excursion + (when (and (semantic-tag-overlay tag) + (semantic-tag-buffer tag)) + (set-buffer (semantic-tag-buffer tag))) + (semantic-sb-tag-children-to-expand tag)))) + ;; Well, it wasn't one of the many things we expect. + ;; Lets just insert them in with no decoration. + (while components + (semantic-sb-one-button (car components) indent) + (setq components (cdr components))) + )) + ) + )) + +(defun semantic-sb-detail-parent () + "Return the first parent token of the current line that includes a location." + (save-excursion + (beginning-of-line) + (let ((dep (if (looking-at "[0-9]+:") + (1- (string-to-number (match-string 0))) + 0))) + (re-search-backward (concat "^" + (int-to-string dep) + ":") + nil t)) + (beginning-of-line) + (if (looking-at "[0-9]+: +[-+][>()@|] \\([^\n]+\\)$") + (let ((prop nil)) + (goto-char (match-beginning 1)) + (setq prop (get-text-property (point) 'speedbar-token)) + (if (semantic-tag-with-position-p prop) + prop + (semantic-sb-detail-parent))) + nil))) + +(defun semantic-sb-show-extra (text token indent) + "Display additional information about the token as an expansion. +TEXT TOKEN and INDENT are the details." + (cond ((string-match "+" text) ;we have to expand this file + (speedbar-change-expand-button-char ?-) + (speedbar-with-writable + (save-excursion + (end-of-line) (forward-char 1) + (save-restriction + (narrow-to-region (point) (point)) + ;; Add in stuff specific to this type of token. + (semantic-sb-insert-details token (1+ indent)))))) + ((string-match "-" text) ;we have to contract this node + (speedbar-change-expand-button-char ?+) + (speedbar-delete-subblock indent)) + (t (error "Ooops... not sure what to do"))) + (speedbar-center-buffer-smartly)) + +(defun semantic-sb-token-jump (text token indent) + "Jump to the location specified in token. +TEXT TOKEN and INDENT are the details." + (let ((file + (or + (cond ((fboundp 'speedbar-line-path) + (speedbar-line-directory indent)) + ((fboundp 'speedbar-line-directory) + (speedbar-line-directory indent))) + ;; If speedbar cannot figure this out, extract the filename from + ;; the token. True for Analysis mode. + (semantic-tag-file-name token))) + (parent (semantic-sb-detail-parent))) + (let ((f (selected-frame))) + (dframe-select-attached-frame speedbar-frame) + (run-hooks 'speedbar-before-visiting-tag-hook) + (select-frame f)) + ;; Sometimes FILE may be nil here. If you are debugging a problem + ;; when this happens, go back and figure out why FILE is nil and try + ;; and fix the source. + (speedbar-find-file-in-frame file) + (save-excursion (speedbar-stealthy-updates)) + (semantic-go-to-tag token parent) + (switch-to-buffer (current-buffer)) + ;; Reset the timer with a new timeout when cliking a file + ;; in case the user was navigating directories, we can cancel + ;; that other timer. + ;; (speedbar-set-timer dframe-update-speed) + ;;(recenter) + (speedbar-maybee-jump-to-attached-frame) + (run-hooks 'speedbar-visiting-tag-hook))) + +(defun semantic-sb-expand-group (text token indent) + "Expand a group which has semantic tokens. +TEXT TOKEN and INDENT are the details." + (cond ((string-match "+" text) ;we have to expand this file + (speedbar-change-expand-button-char ?-) + (speedbar-with-writable + (save-excursion + (end-of-line) (forward-char 1) + (save-restriction + (narrow-to-region (point-min) (point)) + (semantic-sb-buttons-plain (1+ indent) token))))) + ((string-match "-" text) ;we have to contract this node + (speedbar-change-expand-button-char ?+) + (speedbar-delete-subblock indent)) + (t (error "Ooops... not sure what to do"))) + (speedbar-center-buffer-smartly)) + +(defun semantic-sb-buttons-plain (level tokens) + "Create buttons at LEVEL using TOKENS." + (let ((sordid (speedbar-create-tag-hierarchy tokens))) + (while sordid + (cond ((null (car-safe sordid)) nil) + ((consp (car-safe (cdr-safe (car-safe sordid)))) + ;; A group! + (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group + (cdr (car sordid)) + (car (car sordid)) + nil nil 'speedbar-tag-face + level)) + (t ;; Assume that this is a token. + (semantic-sb-one-button (car sordid) level))) + (setq sordid (cdr sordid))))) + +(defun semantic-sb-insert-tag-table (level table) + "At LEVEL, insert the tag table TABLE. +Use arcane knowledge about the semantic tokens in the tagged elements +to create much wiser decisions about how to sort and group these items." + (semantic-sb-buttons level table)) + +(defun semantic-sb-buttons (level lst) + "Create buttons at LEVEL using LST sorting into type buckets." + (save-restriction + (narrow-to-region (point-min) (point)) + (let (tmp) + (while lst + (setq tmp (car lst)) + (if (cdr tmp) + (if (<= (length (cdr tmp)) semantic-sb-autoexpand-length) + (semantic-sb-buttons-plain (1+ level) (cdr tmp)) + (speedbar-make-tag-line 'curly ?+ 'semantic-sb-expand-group + (cdr tmp) + (car (car lst)) + nil nil 'speedbar-tag-face + (1+ level)))) + (setq lst (cdr lst)))))) + +(defun semantic-sb-fetch-tag-table (file) + "Load FILE into a buffer, and generate tags using the Semantic parser. +Returns the tag list, or t for an error." + (let ((out nil)) + (if (and (featurep 'semantic/db) + (semanticdb-minor-mode-p) + (not speedbar-power-click) + ;; If the database is loaded and running, try to get + ;; tokens from it. + (setq out (semanticdb-file-stream file))) + ;; Successful DB query. + nil + ;; No database, do it the old way. + (save-excursion + (set-buffer (find-file-noselect file)) + (if (or (not (featurep 'semantic)) + (not semantic--parse-table)) + (setq out t) + (if speedbar-power-click (semantic-clear-toplevel-cache)) + (setq out (semantic-fetch-tags))))) + (if (listp out) + (condition-case nil + (progn + ;; This brings externally defind methods into + ;; their classes, and creates meta classes for + ;; orphans. + (setq out (semantic-adopt-external-members out)) + ;; Dump all the tokens into buckets. + (semantic-sb-with-tag-buffer (car out) + (semantic-bucketize out))) + (error t)) + t))) + +;; Link ourselves into the tagging process. +(add-to-list 'speedbar-dynamic-tags-function-list + '(semantic-sb-fetch-tag-table . semantic-sb-insert-tag-table)) + +(provide 'semantic/sb) + +;;; semantic/sb.el ends here diff --git a/lisp/cedet/semantic/scope.el b/lisp/cedet/semantic/scope.el new file mode 100644 index 00000000000..30b394d4a07 --- /dev/null +++ b/lisp/cedet/semantic/scope.el @@ -0,0 +1,816 @@ +;;; semantic/scope.el --- Analyzer Scope Calculations + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Calculate information about the current scope. +;; +;; Manages the current scope as a structure that can be cached on a +;; per-file basis and recycled between different occurances of +;; analysis on different parts of a file. +;; +;; Pattern for Scope Calculation +;; +;; Step 1: Calculate DataTypes in Scope: +;; +;; a) What is in scope via using statements or local namespaces +;; b) Lineage of current context. Some names drawn from step 1. +;; +;; Step 2: Convert type names into lists of concrete tags +;; +;; a) Convert each datatype into the real datatype tag +;; b) Convert namespaces into the list of contents of the namespace. +;; c) Merge all existing scopes together into one search list. +;; +;; Step 3: Local variables +;; +;; a) Local variables are in the master search list. +;; + +(require 'semantic/db) +(require 'semantic/analyze/fcn) +(require 'semantic/ctxt) + +(eval-when-compile (require 'semantic/find)) + +(declare-function data-debug-show "eieio-datadebug") +(declare-function semantic-analyze-find-tag "semantic/analyze") +(declare-function semantic-analyze-princ-sequence "semantic/analyze") +(declare-function semanticdb-typecache-merge-streams "semantic/db-typecache") +(declare-function semanticdb-typecache-add-dependant "semantic/db-typecache") + +;;; Code: + +(defclass semantic-scope-cache (semanticdb-abstract-cache) + ((tag :initform nil + :documentation + "The tag this scope was calculated for.") + (scopetypes :initform nil + :documentation + "The list of types currently in scope. +For C++, this would contain anonymous namespaces known, and +anything labled by a `using' statement.") + (parents :initform nil + :documentation + "List of parents in scope w/in the body of this function. +Presumably, the members of these parent classes are available for access +based on private:, or public: style statements.") + (parentinheritance :initform nil + :documentation "Alist of parents by inheritance. +Each entry is ( PARENT . PROTECTION ), where PARENT is a type, and +PROTECTION is a symbol representing the level of inheritance, such as 'private, or 'protected.") + (scope :initform nil + :documentation + "Items in scope due to the scopetypes or parents.") + (fullscope :initform nil + :documentation + "All the other stuff on one master list you can search.") + (localargs :initform nil + :documentation + "The arguments to the function tag.") + (localvar :initform nil + :documentation + "The local variables.") + (typescope :initform nil + :documentation + "Slot to save intermediate scope while metatypes are dereferenced.") + ) + "Cache used for storage of the current scope by the Semantic Analyzer. +Saves scoping information between runs of the analyzer.") + +;;; METHODS +;; +;; Methods for basic management of the structure in semanticdb. +;; +(defmethod semantic-reset ((obj semantic-scope-cache)) + "Reset OBJ back to it's empty settings." + (oset obj tag nil) + (oset obj scopetypes nil) + (oset obj parents nil) + (oset obj parentinheritance nil) + (oset obj scope nil) + (oset obj fullscope nil) + (oset obj localargs nil) + (oset obj localvar nil) + (oset obj typescope nil) + ) + +(defmethod semanticdb-synchronize ((cache semantic-scope-cache) + new-tags) + "Synchronize a CACHE with some NEW-TAGS." + (semantic-reset cache)) + + +(defmethod semanticdb-partial-synchronize ((cache semantic-scope-cache) + new-tags) + "Synchronize a CACHE with some changed NEW-TAGS." + ;; If there are any includes or datatypes changed, then clear. + (if (or (semantic-find-tags-by-class 'include new-tags) + (semantic-find-tags-by-class 'type new-tags) + (semantic-find-tags-by-class 'using new-tags)) + (semantic-reset cache)) + ) + +(defun semantic-scope-reset-cache () + "Get the current cached scope, and reset it." + (when semanticdb-current-table + (let ((co (semanticdb-cache-get semanticdb-current-table + semantic-scope-cache))) + (semantic-reset co)))) + +(defmethod semantic-scope-set-typecache ((cache semantic-scope-cache) + types-in-scope) + "Set the :typescope property on CACHE to some types. +TYPES-IN-SCOPE is a list of type tags whos members are +currently in scope. For each type in TYPES-IN-SCOPE, +add those members to the types list. +If nil, then the typescope is reset." + (let ((newts nil)) ;; New Type Scope + (dolist (onetype types-in-scope) + (setq newts (append (semantic-tag-type-members onetype) + newts)) + ) + (oset cache typescope newts))) + +;;; TAG SCOPES +;; +;; These fcns should be used by search routines that return a single +;; tag which, in turn, may have come from a deep scope. The scope +;; will be attached to the tag. Thus, in future scope based calls, a +;; tag can be passed in and a scope derived from it. + +(defun semantic-scope-tag-clone-with-scope (tag scopetags) + "Close TAG, and return it. Add SCOPETAGS as a tag-local scope. +Stores the SCOPETAGS as a set of tag properties on the cloned tag." + (let ((clone (semantic-tag-clone tag)) + ) + (semantic--tag-put-property clone 'scope scopetags) + )) + +(defun semantic-scope-tag-get-scope (tag) + "Get from TAG the list of tags comprising the scope from TAG." + (semantic--tag-get-property tag 'scope)) + +;;; SCOPE UTILITIES +;; +;; Functions that do the main scope calculations + + +(define-overloadable-function semantic-analyze-scoped-types (position) + "Return a list of types currently in scope at POSITION. +This is based on what tags exist at POSITION, and any associated +types available.") + +(defun semantic-analyze-scoped-types-default (position) + "Return a list of types currently in scope at POSITION. +Use `semantic-ctxt-scoped-types' to find types." + (require 'semantic/db-typecache) + (save-excursion + (goto-char position) + (let ((code-scoped-types nil)) + ;; Lets ask if any types are currently scoped. Scoped + ;; classes and types provide their public methods and types + ;; in source code, but are unrelated hierarchically. + (let ((sp (semantic-ctxt-scoped-types))) + (while sp + ;; Get this thing as a tag + (let ((tmp (cond + ((stringp (car sp)) + (semanticdb-typecache-find (car sp))) + ;(semantic-analyze-find-tag (car sp) 'type)) + ((semantic-tag-p (car sp)) + (if (semantic-analyze-tag-prototype-p (car sp)) + (semanticdb-typecache-find (semantic-tag-name (car sp))) + ;;(semantic-analyze-find-tag (semantic-tag-name (car sp)) 'type) + (car sp))) + (t nil)))) + (when tmp + (setq code-scoped-types + (cons tmp code-scoped-types)))) + (setq sp (cdr sp)))) + (setq code-scoped-types (nreverse code-scoped-types)) + + (when code-scoped-types + (semanticdb-typecache-merge-streams code-scoped-types nil)) + + ))) + +;;------------------------------------------------------------ +(define-overloadable-function semantic-analyze-scope-nested-tags (position scopedtypes) + "Return a list of types in order of nesting for the context of POSITION. +If POSITION is in a method with a named parent, find that parent, and +identify it's scope via overlay instead. +Optional SCOPETYPES are additional scoped entities in which our parent might +be found.") + +(defun semantic-analyze-scope-nested-tags-default (position scopetypes) + "Return a list of types in order of nesting for the context of POSITION. +If POSITION is in a method with a named parent, find that parent, and +identify it's scope via overlay instead. +Optional SCOPETYPES are additional scoped entities in which our parent might +be found. +This only finds ONE immediate parent by name. All other parents returned +are from nesting data types." + (require 'semantic/analyze) + (save-excursion + (if position (goto-char position)) + (let* ((stack (reverse (semantic-find-tag-by-overlay (point)))) + (tag (car stack)) + (pparent (car (cdr stack))) + (returnlist nil) + ) + ;; In case of arg lists or some-such, throw out non-types. + (while (and stack (not (semantic-tag-of-class-p pparent 'type))) + (setq stack (cdr stack) + pparent (car (cdr stack)))) + + ;; Step 1: + ;; Analyze the stack of tags we are nested in as parents. + ;; + + ;; If we have a pparent tag, lets go there + ;; an analyze that stack of tags. + (when (and pparent (semantic-tag-with-position-p pparent)) + (semantic-go-to-tag pparent) + (setq stack (semantic-find-tag-by-overlay (point))) + ;; Step one, find the merged version of stack in the typecache. + (let* ((stacknames (reverse (mapcar 'semantic-tag-name stack))) + (tc nil) + ) + ;; @todo - can we use the typecache ability to + ;; put a scope into a tag to do this? + (while (and stacknames + (setq tc (semanticdb-typecache-find + (reverse stacknames)))) + (setq returnlist (cons tc returnlist) + stacknames (cdr stacknames))) + (when (not returnlist) + ;; When there was nothing from the typecache, then just + ;; use what's right here. + (setq stack (reverse stack)) + ;; Add things to STACK until we cease finding tags of class type. + (while (and stack (eq (semantic-tag-class (car stack)) 'type)) + ;; Otherwise, just add this to the returnlist. + (setq returnlist (cons (car stack) returnlist)) + (setq stack (cdr stack))) + + (setq returnlist (nreverse returnlist)) + )) + ) + + ;; Only do this level of analysis for functions. + (when (eq (semantic-tag-class tag) 'function) + ;; Step 2: + ;; If the function tag itself has a "parent" by name, then that + ;; parent will exist in the scope we just calculated, so look it + ;; up now. + ;; + (let ((p (semantic-tag-function-parent tag))) + (when p + ;; We have a parent, search for it. + (let* ((searchnameraw (cond ((stringp p) p) + ((semantic-tag-p p) + (semantic-tag-name p)) + ((and (listp p) (stringp (car p))) + (car p)))) + (searchname (semantic-analyze-split-name searchnameraw)) + (snlist (if (consp searchname) + searchname + (list searchname))) + (fullsearchname nil) + + (miniscope (semantic-scope-cache "mini")) + ptag) + + ;; Find the next entry in the refereneced type for + ;; our function, and append to return list till our + ;; returnlist is empty. + (while snlist + (setq fullsearchname + (append (mapcar 'semantic-tag-name returnlist) + (list (car snlist)))) ;; Next one + (setq ptag + (semanticdb-typecache-find fullsearchname)) + + (when (or (not ptag) + (not (semantic-tag-of-class-p ptag 'type))) + (let ((rawscope + (apply 'append + (mapcar 'semantic-tag-type-members + (cons (car returnlist) scopetypes) + ))) + ) + (oset miniscope parents returnlist) ;; Not really accurate, but close + (oset miniscope scope rawscope) + (oset miniscope fullscope rawscope) + (setq ptag + (semantic-analyze-find-tag searchnameraw + 'type + miniscope + )) + )) + + (when ptag + (when (and (not (semantic-tag-p ptag)) + (semantic-tag-p (car ptag))) + (setq ptag (car ptag))) + (setq returnlist (append returnlist (list ptag))) + ) + + (setq snlist (cdr snlist))) + (setq returnlist returnlist) + ))) + ) + returnlist + ))) + +(define-overloadable-function semantic-analyze-scope-lineage-tags (parents scopedtypes) + "Return the full lineage of tags from PARENTS. +The return list is of the form ( TAG . PROTECTION ), where TAG is a tag, +and PROTECTION is the level of protection offered by the relationship. +Optional SCOPETYPES are additional scoped entities in which our parent might +be found.") + +(defun semantic-analyze-scope-lineage-tags-default (parents scopetypes) + "Return the full lineage of tags from PARENTS. +The return list is of the form ( TAG . PROTECTION ), where TAG is a tag, +and PROTECTION is the level of protection offered by the relationship. +Optional SCOPETYPES are additional scoped entities in which our parent might +be found." + (let ((lineage nil) + (miniscope (semantic-scope-cache "mini")) + ) + (oset miniscope parents parents) + (oset miniscope scope scopetypes) + (oset miniscope fullscope scopetypes) + + (dolist (slp parents) + (semantic-analyze-scoped-inherited-tag-map + slp (lambda (newparent) + (let* ((pname (semantic-tag-name newparent)) + (prot (semantic-tag-type-superclass-protection slp pname)) + (effectiveprot (cond ((eq prot 'public) + ;; doesn't provide access to private slots? + 'protected) + (t prot)))) + (push (cons newparent effectiveprot) lineage) + )) + miniscope)) + + lineage)) + + +;;------------------------------------------------------------ + +(define-overloadable-function semantic-analyze-scoped-tags (typelist parentlist) + "Return accessable tags when TYPELIST and PARENTLIST is in scope. +Tags returned are not in the global name space, but are instead +scoped inside a class or namespace. Such items can be referenced +without use of \"object.function()\" style syntax due to an +implicit \"object\".") + +(defun semantic-analyze-scoped-tags-default (typelist halfscope) + "Return accessable tags when TYPELIST and HALFSCOPE is in scope. +HALFSCOPE is the current scope partially initialized. +Tags returned are not in the global name space, but are instead +scoped inside a class or namespace. Such items can be referenced +without use of \"object.function()\" style syntax due to an +implicit \"object\"." + (let ((typelist2 nil) + (currentscope nil) + (parentlist (oref halfscope parents)) + (miniscope halfscope) + ) + ;; Loop over typelist, and find and merge all namespaces matching + ;; the names in typelist. + (while typelist + (let ((tt (semantic-tag-type (car typelist)))) + (when (and (stringp tt) (string= tt "namespace")) + ;; By using the typecache, our namespaces are pre-merged. + (setq typelist2 (cons (car typelist) typelist2)) + )) + (setq typelist (cdr typelist))) + + ;; Loop over the types (which should be sorted by postion + ;; adding to the scopelist as we go, and using the scopelist + ;; for additional searching! + (while typelist2 + (oset miniscope scope currentscope) + (oset miniscope fullscope currentscope) + (setq currentscope (append + (semantic-analyze-scoped-type-parts (car typelist2) + miniscope) + currentscope)) + (setq typelist2 (cdr typelist2))) + + ;; Collect all the types (class, etc) that are in our heratage. + ;; These are types that we can extract members from, not those + ;; delclared in using statements, or the like. + ;; Get the PARENTS including nesting scope for this location. + (while parentlist + (oset miniscope scope currentscope) + (oset miniscope fullscope currentscope) + (setq currentscope (append + (semantic-analyze-scoped-type-parts (car parentlist) + miniscope) + currentscope)) + (setq parentlist (cdr parentlist))) + + ;; Loop over all the items, and collect any type constants. + (let ((constants nil)) + (dolist (T currentscope) + (setq constants (append constants + (semantic-analyze-type-constants T))) + ) + + (setq currentscope (append currentscope constants))) + + currentscope)) + +;;------------------------------------------------------------ +(define-overloadable-function semantic-analyze-scope-calculate-access (type scope) + "Calculate the access class for TYPE as defined by the current SCOPE. +Access is related to the :parents in SCOPE. If type is a member of SCOPE +then access would be 'private. If TYPE is inherited by a member of SCOPE, +the access would be 'protected. Otherwise, access is 'public") + +(defun semantic-analyze-scope-calculate-access-default (type scope) + "Calculate the access class for TYPE as defined by the current SCOPE." + (cond ((semantic-scope-cache-p scope) + (let ((parents (oref scope parents)) + (parentsi (oref scope parentinheritance)) + ) + (catch 'moose + ;; Investigate the parent, and see how it relates to type. + ;; If these tags are basically the same, then we have full access. + (dolist (p parents) + (when (semantic-tag-similar-p type p) + (throw 'moose 'private)) + ) + ;; Look to see if type is in our list of inherited parents. + (dolist (pi parentsi) + ;; pi is a cons cell ( PARENT . protection) + (let ((pip (car pi)) + (piprot (cdr pi))) + (when (semantic-tag-similar-p type pip) + (throw 'moose + ;; protection via inheritance means to pull out different + ;; bits based on protection labels in an opposite way. + (cdr (assoc piprot + '((public . private) + (protected . protected) + (private . public)))) + ))) + ) + ;; Not in our parentage. Is type a FRIEND? + (let ((friends (semantic-find-tags-by-class 'friend (semantic-tag-type-members type)))) + (dolist (F friends) + (dolist (pi parents) + (if (string= (semantic-tag-name F) (semantic-tag-name pi)) + (throw 'moose 'private)) + ))) + ;; Found nothing, return public + 'public) + )) + (t 'public))) + +(defun semantic-completable-tags-from-type (type) + "Return a list of slots that are valid completions from the list of SLOTS. +If a tag in SLOTS has a named parent, then that implies that the +tag is not something you can complete from within TYPE." + (let ((allslots (semantic-tag-components type)) + (leftover nil) + ) + (dolist (S allslots) + (when (or (not (semantic-tag-of-class-p S 'function)) + (not (semantic-tag-function-parent S))) + (setq leftover (cons S leftover))) + ) + (nreverse leftover))) + +(defun semantic-analyze-scoped-type-parts (type &optional scope noinherit protection) + "Return all parts of TYPE, a tag representing a TYPE declaration. +SCOPE is the scope object. +NOINHERIT turns off searching of inherited tags. +PROTECTION specifies the type of access requested, such as 'public or 'private." + (if (not type) + nil + (let* ((access (semantic-analyze-scope-calculate-access type scope)) + ;; SLOTS are the slots directly a part of TYPE. + (allslots (semantic-completable-tags-from-type type)) + (slots (semantic-find-tags-by-scope-protection + access + type allslots)) + (fname (semantic-tag-file-name type)) + ;; EXTMETH are externally defined methods that are still + ;; a part of this class. + + ;; @TODO - is this line needed?? Try w/out for a while + ;; @note - I think C++ says no. elisp might, but methods + ;; look like defuns, so it makes no difference. + (extmeth nil) ; (semantic-tag-external-member-children type t)) + + ;; INHERITED are tags found in classes that our TYPE tag + ;; inherits from. Do not do this if it was not requested. + (inherited (when (not noinherit) + (semantic-analyze-scoped-inherited-tags type scope + access))) + ) + (when (not (semantic-tag-in-buffer-p type)) + (let ((copyslots nil)) + (dolist (TAG slots) + ;;(semantic--tag-put-property TAG :filename fname) + (if (semantic-tag-file-name TAG) + ;; If it has a filename, just go with it... + (setq copyslots (cons TAG copyslots)) + ;; Otherwise, copy the tag w/ the guessed filename. + (setq copyslots (cons (semantic-tag-copy TAG nil fname) + copyslots))) + ) + (setq slots (nreverse copyslots)) + )) + ;; Flatten the database output. + (append slots extmeth inherited) + ))) + +(defun semantic-analyze-scoped-inherited-tags (type scope access) + "Return all tags that TYPE inherits from. +Argument SCOPE specify additional tags that are in scope +whose tags can be searched when needed, OR it may be a scope object. +ACCESS is the level of access we filter on child supplied tags. +For langauges with protection on specific methods or slots, +it should strip out those not accessable by methods of TYPE. +An ACCESS of 'public means not in a method of a subclass of type. +A value of 'private means we can access private parts of the originating +type." + (let ((ret nil)) + (semantic-analyze-scoped-inherited-tag-map + type (lambda (p) + (let* ((pname (semantic-tag-name p)) + (protection (semantic-tag-type-superclass-protection + type pname)) + ) + (if (and (eq access 'public) (not (eq protection 'public))) + nil ;; Don't do it. + + ;; We can get some parts of this type. + (setq ret (nconc ret + ;; Do not pull in inherited parts here. Those + ;; will come via the inherited-tag-map fcn + (semantic-analyze-scoped-type-parts + p scope t protection)) + )))) + scope) + ret)) + +(defun semantic-analyze-scoped-inherited-tag-map (type fcn scope) + "Map all parents of TYPE to FCN. Return tags of all the types. +Argument SCOPE specify additional tags that are in scope +whose tags can be searched when needed, OR it may be a scope object." + (require 'semantic/analyze) + (let* (;; PARENTS specifies only the superclasses and not + ;; interfaces. Inheriting from an interfaces implies + ;; you have a copy of all methods locally. I think. + (parents (semantic-tag-type-superclasses type)) + ps pt + (tmpscope scope) + ) + (save-excursion + + ;; Create a SCOPE just for looking up the parent based on where + ;; the parent came from. + ;; + ;; @TODO - Should we cache these mini-scopes around in Emacs + ;; for recycling later? Should this become a helpful + ;; extra routine? + (when (and parents (semantic-tag-with-position-p type)) + ;; If TYPE has a position, go there and get the scope. + (semantic-go-to-tag type) + + ;; We need to make a mini scope, and only include the misc bits + ;; that will help in finding the parent. We don't really need + ;; to do any of the stuff related to variables and what-not. + (setq tmpscope (semantic-scope-cache "mini")) + (let* (;; Step 1: + (scopetypes (semantic-analyze-scoped-types (point))) + (parents (semantic-analyze-scope-nested-tags (point) scopetypes)) + ;;(parentinherited (semantic-analyze-scope-lineage-tags parents scopetypes)) + (lscope nil) + ) + (oset tmpscope scopetypes scopetypes) + (oset tmpscope parents parents) + ;;(oset tmpscope parentinheritance parentinherited) + + (when (or scopetypes parents) + (setq lscope (semantic-analyze-scoped-tags scopetypes tmpscope)) + (oset tmpscope scope lscope)) + (oset tmpscope fullscope (append scopetypes lscope parents)) + )) + ;; END creating tmpscope + + ;; Look up each parent one at a time. + (dolist (p parents) + (setq ps (cond ((stringp p) p) + ((and (semantic-tag-p p) (semantic-tag-prototype-p p)) + (semantic-tag-name p)) + ((and (listp p) (stringp (car p))) + p)) + pt (condition-case nil + (or (semantic-analyze-find-tag ps 'type tmpscope) + ;; A backup hack. + (semantic-analyze-find-tag ps 'type scope)) + (error nil))) + + (when pt + (funcall fcn pt) + ;; Note that we pass the original SCOPE in while recursing. + ;; so that the correct inheritance model is passed along. + (semantic-analyze-scoped-inherited-tag-map pt fcn scope) + ))) + nil)) + +;;; ANALYZER +;; +;; Create the scope structure for use in the Analyzer. +;; +;;;###autoload +(defun semantic-calculate-scope (&optional point) + "Calculate the scope at POINT. +If POINT is not provided, then use the current location of point. +The class returned from the scope calculation is variable +`semantic-scope-cache'." + (interactive) + (if (not (and (featurep 'semantic/db) semanticdb-current-database)) + nil ;; Don't do anything... + (require 'semantic/db-typecache) + (if (not point) (setq point (point))) + (when (interactive-p) + (semantic-fetch-tags) + (semantic-scope-reset-cache) + ) + (save-excursion + (goto-char point) + (let* ((TAG (semantic-current-tag)) + (scopecache + (semanticdb-cache-get semanticdb-current-table + semantic-scope-cache)) + ) + (when (not (semantic-equivalent-tag-p TAG (oref scopecache tag))) + (semantic-reset scopecache)) + (if (oref scopecache tag) + ;; Even though we can recycle most of the scope, we + ;; need to redo the local variables since those change + ;; as you move about the tag. + (condition-case nil + (oset scopecache localvar (semantic-get-all-local-variables)) + (error nil)) + + (let* (;; Step 1: + (scopetypes (semantic-analyze-scoped-types point)) + (parents (semantic-analyze-scope-nested-tags point scopetypes)) + (parentinherited (semantic-analyze-scope-lineage-tags + parents scopetypes)) + ) + (oset scopecache tag TAG) + (oset scopecache scopetypes scopetypes) + (oset scopecache parents parents) + (oset scopecache parentinheritance parentinherited) + + (let* (;; Step 2: + (scope (when (or scopetypes parents) + (semantic-analyze-scoped-tags scopetypes scopecache)) + ) + ;; Step 3: + (localargs (semantic-get-local-arguments)) + (localvar (condition-case nil + (semantic-get-all-local-variables) + (error nil))) + ) + + ;; Try looking for parents again. + (when (not parentinherited) + (setq parentinherited (semantic-analyze-scope-lineage-tags + parents (append scopetypes scope))) + (when parentinherited + (oset scopecache parentinheritance parentinherited) + ;; Try calculating the scope again with the new inherited parent list. + (setq scope (when (or scopetypes parents) + (semantic-analyze-scoped-tags scopetypes scopecache)) + ))) + + ;; Fill out the scope. + (oset scopecache scope scope) + (oset scopecache fullscope (append scopetypes scope parents)) + (oset scopecache localargs localargs) + (oset scopecache localvar localvar) + ))) + ;; Make sure we become dependant on the typecache. + (semanticdb-typecache-add-dependant scopecache) + ;; Handy debug output. + (when (interactive-p) + (require 'eieio-datadebug) + (data-debug-show scopecache) + ) + ;; Return ourselves + scopecache)))) + +(defun semantic-scope-find (name &optional class scope-in) + "Find the tag with NAME, and optinal CLASS in the current SCOPE-IN. +Searches various elements of the scope for NAME. Return ALL the +hits in order, with the first tag being in the closest scope." + (let ((scope (or scope-in (semantic-calculate-scope))) + (ans nil)) + ;; Is the passed in scope really a scope? if so, look through + ;; the options in that scope. + (if (semantic-scope-cache-p scope) + (let* ((la + ;; This should be first, but bugs in the + ;; C parser will turn function calls into + ;; assumed int return function prototypes. Yuck! + (semantic-find-tags-by-name name (oref scope localargs))) + (lv + (semantic-find-tags-by-name name (oref scope localvar))) + (fullscoperaw (oref scope fullscope)) + (sc (semantic-find-tags-by-name name fullscoperaw)) + (typescoperaw (oref scope typescope)) + (tsc (semantic-find-tags-by-name name typescoperaw)) + ) + (setq ans + (if class + ;; Scan out things not of the right class. + (semantic-find-tags-by-class class (append la lv sc tsc)) + (append la lv sc tsc)) + ) + + (when (and (not ans) (or typescoperaw fullscoperaw)) + (let ((namesplit (semantic-analyze-split-name name))) + (when (consp namesplit) + ;; It may be we need to hack our way through type typescope. + (while namesplit + (setq ans (append + (semantic-find-tags-by-name (car namesplit) + typescoperaw) + (semantic-find-tags-by-name (car namesplit) + fullscoperaw) + )) + (if (not ans) + (setq typescoperaw nil) + (when (cdr namesplit) + (setq typescoperaw (semantic-tag-type-members + (car ans))))) + + (setq namesplit (cdr namesplit))) + ;; Once done, store the current typecache lookup + (oset scope typescope + (append typescoperaw (oref scope typescope))) + ))) + ;; Return it. + ans) + ;; Not a real scope. Our scope calculation analyze parts of + ;; what it finds, and needs to pass lists through to do it's work. + ;; Tread that list as a singly entry. + (if class + (semantic-find-tags-by-class class scope) + scope) + ))) + +;;; DUMP +;; +(defmethod semantic-analyze-show ((context semantic-scope-cache)) + "Insert CONTEXT into the current buffer in a nice way." + (require 'semantic/analyze) + (semantic-analyze-princ-sequence (oref context scopetypes) "-> ScopeTypes: " ) + (semantic-analyze-princ-sequence (oref context parents) "-> Parents: " ) + (semantic-analyze-princ-sequence (oref context scope) "-> Scope: " ) + ;;(semantic-analyze-princ-sequence (oref context fullscope) "Fullscope: " ) + (semantic-analyze-princ-sequence (oref context localargs) "-> Local Args: " ) + (semantic-analyze-princ-sequence (oref context localvar) "-> Local Vars: " ) + ) + +(provide 'semantic/scope) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/scope" +;; End: + +;;; semantic/scope.el ends here diff --git a/lisp/cedet/semantic/senator.el b/lisp/cedet/semantic/senator.el new file mode 100644 index 00000000000..41735f9c6c7 --- /dev/null +++ b/lisp/cedet/semantic/senator.el @@ -0,0 +1,888 @@ +;;; semantic/senator.el --- SEmantic NAvigaTOR + +;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, +;; 2009 Free Software Foundation, Inc. + +;; Author: David Ponce <david@dponce.com> +;; Maintainer: FSF +;; Created: 10 Nov 2000 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file defines some user commands for navigating between +;; Semantic tags. This is a subset of the version of senator.el in +;; the upstream CEDET package; the rest is incorporated into other +;; parts of Semantic or Emacs. + +;;; Code: + +(require 'ring) +(require 'semantic) +(require 'semantic/ctxt) +(require 'semantic/decorate) +(require 'semantic/format) + +(eval-when-compile (require 'semantic/find)) + +;; (eval-when-compile (require 'hippie-exp)) + +(declare-function semanticdb-fast-strip-find-results "semantic/db-find") +(declare-function semanticdb-deep-find-tags-for-completion "semantic/db-find") +(declare-function semantic-analyze-tag-references "semantic/analyze/refs") +(declare-function semantic-analyze-refs-impl "semantic/analyze/refs") +(declare-function semantic-analyze-find-tag "semantic/analyze") +(declare-function semantic-analyze-tag-type "semantic/analyze/fcn") +(declare-function semantic-tag-external-class "semantic/sort") +(declare-function imenu--mouse-menu "imenu") + +;;; Customization +(defgroup senator nil + "Semantic Navigator." + :group 'semantic) + +;;;###autoload +(defcustom senator-step-at-tag-classes nil + "List of tag classes recognized by Senator's navigation commands. +A tag class is a symbol, such as `variable', `function', or `type'. + +As a special exception, if the value is nil, Senator's navigation +commands recognize all tag classes." + :group 'senator + :type '(repeat (symbol))) +;;;###autoload +(make-variable-buffer-local 'senator-step-at-tag-classes) + +;;;###autoload +(defcustom senator-step-at-start-end-tag-classes nil + "List of tag classes at which Senator's navigation commands should stop. +A tag class is a symbol, such as `variable', `function', or `type'. +The navigation commands stop at the start and end of each tag +class in this list, provided the tag class is recognized (see +`senator-step-at-tag-classes'). + +As a special exception, if the value is nil, the navigation +commands stop at the beginning of every tag. + +If t, the navigation commands stop at the start and end of any +tag, where possible." + :group 'senator + :type '(choice :tag "Identifiers" + (repeat :menu-tag "Symbols" (symbol)) + (const :tag "All" t))) +;;;###autoload +(make-variable-buffer-local 'senator-step-at-start-end-tag-classes) + +(defcustom senator-highlight-found nil + "If non-nil, Senator commands momentarily highlight found tags." + :group 'senator + :type 'boolean) +(make-variable-buffer-local 'senator-highlight-found) + +;;; Faces +(defface senator-momentary-highlight-face + '((((class color) (background dark)) + (:background "gray30")) + (((class color) (background light)) + (:background "gray70"))) + "Face used to momentarily highlight tags." + :group 'semantic-faces) + +;;; Common functions + +(defun senator-momentary-highlight-tag (tag) + "Momentarily highlight TAG. +Does nothing if `senator-highlight-found' is nil." + (and senator-highlight-found + (semantic-momentary-highlight-tag + tag 'senator-momentary-highlight-face))) + +(defun senator-step-at-start-end-p (tag) + "Return non-nil if must step at start and end of TAG." + (and tag + (or (eq senator-step-at-start-end-tag-classes t) + (memq (semantic-tag-class tag) + senator-step-at-start-end-tag-classes)))) + +(defun senator-skip-p (tag) + "Return non-nil if must skip TAG." + (and tag + senator-step-at-tag-classes + (not (memq (semantic-tag-class tag) + senator-step-at-tag-classes)))) + +(defun senator-middle-of-tag-p (pos tag) + "Return non-nil if POS is between start and end of TAG." + (and (> pos (semantic-tag-start tag)) + (< pos (semantic-tag-end tag)))) + +(defun senator-step-at-parent (tag) + "Return TAG's outermost parent if must step at start/end of it. +Return nil otherwise." + (if tag + (let (parent parents) + (setq parents (semantic-find-tag-by-overlay + (semantic-tag-start tag))) + (while (and parents (not parent)) + (setq parent (car parents) + parents (cdr parents)) + (if (or (eq tag parent) + (senator-skip-p parent) + (not (senator-step-at-start-end-p parent))) + (setq parent nil))) + parent))) + +(defun senator-previous-tag-or-parent (pos) + "Return the tag before POS or one of its parent where to step." + (let (ol tag) + (while (and pos (> pos (point-min)) (not tag)) + (setq pos (semantic-overlay-previous-change pos)) + (when pos + ;; Get overlays at position + (setq ol (semantic-overlays-at pos)) + ;; find the overlay that belongs to semantic + ;; and STARTS or ENDS at the found position. + (while (and ol (not tag)) + (setq tag (semantic-overlay-get (car ol) 'semantic)) + (unless (and tag (semantic-tag-p tag) + (or (= (semantic-tag-start tag) pos) + (= (semantic-tag-end tag) pos))) + (setq tag nil + ol (cdr ol)))))) + (or (senator-step-at-parent tag) tag))) + +;;; Search functions + +(defun senator-search-tag-name (tag) + "Search for TAG name in current buffer. +Limit the search to TAG bounds. +If found, set point to the end of the name, and return point. The +beginning of the name is at (match-beginning 0). +Return nil if not found, that is if TAG name doesn't come from the +source." + (let ((name (semantic-tag-name tag))) + (setq name (if (string-match "\\`\\([^[]+\\)[[]" name) + (match-string 1 name) + name)) + (goto-char (semantic-tag-start tag)) + (when (re-search-forward (concat + ;; The tag name is expected to be + ;; between word delimiters, whitespaces, + ;; or punctuations. + "\\(\\<\\|\\s-+\\|\\s.\\)" + (regexp-quote name) + "\\(\\>\\|\\s-+\\|\\s.\\)") + (semantic-tag-end tag) + t) + (goto-char (match-beginning 0)) + (search-forward name)))) + +(defcustom senator-search-ignore-tag-classes + '(code block) + "List of ignored tag classes. +Tags of those classes are excluded from search." + :group 'senator + :type '(repeat (symbol :tag "class"))) + +(defun senator-search-default-tag-filter (tag) + "Default function that filters searched tags. +Ignore tags of classes in `senator-search-ignore-tag-classes'" + (not (memq (semantic-tag-class tag) + senator-search-ignore-tag-classes))) + +(defvar senator-search-tag-filter-functions + '(senator-search-default-tag-filter) + "List of functions to be called to filter searched tags. +Each function is passed a tag. If one of them returns nil, the tag is +excluded from the search.") + +(defun senator-search (searcher text &optional bound noerror count) + "Use the SEARCHER function to search from point for TEXT in a tag name. +SEARCHER is typically the function `search-forward', `search-backward', +`word-search-forward', `word-search-backward', `re-search-forward', or +`re-search-backward'. See one of the above function to see how the +TEXT, BOUND, NOERROR, and COUNT arguments are interpreted." + (let* ((origin (point)) + (count (or count 1)) + (step (cond ((> count 0) 1) + ((< count 0) (setq count (- count)) -1) + (0))) + found next sstart send tag tstart tend) + (or (zerop step) + (while (and (not found) + (setq next (funcall searcher text bound t step))) + (setq sstart (match-beginning 0) + send (match-end 0)) + (if (= sstart send) + (setq found t) + (and (setq tag (semantic-current-tag)) + (run-hook-with-args-until-failure + 'senator-search-tag-filter-functions tag) + (setq tend (senator-search-tag-name tag)) + (setq tstart (match-beginning 0) + found (and (>= sstart tstart) + (<= send tend) + (zerop (setq count (1- count)))))) + (goto-char next)))) + (cond ((null found) + (setq next origin + send origin)) + ((= next sstart) + (setq next send + send sstart)) + (t + (setq next sstart))) + (goto-char next) + ;; Setup the returned value and the `match-data' or maybe fail! + (funcall searcher text send noerror step))) + +;;; Navigation commands + +;;;###autoload +(defun senator-next-tag () + "Navigate to the next Semantic tag. +Return the tag or nil if at end of buffer." + (interactive) + (let ((pos (point)) + (tag (semantic-current-tag)) + where) + (if (and tag + (not (senator-skip-p tag)) + (senator-step-at-start-end-p tag) + (or (= pos (semantic-tag-start tag)) + (senator-middle-of-tag-p pos tag))) + nil + (if (setq tag (senator-step-at-parent tag)) + nil + (setq tag (semantic-find-tag-by-overlay-next pos)) + (while (and tag (senator-skip-p tag)) + (setq tag (semantic-find-tag-by-overlay-next + (semantic-tag-start tag)))))) + (if (not tag) + (progn + (goto-char (point-max)) + (message "End of buffer")) + (cond ((and (senator-step-at-start-end-p tag) + (or (= pos (semantic-tag-start tag)) + (senator-middle-of-tag-p pos tag))) + (setq where "end") + (goto-char (semantic-tag-end tag))) + (t + (setq where "start") + (goto-char (semantic-tag-start tag)))) + (senator-momentary-highlight-tag tag) + (message "%S: %s (%s)" + (semantic-tag-class tag) + (semantic-tag-name tag) + where)) + tag)) + +;;;###autoload +(defun senator-previous-tag () + "Navigate to the previous Semantic tag. +Return the tag or nil if at beginning of buffer." + (interactive) + (let ((pos (point)) + (tag (semantic-current-tag)) + where) + (if (and tag + (not (senator-skip-p tag)) + (senator-step-at-start-end-p tag) + (or (= pos (semantic-tag-end tag)) + (senator-middle-of-tag-p pos tag))) + nil + (if (setq tag (senator-step-at-parent tag)) + nil + (setq tag (senator-previous-tag-or-parent pos)) + (while (and tag (senator-skip-p tag)) + (setq tag (senator-previous-tag-or-parent + (semantic-tag-start tag)))))) + (if (not tag) + (progn + (goto-char (point-min)) + (message "Beginning of buffer")) + (cond ((or (not (senator-step-at-start-end-p tag)) + (= pos (semantic-tag-end tag)) + (senator-middle-of-tag-p pos tag)) + (setq where "start") + (goto-char (semantic-tag-start tag))) + (t + (setq where "end") + (goto-char (semantic-tag-end tag)))) + (senator-momentary-highlight-tag tag) + (message "%S: %s (%s)" + (semantic-tag-class tag) + (semantic-tag-name tag) + where)) + tag)) + +;;; Search commands + +(defun senator-search-forward (string &optional bound noerror count) + "Search in tag names forward from point for STRING. +Set point to the end of the occurrence found, and return point. +See also the function `search-forward' for details on the BOUND, +NOERROR and COUNT arguments." + (interactive "sSemantic search: ") + (senator-search 'search-forward string bound noerror count)) + +(defun senator-re-search-forward (regexp &optional bound noerror count) + "Search in tag names forward from point for regular expression REGEXP. +Set point to the end of the occurrence found, and return point. +See also the function `re-search-forward' for details on the BOUND, +NOERROR and COUNT arguments." + (interactive "sSemantic regexp search: ") + (senator-search 're-search-forward regexp bound noerror count)) + +(defun senator-word-search-forward (word &optional bound noerror count) + "Search in tag names forward from point for WORD. +Set point to the end of the occurrence found, and return point. +See also the function `word-search-forward' for details on the BOUND, +NOERROR and COUNT arguments." + (interactive "sSemantic word search: ") + (senator-search 'word-search-forward word bound noerror count)) + +(defun senator-search-backward (string &optional bound noerror count) + "Search in tag names backward from point for STRING. +Set point to the beginning of the occurrence found, and return point. +See also the function `search-backward' for details on the BOUND, +NOERROR and COUNT arguments." + (interactive "sSemantic backward search: ") + (senator-search 'search-backward string bound noerror count)) + +(defun senator-re-search-backward (regexp &optional bound noerror count) + "Search in tag names backward from point for regular expression REGEXP. +Set point to the beginning of the occurrence found, and return point. +See also the function `re-search-backward' for details on the BOUND, +NOERROR and COUNT arguments." + (interactive "sSemantic backward regexp search: ") + (senator-search 're-search-backward regexp bound noerror count)) + +(defun senator-word-search-backward (word &optional bound noerror count) + "Search in tag names backward from point for WORD. +Set point to the beginning of the occurrence found, and return point. +See also the function `word-search-backward' for details on the BOUND, +NOERROR and COUNT arguments." + (interactive "sSemantic backward word search: ") + (senator-search 'word-search-backward word bound noerror count)) + +;;; Other useful search commands (minor mode menu) + +(defvar senator-last-search-type nil + "Type of last non-incremental search command called.") + +(defun senator-nonincremental-repeat-search-forward () + "Search forward for the previous search string or regexp." + (interactive) + (cond + ((and (eq senator-last-search-type 'string) + search-ring) + (senator-search-forward (car search-ring))) + ((and (eq senator-last-search-type 'regexp) + regexp-search-ring) + (senator-re-search-forward (car regexp-search-ring))) + (t + (error "No previous search")))) + +(defun senator-nonincremental-repeat-search-backward () + "Search backward for the previous search string or regexp." + (interactive) + (cond + ((and (eq senator-last-search-type 'string) + search-ring) + (senator-search-backward (car search-ring))) + ((and (eq senator-last-search-type 'regexp) + regexp-search-ring) + (senator-re-search-backward (car regexp-search-ring))) + (t + (error "No previous search")))) + +(defun senator-nonincremental-search-forward (string) + "Search for STRING nonincrementally." + (interactive "sSemantic search for string: ") + (setq senator-last-search-type 'string) + (if (equal string "") + (senator-search-forward (car search-ring)) + (isearch-update-ring string nil) + (senator-search-forward string))) + +(defun senator-nonincremental-search-backward (string) + "Search backward for STRING nonincrementally." + (interactive "sSemantic search for string: ") + (setq senator-last-search-type 'string) + (if (equal string "") + (senator-search-backward (car search-ring)) + (isearch-update-ring string nil) + (senator-search-backward string))) + +(defun senator-nonincremental-re-search-forward (string) + "Search for the regular expression STRING nonincrementally." + (interactive "sSemantic search for regexp: ") + (setq senator-last-search-type 'regexp) + (if (equal string "") + (senator-re-search-forward (car regexp-search-ring)) + (isearch-update-ring string t) + (senator-re-search-forward string))) + +(defun senator-nonincremental-re-search-backward (string) + "Search backward for the regular expression STRING nonincrementally." + (interactive "sSemantic search for regexp: ") + (setq senator-last-search-type 'regexp) + (if (equal string "") + (senator-re-search-backward (car regexp-search-ring)) + (isearch-update-ring string t) + (senator-re-search-backward string))) + +(defvar senator--search-filter nil) + +(defun senator-search-set-tag-class-filter (&optional classes) + "In current buffer, limit search scope to tag CLASSES. +CLASSES is a list of tag class symbols or nil. If nil only global +filters in `senator-search-tag-filter-functions' remain active." + (interactive "sClasses: ") + (setq classes + (cond + ((null classes) + nil) + ((symbolp classes) + (list classes)) + ((stringp classes) + (mapcar 'read (split-string classes))) + (t + (signal 'wrong-type-argument (list classes))) + )) + ;; Clear previous filter. + (remove-hook 'senator-search-tag-filter-functions + senator--search-filter t) + (kill-local-variable 'senator--search-filter) + (if classes + (let ((tag (make-symbol "tag")) + (names (mapconcat 'symbol-name classes "', `"))) + (set (make-local-variable 'senator--search-filter) + `(lambda (,tag) + (memq (semantic-tag-class ,tag) ',classes))) + (add-hook 'senator-search-tag-filter-functions + senator--search-filter nil t) + (message "Limit search to `%s' tags" names)) + (message "Default search filter restored"))) + +;;; Folding +;; +;; Use new folding state. It might be wise to extend the idea +;; of folding for hiding all but this, or show all children, etc. + +(defun senator-fold-tag (&optional tag) + "Fold the current TAG." + (interactive) + (semantic-set-tag-folded (or tag (semantic-current-tag)) t)) + +(defun senator-unfold-tag (&optional tag) + "Fold the current TAG." + (interactive) + (semantic-set-tag-folded (or tag (semantic-current-tag)) nil)) + +(defun senator-fold-tag-toggle (&optional tag) + "Fold the current TAG." + (interactive) + (let ((tag (or tag (semantic-current-tag)))) + (if (semantic-tag-folded-p tag) + (senator-unfold-tag tag) + (senator-fold-tag tag)))) + +;; @TODO - move this to some analyzer / refs tool +(define-overloadable-function semantic-up-reference (tag) + "Return a tag that is referred to by TAG. +A \"reference\" could be any interesting feature of TAG. +In C++, a function may have a 'parent' which is non-local. +If that parent which is only a reference in the function tag +is found, we can jump to it. +Some tags such as includes have other reference features.") + +;;;###autoload +(defun senator-go-to-up-reference (&optional tag) + "Move up one reference from the current TAG. +A \"reference\" could be any interesting feature of TAG. +In C++, a function may have a 'parent' which is non-local. +If that parent which is only a reference in the function tag +is found, we can jump to it. +Some tags such as includes have other reference features." + (interactive) + (let ((result (semantic-up-reference (or tag (semantic-current-tag))))) + (if (not result) + (error "No up reference found") + (push-mark) + (cond + ;; A tag + ((semantic-tag-p result) + (semantic-go-to-tag result) + (switch-to-buffer (current-buffer)) + (semantic-momentary-highlight-tag result)) + ;; Buffers + ((bufferp result) + (switch-to-buffer result) + (pulse-momentary-highlight-one-line (point))) + ;; Files + ((and (stringp result) (file-exists-p result)) + (find-file result) + (pulse-momentary-highlight-one-line (point))) + (t + (error "Unknown result type from `semantic-up-reference'")))))) + +(defun semantic-up-reference-default (tag) + "Return a tag that is referredto by TAG. +Makes C/C++ language like assumptions." + (cond ((semantic-tag-faux-p tag) + ;; Faux tags should have a real tag in some other location. + (require 'semantic/sort) + (let ((options (semantic-tag-external-class tag))) + ;; I should do something a little better than + ;; this. Oy! + (car options) + )) + + ;; Include always point to another file. + ((eq (semantic-tag-class tag) 'include) + (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) + (get-file-buffer file)) + ((stringp file) + file) + ))) + + ;; Is there a parent of the function to jump to? + ((and (semantic-tag-of-class-p tag 'function) + (semantic-tag-function-parent tag)) + (let* ((scope (semantic-calculate-scope (point)))) + ;; @todo - it would be cool to ask the user which one if + ;; more than one. + (car (oref scope parents)) + )) + + ;; Is there a non-prototype version of the tag to jump to? + ((semantic-tag-get-attribute tag :prototype-flag) + (require 'semantic/analyze/refs) + (let* ((sar (semantic-analyze-tag-references tag))) + (car (semantic-analyze-refs-impl sar t))) + ) + + ;; If this is a datatype, and we have superclasses + ((and (semantic-tag-of-class-p tag 'type) + (semantic-tag-type-superclasses tag)) + (require 'semantic/analyze) + (let ((scope (semantic-calculate-scope (point))) + (parents (semantic-tag-type-superclasses tag))) + (semantic-analyze-find-tag (car parents) 'type scope))) + + ;; Get the data type, and try to find that. + ((semantic-tag-type tag) + (require 'semantic/analyze) + (let ((scope (semantic-calculate-scope (point)))) + (semantic-analyze-tag-type tag scope)) + ) + (t nil))) + +(defvar senator-isearch-semantic-mode nil + "Non-nil if isearch does semantic search. +This is a buffer local variable.") +(make-variable-buffer-local 'senator-isearch-semantic-mode) + +(defun senator-beginning-of-defun (&optional arg) + "Move backward to the beginning of a defun. +Use semantic tags to navigate. +ARG is the number of tags to navigate (not yet implemented)." + (semantic-fetch-tags) + (let* ((senator-highlight-found nil) + ;; Step at beginning of next tag with class specified in + ;; `senator-step-at-tag-classes'. + (senator-step-at-start-end-tag-classes t) + (tag (senator-previous-tag))) + (when tag + (if (= (point) (semantic-tag-end tag)) + (goto-char (semantic-tag-start tag))) + (beginning-of-line)))) + +(defun senator-end-of-defun (&optional arg) + "Move forward to next end of defun. +Use semantic tags to navigate. +ARG is the number of tags to navigate (not yet implemented)." + (semantic-fetch-tags) + (let* ((senator-highlight-found nil) + ;; Step at end of next tag with class specified in + ;; `senator-step-at-tag-classes'. + (senator-step-at-start-end-tag-classes t) + (tag (senator-next-tag))) + (when tag + (if (= (point) (semantic-tag-start tag)) + (goto-char (semantic-tag-end tag))) + (skip-chars-forward " \t") + (if (looking-at "\\s<\\|\n") + (forward-line 1))))) + +(defun senator-narrow-to-defun () + "Make text outside current defun invisible. +The defun visible is the one that contains point or follows point. +Use semantic tags to navigate." + (interactive) + (semantic-fetch-tags) + (save-excursion + (widen) + (senator-end-of-defun) + (let ((end (point))) + (senator-beginning-of-defun) + (narrow-to-region (point) end)))) + +(defun senator-mark-defun () + "Put mark at end of this defun, point at beginning. +The defun marked is the one that contains point or follows point. +Use semantic tags to navigate." + (interactive) + (let ((origin (point)) + (end (progn (senator-end-of-defun) (point))) + (start (progn (senator-beginning-of-defun) (point)))) + (goto-char origin) + (push-mark (point)) + (goto-char end) ;; end-of-defun + (push-mark (point) nil t) + (goto-char start) ;; beginning-of-defun + (re-search-backward "^\n" (- (point) 1) t))) + +;;; Tag Cut & Paste + +;; To copy a tag, means to put a tag definition into the tag +;; ring. To kill a tag, put the tag into the tag ring AND put +;; the body of the tag into the kill-ring. +;; +;; To retrieve a killed tag's text, use C-y (yank), but to retrieve +;; the tag as a reference of some sort, use senator-yank-tag. + +(defvar senator-tag-ring (make-ring 20) + "Ring of tags for use with cut and paste.") + +;;;###autoload +(defun senator-copy-tag () + "Take the current tag, and place it in the tag ring." + (interactive) + (semantic-fetch-tags) + (let ((ft (semantic-obtain-foreign-tag))) + (when ft + (ring-insert senator-tag-ring ft) + (kill-ring-save (semantic-tag-start ft) (semantic-tag-end ft)) + (when (interactive-p) + (message "Use C-y to yank text. Use `senator-yank-tag' for prototype insert.")) + ) + ft)) + +;;;###autoload +(defun senator-kill-tag () + "Take the current tag, place it in the tag ring, and kill it. +Killing the tag removes the text for that tag, and places it into +the kill ring. Retrieve that text with \\[yank]." + (interactive) + (let ((ct (senator-copy-tag))) ;; this handles the reparse for us. + (kill-region (semantic-tag-start ct) + (semantic-tag-end ct)) + (when (interactive-p) + (message "Use C-y to yank text. Use `senator-yank-tag' for prototype insert.")) + )) + +;;;###autoload +(defun senator-yank-tag () + "Yank a tag from the tag ring. +The form the tag takes is differnet depending on where it is being +yanked to." + (interactive) + (or (ring-empty-p senator-tag-ring) + (let ((ft (ring-ref senator-tag-ring 0))) + (semantic-foreign-tag-check ft) + (semantic-insert-foreign-tag ft) + (when (interactive-p) + (message "Use C-y to recover the yank the text of %s." + (semantic-tag-name ft))) + ))) + +;;;###autoload +(defun senator-copy-tag-to-register (register &optional kill-flag) + "Copy the current tag into REGISTER. +Optional argument KILL-FLAG will delete the text of the tag to the +kill ring." + (interactive "cTag to register: \nP") + (semantic-fetch-tags) + (let ((ft (semantic-obtain-foreign-tag))) + (when ft + (set-register register ft) + (if kill-flag + (kill-region (semantic-tag-start ft) + (semantic-tag-end ft)))))) + +;;;###autoload +(defun senator-transpose-tags-up () + "Transpose the current tag, and the preceeding tag." + (interactive) + (semantic-fetch-tags) + (let* ((current-tag (semantic-current-tag)) + (prev-tag (save-excursion + (goto-char (semantic-tag-start current-tag)) + (semantic-find-tag-by-overlay-prev))) + (ct-parent (semantic-find-tag-parent-by-overlay current-tag)) + (pt-parent (semantic-find-tag-parent-by-overlay prev-tag))) + (if (not (eq ct-parent pt-parent)) + (error "Cannot transpose tags")) + (let ((txt (buffer-substring (semantic-tag-start current-tag) + (semantic-tag-end current-tag))) + (line (count-lines (semantic-tag-start current-tag) + (point))) + (insert-point nil) + ) + (delete-region (semantic-tag-start current-tag) + (semantic-tag-end current-tag)) + (delete-blank-lines) + (goto-char (semantic-tag-start prev-tag)) + (setq insert-point (point)) + (insert txt) + (if (/= (current-column) 0) + (insert "\n")) + (insert "\n") + (goto-char insert-point) + (forward-line line) + ))) + +;;;###autoload +(defun senator-transpose-tags-down () + "Transpose the current tag, and the following tag." + (interactive) + (semantic-fetch-tags) + (let* ((current-tag (semantic-current-tag)) + (next-tag (save-excursion + (goto-char (semantic-tag-end current-tag)) + (semantic-find-tag-by-overlay-next))) + (end-pt (point-marker)) + ) + (goto-char (semantic-tag-start next-tag)) + (forward-char 1) + (senator-transpose-tags-up) + ;; I know that the above fcn deletes the next tag, so our pt marker + ;; will be stable. + (goto-char end-pt))) + +;;; Using semantic search in isearch mode + +(defun senator-lazy-highlight-update () + "Force lazy highlight update." + (lazy-highlight-cleanup t) + (set 'isearch-lazy-highlight-last-string nil) + (setq isearch-adjusted t) + (isearch-update)) + +;; Recent versions of GNU Emacs allow to override the isearch search +;; function for special needs, and avoid to advice the built-in search +;; function :-) +(defun senator-isearch-search-fun () + "Return the function to use for the search. +Use a senator search function when semantic isearch mode is enabled." + (intern + (concat (if senator-isearch-semantic-mode + "senator-" + "") + (cond (isearch-word "word-") + (isearch-regexp "re-") + (t "")) + "search-" + (if isearch-forward + "forward" + "backward")))) + +(defun senator-isearch-toggle-semantic-mode () + "Toggle semantic searching on or off in isearch mode." + (interactive) + (setq senator-isearch-semantic-mode + (not senator-isearch-semantic-mode)) + (if isearch-mode + ;; force lazy highlight update + (senator-lazy-highlight-update) + (message "Isearch semantic mode %s" + (if senator-isearch-semantic-mode + "enabled" + "disabled")))) + +(defvar senator-old-isearch-search-fun nil + "Hold previous value of `isearch-search-fun-function'.") + +(defun senator-isearch-mode-hook () + "Isearch mode hook to setup semantic searching." + (if (and isearch-mode senator-isearch-semantic-mode) + (progn + ;; When `senator-isearch-semantic-mode' is on save the + ;; previous `isearch-search-fun-function' and install the + ;; senator one. + (when (and (local-variable-p 'isearch-search-fun-function) + (not (local-variable-p 'senator-old-isearch-search-fun))) + (set (make-local-variable 'senator-old-isearch-search-fun) + isearch-search-fun-function)) + (set (make-local-variable 'isearch-search-fun-function) + 'senator-isearch-search-fun)) + ;; When `senator-isearch-semantic-mode' is off restore the + ;; previous `isearch-search-fun-function'. + (when (eq isearch-search-fun-function 'senator-isearch-search-fun) + (if (local-variable-p 'senator-old-isearch-search-fun) + (progn + (set (make-local-variable 'isearch-search-fun-function) + senator-old-isearch-search-fun) + (kill-local-variable 'senator-old-isearch-search-fun)) + (kill-local-variable 'isearch-search-fun-function))))) + +;; (add-hook 'isearch-mode-hook 'senator-isearch-mode-hook) +;; (add-hook 'isearch-mode-end-hook 'senator-isearch-mode-hook) + +;; ;; Keyboard shortcut to toggle semantic search in isearch mode. +;; (define-key isearch-mode-map +;; [(control ?,)] +;; 'senator-isearch-toggle-semantic-mode) + +;; (defadvice insert-register (around senator activate) +;; "Insert contents of register REGISTER as a tag. +;; If senator is not active, use the original mechanism." +;; (let ((val (get-register (ad-get-arg 0)))) +;; (if (and senator-minor-mode (interactive-p) +;; (semantic-foreign-tag-p val)) +;; (semantic-insert-foreign-tag val) +;; ad-do-it))) + +;; (defadvice jump-to-register (around senator activate) +;; "Insert contents of register REGISTER as a tag. +;; If senator is not active, use the original mechanism." +;; (let ((val (get-register (ad-get-arg 0)))) +;; (if (and senator-minor-mode (interactive-p) +;; (semantic-foreign-tag-p val)) +;; (progn +;; (switch-to-buffer (semantic-tag-buffer val)) +;; (goto-char (semantic-tag-start val))) +;; ad-do-it))) + +(provide 'semantic/senator) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/senator" +;; End: + +;;; semantic/senator.el ends here diff --git a/lisp/cedet/semantic/sort.el b/lisp/cedet/semantic/sort.el new file mode 100644 index 00000000000..36d4d808ca2 --- /dev/null +++ b/lisp/cedet/semantic/sort.el @@ -0,0 +1,570 @@ +;;; sort.el --- Utilities for sorting and re-arranging tag tables. + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Tag tables originate in the order they appear in a buffer, or source file. +;; It is often useful to re-arrange them is some predictable way for browsing +;; purposes. Re-organization may be alphabetical, or even a complete +;; reorganization of parents and children. +;; +;; Originally written in semantic-util.el +;; + +(require 'semantic) +(eval-when-compile + (require 'semantic/find)) + +(declare-function semanticdb-find-tags-external-children-of-type + "semantic/db-find") + +;;; Alphanumeric sorting +;; +;; Takes a list of tags, and sorts them in a case-insensitive way +;; at a single level. + +;;; Code: +(defun semantic-string-lessp-ci (s1 s2) + "Case insensitive version of `string-lessp'. +Argument S1 and S2 are the strings to compare." + ;; Use downcase instead of upcase because an average name + ;; has more lower case characters. + (if (fboundp 'compare-strings) + (eq (compare-strings s1 0 nil s2 0 nil t) -1) + (string-lessp (downcase s1) (downcase s2)))) + +(defun semantic-sort-tag-type (tag) + "Return a type string for TAG guaranteed to be a string." + (let ((ty (semantic-tag-type tag))) + (cond ((stringp ty) + ty) + ((listp ty) + (or (car ty) "")) + (t "")))) + +(defun semantic-tag-lessp-name-then-type (A B) + "Return t if tag A is < tag B. +First sorts on name, then sorts on the name of the :type of +each tag." + (let ((na (semantic-tag-name A)) + (nb (semantic-tag-name B)) + ) + (if (string-lessp na nb) + t ; a sure thing. + (if (string= na nb) + ;; If equal, test the :type which might be different. + (let* ((ta (semantic-tag-type A)) + (tb (semantic-tag-type B)) + (tas (cond ((stringp ta) + ta) + ((semantic-tag-p ta) + (semantic-tag-name ta)) + (t nil))) + (tbs (cond ((stringp tb) + tb) + ((semantic-tag-p tb) + (semantic-tag-name tb)) + (t nil)))) + (if (and (stringp tas) (stringp tbs)) + (string< tas tbs) + ;; This is if A == B, and no types in A or B + nil)) + ;; This nil is if A > B, but not = + nil)))) + +(defun semantic-sort-tags-by-name-increasing (tags) + "Sort TAGS by name in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-tag-name a) + (semantic-tag-name b))))) + +(defun semantic-sort-tags-by-name-decreasing (tags) + "Sort TAGS by name in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-tag-name b) + (semantic-tag-name a))))) + +(defun semantic-sort-tags-by-type-increasing (tags) + "Sort TAGS by type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-sort-tag-type a) + (semantic-sort-tag-type b))))) + +(defun semantic-sort-tags-by-type-decreasing (tags) + "Sort TAGS by type in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (string-lessp (semantic-sort-tag-type b) + (semantic-sort-tag-type a))))) + +(defun semantic-sort-tags-by-name-increasing-ci (tags) + "Sort TAGS by name in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-tag-name a) + (semantic-tag-name b))))) + +(defun semantic-sort-tags-by-name-decreasing-ci (tags) + "Sort TAGS by name in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-tag-name b) + (semantic-tag-name a))))) + +(defun semantic-sort-tags-by-type-increasing-ci (tags) + "Sort TAGS by type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-sort-tag-type a) + (semantic-sort-tag-type b))))) + +(defun semantic-sort-tags-by-type-decreasing-ci (tags) + "Sort TAGS by type in decreasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) + (semantic-string-lessp-ci (semantic-sort-tag-type b) + (semantic-sort-tag-type a))))) + +(defun semantic-sort-tags-by-name-then-type-increasing (tags) + "Sort TAGS by name, then type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type a b)))) + +(defun semantic-sort-tags-by-name-then-type-decreasing (tags) + "Sort TAGS by name, then type in increasing order with side effects. +Return the sorted list." + (sort tags (lambda (a b) (semantic-tag-lessp-name-then-type b a)))) + +;;; Unique +;; +;; Scan a list of tags, removing duplicates. +;; This must first sort the tags by name alphabetically ascending. +;; +;; Useful for completion lists, or other situations where the +;; other data isn't as useful. + +(defun semantic-unique-tag-table-by-name (tags) + "Scan a list of TAGS, removing duplicate names. +This must first sort the tags by name alphabetically ascending. +For more complex uniqueness testing used by the semanticdb +typecaching system, see `semanticdb-typecache-merge-streams'." + (let ((sorted (semantic-sort-tags-by-name-increasing + (copy-sequence tags))) + (uniq nil)) + (while sorted + (if (or (not uniq) + (not (string= (semantic-tag-name (car sorted)) + (semantic-tag-name (car uniq))))) + (setq uniq (cons (car sorted) uniq))) + (setq sorted (cdr sorted)) + ) + (nreverse uniq))) + +(defun semantic-unique-tag-table (tags) + "Scan a list of TAGS, removing duplicates. +This must first sort the tags by position ascending. +TAGS are removed only if they are equivalent, as can happen when +multiple tag sources are scanned. +For more complex uniqueness testing used by the semanticdb +typecaching system, see `semanticdb-typecache-merge-streams'." + (let ((sorted (sort (copy-sequence tags) + (lambda (a b) + (cond ((not (semantic-tag-with-position-p a)) + t) + ((not (semantic-tag-with-position-p b)) + nil) + (t + (< (semantic-tag-start a) + (semantic-tag-start b))))))) + (uniq nil)) + (while sorted + (if (or (not uniq) + (not (semantic-equivalent-tag-p (car sorted) (car uniq)))) + (setq uniq (cons (car sorted) uniq))) + (setq sorted (cdr sorted)) + ) + (nreverse uniq))) + + +;;; Tag Table Flattening +;; +;; In the 1.4 search API, there was a parameter "search-parts" which +;; was used to find tags inside other tags. This was used +;; infrequently, mostly for completion/jump routines. These types +;; of commands would be better off with a flattened list, where all +;; tags appear at the top level. + +;;;###autoload +(defun semantic-flatten-tags-table (&optional table) + "Flatten the tags table TABLE. +All tags in TABLE, and all components of top level tags +in TABLE will appear at the top level of list. +Tags promoted to the top of the list will still appear +unmodified as components of their parent tags." + (let* ((table (semantic-something-to-tag-table table)) + ;; Initialize the starting list with our table. + (lists (list table))) + (mapc (lambda (tag) + (let ((components (semantic-tag-components tag))) + (if (and components + ;; unpositined tags can be hazardous to + ;; completion. Do we need any type of tag + ;; here? - EL + (semantic-tag-with-position-p (car components))) + (setq lists (cons + (semantic-flatten-tags-table components) + lists))))) + table) + (apply 'append (nreverse lists)) + )) + + +;;; Buckets: +;; +;; A list of tags can be grouped into buckets based on the tag class. +;; Bucketize means to take a list of tags at a given level in a tag +;; table, and reorganize them into buckets based on class. +;; +(defvar semantic-bucketize-tag-class + ;; Must use lambda because `semantic-tag-class' is a macro. + (lambda (tok) (semantic-tag-class tok)) + "Function used to get a symbol describing the class of a tag. +This function must take one argument of a semantic tag. +It should return a symbol found in `semantic-symbol->name-assoc-list' +which `semantic-bucketize' uses to bin up tokens. +To create new bins for an application augment +`semantic-symbol->name-assoc-list', and +`semantic-symbol->name-assoc-list-for-type-parts' in addition +to setting this variable (locally in your function).") + +(defun semantic-bucketize (tags &optional parent filter) + "Sort TAGS into a group of buckets based on tag class. +Unknown classes are placed in a Misc bucket. +Type bucket names are defined by either `semantic-symbol->name-assoc-list'. +If PARENT is specified, then TAGS belong to this PARENT in some way. +This will use `semantic-symbol->name-assoc-list-for-type-parts' to +generate bucket names. +Optional argument FILTER is a filter function to be applied to each bucket. +The filter function will take one argument, which is a list of tokens, and +may re-organize the list with side-effects." + (let* ((name-list (if parent + semantic-symbol->name-assoc-list-for-type-parts + semantic-symbol->name-assoc-list)) + (sn name-list) + (bins (make-vector (1+ (length sn)) nil)) + ask tagtype + (nsn nil) + (num 1) + (out nil)) + ;; Build up the bucket vector + (while sn + (setq nsn (cons (cons (car (car sn)) num) nsn) + sn (cdr sn) + num (1+ num))) + ;; Place into buckets + (while tags + (setq tagtype (funcall semantic-bucketize-tag-class (car tags)) + ask (assq tagtype nsn) + num (or (cdr ask) 0)) + (aset bins num (cons (car tags) (aref bins num))) + (setq tags (cdr tags))) + ;; Remove from buckets into a list. + (setq num 1) + (while (< num (length bins)) + (when (aref bins num) + (setq out + (cons (cons + (cdr (nth (1- num) name-list)) + ;; Filtering, First hacked by David Ponce david@dponce.com + (funcall (or filter 'nreverse) (aref bins num))) + out))) + (setq num (1+ num))) + (if (aref bins 0) + (setq out (cons (cons "Misc" + (funcall (or filter 'nreverse) (aref bins 0))) + out))) + (nreverse out))) + +;;; Adoption +;; +;; Some languages allow children of a type to be defined outside +;; the syntactic scope of that class. These routines will find those +;; external members, and bring them together in a cloned copy of the +;; class tag. +;; +(defvar semantic-orphaned-member-metaparent-type "class" + "In `semantic-adopt-external-members', the type of 'type for metaparents. +A metaparent is a made-up type semantic token used to hold the child list +of orphaned members of a named type.") +(make-variable-buffer-local 'semantic-orphaned-member-metaparent-type) + +(defvar semantic-mark-external-member-function nil + "Function called when an externally defined orphan is found. +By default, the token is always marked with the `adopted' property. +This function should be locally bound by a program that needs +to add additional behaviors into the token list. +This function is called with two arguments. The first is TOKEN which is +a shallow copy of the token to be modified. The second is the PARENT +which is adopting TOKEN. This function should return TOKEN (or a copy of it) +which is then integrated into the revised token list.") + +(defun semantic-adopt-external-members (tags) + "Rebuild TAGS so that externally defined members are regrouped. +Some languages such as C++ and CLOS permit the declaration of member +functions outside the definition of the class. It is easier to study +the structure of a program when such methods are grouped together +more logically. + +This function uses `semantic-tag-external-member-p' to +determine when a potential child is an externally defined member. + +Note: Applications which use this function must account for token +types which do not have a position, but have children which *do* +have positions. + +Applications should use `semantic-mark-external-member-function' +to modify all tags which are found as externally defined to some +type. For example, changing the token type for generating extra +buckets with the bucket function." + (let ((parent-buckets nil) + (decent-list nil) + (out nil) + (tmp nil) + ) + ;; Rebuild the output list, stripping out all parented + ;; external entries + (while tags + (cond + ((setq tmp (semantic-tag-external-member-parent (car tags))) + (let ((tagcopy (semantic-tag-clone (car tags))) + (a (assoc tmp parent-buckets))) + (semantic--tag-put-property-no-side-effect tagcopy 'adopted t) + (if a + ;; If this parent is already in the list, append. + (setcdr (nthcdr (1- (length a)) a) (list tagcopy)) + ;; If not, prepend this new parent bucket into our list + (setq parent-buckets + (cons (cons tmp (list tagcopy)) parent-buckets))) + )) + ((eq (semantic-tag-class (car tags)) 'type) + ;; Types need to be rebuilt from scratch so we can add in new + ;; children to the child list. Only the top-level cons + ;; cells need to be duplicated so we can hack out the + ;; child list later. + (setq out (cons (semantic-tag-clone (car tags)) out)) + (setq decent-list (cons (car out) decent-list)) + ) + (t + ;; Otherwise, append this tag to our new output list. + (setq out (cons (car tags) out))) + ) + (setq tags (cdr tags))) + ;; Rescan out, by descending into all types and finding parents + ;; for all entries moved into the parent-buckets. + (while decent-list + (let* ((bucket (assoc (semantic-tag-name (car decent-list)) + parent-buckets)) + (bucketkids (cdr bucket))) + (when bucket + ;; Run our secondary marking function on the children + (if semantic-mark-external-member-function + (setq bucketkids + (mapcar (lambda (tok) + (funcall semantic-mark-external-member-function + tok (car decent-list))) + bucketkids))) + ;; We have some extra kids. Merge. + (semantic-tag-put-attribute + (car decent-list) :members + (append (semantic-tag-type-members (car decent-list)) + bucketkids)) + ;; Nuke the bucket label so it is not found again. + (setcar bucket nil)) + (setq decent-list + (append (cdr decent-list) + ;; get embedded types to scan and make copies + ;; of them. + (mapcar + (lambda (tok) (semantic-tag-clone tok)) + (semantic-find-tags-by-class 'type + (semantic-tag-type-members (car decent-list))))) + ))) + ;; Scan over all remaining lost external methods, and tack them + ;; onto the end. + (while parent-buckets + (if (car (car parent-buckets)) + (let* ((tmp (car parent-buckets)) + (fauxtag (semantic-tag-new-type + (car tmp) + semantic-orphaned-member-metaparent-type + nil ;; Part list + nil ;; parents (unknown) + )) + (bucketkids (cdr tmp))) + (semantic-tag-set-faux fauxtag) ;; properties + (if semantic-mark-external-member-function + (setq bucketkids + (mapcar (lambda (tok) + (funcall semantic-mark-external-member-function + tok fauxtag)) + bucketkids))) + (semantic-tag-put-attribute fauxtag :members bucketkids) + ;; We have a bunch of methods with no parent in this file. + ;; Create a meta-type to hold it. + (setq out (cons fauxtag out)) + )) + (setq parent-buckets (cdr parent-buckets))) + ;; Return the new list. + (nreverse out))) + + +;;; External children +;; +;; In order to adopt external children, we need a few overload methods +;; to enable the feature. + +;;;###autoload +(define-overloadable-function semantic-tag-external-member-parent (tag) + "Return a parent for TAG when TAG is an external member. +TAG is an external member if it is defined at a toplevel and +has some sort of label defining a parent. The parent return will +be a string. + +The default behavior, if not overridden with +`tag-member-parent' gets the 'parent extra +specifier of TAG. + +If this function is overridden, use +`semantic-tag-external-member-parent-default' to also +include the default behavior, and merely extend your own." + ) + +(defun semantic-tag-external-member-parent-default (tag) + "Return the name of TAGs parent only if TAG is not defined in it's parent." + ;; Use only the extra spec because a type has a parent which + ;; means something completely different. + (let ((tp (semantic-tag-get-attribute tag :parent))) + (when (stringp tp) + tp))) + +(define-overloadable-function semantic-tag-external-member-p (parent tag) + "Return non-nil if PARENT is the parent of TAG. +TAG is an external member of PARENT when it is somehow tagged +as having PARENT as it's parent. +PARENT and TAG must both be semantic tags. + +The default behavior, if not overridden with +`tag-external-member-p' is to match :parent attribute in +the name of TAG. + +If this function is overridden, use +`semantic-tag-external-member-children-p-default' to also +include the default behavior, and merely extend your own." + ) + +(defun semantic-tag-external-member-p-default (parent tag) + "Return non-nil if PARENT is the parent of TAG." + ;; Use only the extra spec because a type has a parent which + ;; means something completely different. + (let ((tp (semantic-tag-external-member-parent tag))) + (and (stringp tp) + (string= (semantic-tag-name parent) tp)))) + +(define-overloadable-function semantic-tag-external-member-children (tag &optional usedb) + "Return the list of children which are not *in* TAG. +If optional argument USEDB is non-nil, then also search files in +the Semantic Database. If USEDB is a list of databases, search those +databases. + +Children in this case are functions or types which are members of +TAG, such as the parts of a type, but which are not defined inside +the class. C++ and CLOS both permit methods of a class to be defined +outside the bounds of the class' definition. + +The default behavior, if not overridden with +`tag-external-member-children' is to search using +`semantic-tag-external-member-p' in all top level definitions +with a parent of TAG. + +If this function is overridden, use +`semantic-tag-external-member-children-default' to also +include the default behavior, and merely extend your own." + ) + +(defun semantic-tag-external-member-children-default (tag &optional usedb) + "Return list of external children for TAG. +Optional argument USEDB specifies if the semantic database is used. +See `semantic-tag-external-member-children' for details." + (if (and usedb + (require 'semantic/db-mode) + (semanticdb-minor-mode-p) + (require 'semantic/db-find)) + (let ((m (semanticdb-find-tags-external-children-of-type + (semantic-tag-name tag)))) + (if m (apply #'append (mapcar #'cdr m)))) + (semantic--find-tags-by-function + `(lambda (tok) + ;; This bit of annoying backquote forces the contents of + ;; tag into the generated lambda. + (semantic-tag-external-member-p ',tag tok)) + (current-buffer)) + )) + +(define-overloadable-function semantic-tag-external-class (tag) + "Return a list of real tags that faux TAG might represent. + +In some languages, a method can be defined on an object which is +not in the same file. In this case, +`semantic-adopt-external-members' will create a faux-tag. If it +is necessary to get the tag from which for faux TAG was most +likely derived, then this function is needed." + (unless (semantic-tag-faux-p tag) + (signal 'wrong-type-argument (list tag 'semantic-tag-faux-p))) + (:override) + ) + +(defun semantic-tag-external-class-default (tag) + "Return a list of real tags that faux TAG might represent. +See `semantic-tag-external-class' for details." + (if (and (require 'semantic/db-mode) + (semanticdb-minor-mode-p)) + (let* ((semanticdb-search-system-databases nil) + (m (semanticdb-find-tags-by-class + (semantic-tag-class tag) + (semanticdb-find-tags-by-name (semantic-tag-name tag))))) + (semanticdb-strip-find-results m 'name)) + ;; Presumably, if the tag is faux, it is not local. + nil)) + +(provide 'semantic/sort) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/sort" +;; End: + +;;; semantic-sort.el ends here diff --git a/lisp/cedet/semantic/symref.el b/lisp/cedet/semantic/symref.el new file mode 100644 index 00000000000..bea148b1c21 --- /dev/null +++ b/lisp/cedet/semantic/symref.el @@ -0,0 +1,501 @@ +;;; semantic/symref.el --- Symbol Reference API + +;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic Symbol Reference API. +;; +;; Semantic's native parsing tools do not handle symbol references. +;; Tracking such information is a task that requires a huge amount of +;; space and processing not apropriate for an Emacs Lisp program. +;; +;; Many desired tools used in refactoring, however, need to have +;; such references available to them. This API aims to provide a +;; range of functions that can be used to identify references. The +;; API is backed by an OO system that is used to allow multiple +;; external tools to provide the information. +;; +;; The default implementation uses a find/grep combination to do a +;; search. This works ok in small projects. For larger projects, it +;; is important to find an alternate tool to use as a back-end to +;; symref. +;; +;; See the command: `semantic-symref' for an example app using this api. +;; +;; TO USE THIS TOOL +;; +;; The following functions can be used to find different kinds of +;; references. +;; +;; `semantic-symref-find-references-by-name' +;; `semantic-symref-find-file-references-by-name' +;; `semantic-symref-find-text' +;; +;; All the search routines return a class of type +;; `semantic-symref-result'. You can reference the various slots, but +;; you will need the following methods to get extended information. +;; +;; `semantic-symref-result-get-files' +;; `semantic-symref-result-get-tags' +;; +;; ADD A NEW EXTERNAL TOOL +;; +;; To support a new external tool, sublcass `semantic-symref-tool-baseclass' +;; and implement the methods. The baseclass provides support for +;; managing external processes that produce parsable output. +;; +;; Your tool should then create an instance of `semantic-symref-result'. + +(require 'semantic) + +(defvar ede-minor-mode) +(declare-function data-debug-new-buffer "data-debug") +(declare-function data-debug-insert-object-slots "eieio-datadebug") +(declare-function ede-toplevel "ede/files") +(declare-function ede-project-root-directory "ede/files") + +;;; Code: +(defvar semantic-symref-tool 'detect + "*The active symbol reference tool name. +The tool symbol can be 'detect, or a symbol that is the name of +a tool that can be used for symbol referencing.") +(make-variable-buffer-local 'semantic-symref-tool) + +;;; TOOL SETUP +;; +(defvar semantic-symref-tool-alist + '( ( (lambda (rootdir) (file-exists-p (expand-file-name "GPATH" rootdir))) . + global) + ( (lambda (rootdir) (file-exists-p (expand-file-name "ID" rootdir))) . + idutils) + ( (lambda (rootdir) (file-exists-p (expand-file-name "cscope.out" rootdir))) . + cscope ) + ) + "Alist of tools usable by `semantic-symref'. +Each entry is of the form: + ( PREDICATE . KEY ) +Where PREDICATE is a function that takes a directory name for the +root of a project, and returns non-nil if the tool represented by KEY +is supported. + +If no tools are supported, then 'grep is assumed.") + +(defun semantic-symref-detect-symref-tool () + "Detect the symref tool to use for the current buffer." + (if (not (eq semantic-symref-tool 'detect)) + semantic-symref-tool + ;; We are to perform a detection for the right tool to use. + (let* ((rootproj (when (and (featurep 'ede) ede-minor-mode) + (ede-toplevel))) + (rootdir (if rootproj + (ede-project-root-directory rootproj) + default-directory)) + (tools semantic-symref-tool-alist)) + (while (and tools (eq semantic-symref-tool 'detect)) + (when (funcall (car (car tools)) rootdir) + (setq semantic-symref-tool (cdr (car tools)))) + (setq tools (cdr tools))) + + (when (eq semantic-symref-tool 'detect) + (setq semantic-symref-tool 'grep)) + + semantic-symref-tool))) + +(defun semantic-symref-instantiate (&rest args) + "Instantiate a new symref search object. +ARGS are the initialization arguments to pass to the created class." + (let* ((srt (symbol-name (semantic-symref-detect-symref-tool))) + (class (intern-soft (concat "semantic-symref-tool-" srt))) + (inst nil) + ) + (when (not (class-p class)) + (error "Unknown symref tool %s" semantic-symref-tool)) + (setq inst (apply 'make-instance class args)) + inst)) + +(defvar semantic-symref-last-result nil + "The last calculated symref result.") + +(defun semantic-symref-data-debug-last-result () + "Run the last symref data result in Data Debug." + (interactive) + (require 'eieio-datadebug) + (if semantic-symref-last-result + (progn + (data-debug-new-buffer "*Symbol Reference ADEBUG*") + (data-debug-insert-object-slots semantic-symref-last-result "]")) + (message "Empty results."))) + +;;; EXTERNAL API +;; + +;;;###autoload +(defun semantic-symref-find-references-by-name (name &optional scope tool-return) + "Find a list of references to NAME in the current project. +Optional SCOPE specifies which file set to search. Defaults to 'project. +Refers to `semantic-symref-tool', to determine the reference tool to use +for the current buffer. +Returns an object of class `semantic-symref-result'. +TOOL-RETURN is an optional symbol, which will be assigned the tool used +to perform the search. This was added for use by a test harness." + (interactive "sName: ") + (let* ((inst (semantic-symref-instantiate + :searchfor name + :searchtype 'symbol + :searchscope (or scope 'project) + :resulttype 'line)) + (result (semantic-symref-get-result inst))) + (when tool-return + (set tool-return inst)) + (prog1 + (setq semantic-symref-last-result result) + (when (interactive-p) + (semantic-symref-data-debug-last-result)))) + ) + +;;;###autoload +(defun semantic-symref-find-tags-by-name (name &optional scope) + "Find a list of references to NAME in the current project. +Optional SCOPE specifies which file set to search. Defaults to 'project. +Refers to `semantic-symref-tool', to determine the reference tool to use +for the current buffer. +Returns an object of class `semantic-symref-result'." + (interactive "sName: ") + (let* ((inst (semantic-symref-instantiate + :searchfor name + :searchtype 'tagname + :searchscope (or scope 'project) + :resulttype 'line)) + (result (semantic-symref-get-result inst))) + (prog1 + (setq semantic-symref-last-result result) + (when (interactive-p) + (semantic-symref-data-debug-last-result)))) + ) + +;;;###autoload +(defun semantic-symref-find-tags-by-regexp (name &optional scope) + "Find a list of references to NAME in the current project. +Optional SCOPE specifies which file set to search. Defaults to 'project. +Refers to `semantic-symref-tool', to determine the reference tool to use +for the current buffer. +Returns an object of class `semantic-symref-result'." + (interactive "sName: ") + (let* ((inst (semantic-symref-instantiate + :searchfor name + :searchtype 'tagregexp + :searchscope (or scope 'project) + :resulttype 'line)) + (result (semantic-symref-get-result inst))) + (prog1 + (setq semantic-symref-last-result result) + (when (interactive-p) + (semantic-symref-data-debug-last-result)))) + ) + +;;;###autoload +(defun semantic-symref-find-tags-by-completion (name &optional scope) + "Find a list of references to NAME in the current project. +Optional SCOPE specifies which file set to search. Defaults to 'project. +Refers to `semantic-symref-tool', to determine the reference tool to use +for the current buffer. +Returns an object of class `semantic-symref-result'." + (interactive "sName: ") + (let* ((inst (semantic-symref-instantiate + :searchfor name + :searchtype 'tagcompletions + :searchscope (or scope 'project) + :resulttype 'line)) + (result (semantic-symref-get-result inst))) + (prog1 + (setq semantic-symref-last-result result) + (when (interactive-p) + (semantic-symref-data-debug-last-result)))) + ) + +;;;###autoload +(defun semantic-symref-find-file-references-by-name (name &optional scope) + "Find a list of references to NAME in the current project. +Optional SCOPE specifies which file set to search. Defaults to 'project. +Refers to `semantic-symref-tool', to determine the reference tool to use +for the current buffer. +Returns an object of class `semantic-symref-result'." + (interactive "sName: ") + (let* ((inst (semantic-symref-instantiate + :searchfor name + :searchtype 'regexp + :searchscope (or scope 'project) + :resulttype 'file)) + (result (semantic-symref-get-result inst))) + (prog1 + (setq semantic-symref-last-result result) + (when (interactive-p) + (semantic-symref-data-debug-last-result)))) + ) + +;;;###autoload +(defun semantic-symref-find-text (text &optional scope) + "Find a list of occurances of TEXT in the current project. +TEXT is a regexp formatted for use with egrep. +Optional SCOPE specifies which file set to search. Defaults to 'project. +Refers to `semantic-symref-tool', to determine the reference tool to use +for the current buffer. +Returns an object of class `semantic-symref-result'." + (interactive "sEgrep style Regexp: ") + (let* ((inst (semantic-symref-instantiate + :searchfor text + :searchtype 'regexp + :searchscope (or scope 'project) + :resulttype 'line)) + (result (semantic-symref-get-result inst))) + (prog1 + (setq semantic-symref-last-result result) + (when (interactive-p) + (semantic-symref-data-debug-last-result)))) + ) + +;;; RESULTS +;; +;; The results class and methods provide features for accessing hits. +(defclass semantic-symref-result () + ((created-by :initarg :created-by + :type semantic-symref-tool-baseclass + :documentation + "Back-pointer to the symref tool creating these results.") + (hit-files :initarg :hit-files + :type list + :documentation + "The list of files hit.") + (hit-text :initarg :hit-text + :type list + :documentation + "If the result doesn't provide full lines, then fill in hit-text. +GNU Global does completion search this way.") + (hit-lines :initarg :hit-lines + :type list + :documentation + "The list of line hits. +Each element is a cons cell of the form (LINE . FILENAME).") + (hit-tags :initarg :hit-tags + :type list + :documentation + "The list of tags with hits in them. +Use the `semantic-symref-hit-tags' method to get this list.") + ) + "The results from a symbol reference search.") + +(defmethod semantic-symref-result-get-files ((result semantic-symref-result)) + "Get the list of files from the symref result RESULT." + (if (slot-boundp result :hit-files) + (oref result hit-files) + (let* ((lines (oref result :hit-lines)) + (files (mapcar (lambda (a) (cdr a)) lines)) + (ans nil)) + (setq ans (list (car files)) + files (cdr files)) + (dolist (F files) + ;; This algorithm for uniqing the file list depends on the + ;; tool in question providing all the hits in the same file + ;; grouped together. + (when (not (string= F (car ans))) + (setq ans (cons F ans)))) + (oset result hit-files (nreverse ans)) + ) + )) + +(defmethod semantic-symref-result-get-tags ((result semantic-symref-result) + &optional open-buffers) + "Get the list of tags from the symref result RESULT. +Optional OPEN-BUFFERS indicates that the buffers that the hits are +in should remain open after scanning. +Note: This can be quite slow if most of the hits are not in buffers +already." + (if (and (slot-boundp result :hit-tags) (oref result hit-tags)) + (oref result hit-tags) + ;; Calculate the tags. + (let ((lines (oref result :hit-lines)) + (txt (oref (oref result :created-by) :searchfor)) + (searchtype (oref (oref result :created-by) :searchtype)) + (ans nil) + (out nil) + (buffs-to-kill nil)) + (save-excursion + (setq + ans + (mapcar + (lambda (hit) + (let* ((line (car hit)) + (file (cdr hit)) + (buff (get-file-buffer file)) + (tag nil) + ) + (cond + ;; We have a buffer already. Check it out. + (buff + (set-buffer buff)) + + ;; We have a table, but it needs a refresh. + ;; This means we should load in that buffer. + (t + (let ((kbuff + (if open-buffers + ;; Even if we keep the buffers open, don't + ;; let EDE ask lots of questions. + (let ((ede-auto-add-method 'never)) + (find-file-noselect file t)) + ;; When not keeping the buffers open, then + ;; don't setup all the fancy froo-froo features + ;; either. + (semantic-find-file-noselect file t)))) + (set-buffer kbuff) + (setq buffs-to-kill (cons kbuff buffs-to-kill)) + (semantic-fetch-tags) + )) + ) + + ;; Too much baggage in goto-line + ;; (goto-line line) + (goto-char (point-min)) + (forward-line (1- line)) + + ;; Search forward for the matching text + (re-search-forward (regexp-quote txt) + (point-at-eol) + t) + + (setq tag (semantic-current-tag)) + + ;; If we are searching for a tag, but bound the tag we are looking + ;; for, see if it resides in some other parent tag. + ;; + ;; If there is no parent tag, then we still need to hang the originator + ;; in our list. + (when (and (eq searchtype 'symbol) + (string= (semantic-tag-name tag) txt)) + (setq tag (or (semantic-current-tag-parent) tag))) + + ;; Copy the tag, which adds a :filename property. + (when tag + (setq tag (semantic-tag-copy tag nil t)) + ;; Ad this hit to the tag. + (semantic--tag-put-property tag :hit (list line))) + tag)) + lines))) + ;; Kill off dead buffers, unless we were requested to leave them open. + (when (not open-buffers) + (mapc 'kill-buffer buffs-to-kill)) + ;; Strip out duplicates. + (dolist (T ans) + (if (and T (not (semantic-equivalent-tag-p (car out) T))) + (setq out (cons T out)) + (when T + ;; Else, add this line into the existing list of lines. + (let ((lines (append (semantic--tag-get-property (car out) :hit) + (semantic--tag-get-property T :hit)))) + (semantic--tag-put-property (car out) :hit lines))) + )) + ;; Out is reversed... twice + (oset result :hit-tags (nreverse out))))) + +;;; SYMREF TOOLS +;; +;; The base symref tool provides something to hang new tools off of +;; for finding symbol references. +(defclass semantic-symref-tool-baseclass () + ((searchfor :initarg :searchfor + :type string + :documentation "The thing to search for.") + (searchtype :initarg :searchtype + :type symbol + :documentation "The type of search to do. +Values could be `symbol, `regexp, 'tagname, or 'completion.") + (searchscope :initarg :searchscope + :type symbol + :documentation + "The scope to search for. +Can be 'project, 'target, or 'file.") + (resulttype :initarg :resulttype + :type symbol + :documentation + "The kind of search results desired. +Can be 'line, 'file, or 'tag. +The type of result can be converted from 'line to 'file, or 'line to 'tag, +but not from 'file to 'line or 'tag.") + ) + "Baseclass for all symbol references tools. +A symbol reference tool supplies functionality to identify the locations of +where different symbols are used. + +Subclasses should be named `semantic-symref-tool-NAME', where +NAME is the name of the tool used in the configuration variable +`semantic-symref-tool'" + :abstract t) + +(defmethod semantic-symref-get-result ((tool semantic-symref-tool-baseclass)) + "Calculate the results of a search based on TOOL. +The symref TOOL should already contain the search criteria." + (let ((answer (semantic-symref-perform-search tool)) + ) + (when answer + (let ((answersym (if (eq (oref tool :resulttype) 'file) + :hit-files + (if (stringp (car answer)) + :hit-text + :hit-lines)))) + (semantic-symref-result (oref tool searchfor) + answersym + answer + :created-by tool)) + ) + )) + +(defmethod semantic-symref-perform-search ((tool semantic-symref-tool-baseclass)) + "Base search for symref tools should throw an error." + (error "Symref tool objects must implement `semantic-symref-perform-search'")) + +(defmethod semantic-symref-parse-tool-output ((tool semantic-symref-tool-baseclass) + outputbuffer) + "Parse the entire OUTPUTBUFFER of a symref tool. +Calls the method `semantic-symref-parse-tool-output-one-line' over and +over until it returns nil." + (save-excursion + (set-buffer outputbuffer) + (goto-char (point-min)) + (let ((result nil) + (hit nil)) + (while (setq hit (semantic-symref-parse-tool-output-one-line tool)) + (setq result (cons hit result))) + (nreverse result))) + ) + +(defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-baseclass)) + "Base tool output parser is not implemented." + (error "Symref tool objects must implement `semantic-symref-parse-tool-output-one-line'")) + +(provide 'semantic/symref) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/symref" +;; End: + +;;; semantic/symref.el ends here diff --git a/lisp/cedet/semantic/symref/cscope.el b/lisp/cedet/semantic/symref/cscope.el new file mode 100644 index 00000000000..9c9af7c67dd --- /dev/null +++ b/lisp/cedet/semantic/symref/cscope.el @@ -0,0 +1,95 @@ +;;; semantic/symref/cscope.el --- Semantic-symref support via cscope. + +;;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic symref support via cscope. + +(require 'cedet-cscope) +(require 'semantic/symref) + +(defvar ede-minor-mode) +(declare-function ede-toplevel "ede/files") +(declare-function ede-project-root-directory "ede/files") + +;;; Code: +;;;###autoload +(defclass semantic-symref-tool-cscope (semantic-symref-tool-baseclass) + ( + ) + "A symref tool implementation using CScope. +The CScope command can be used to generate lists of tags in a way +similar to that of `grep'. This tool will parse the output to generate +the hit list. + +See the function `cedet-cscope-search' for more details.") + +(defmethod semantic-symref-perform-search ((tool semantic-symref-tool-cscope)) + "Perform a search with GNU Global." + (let* ((rootproj (when (and (featurep 'ede) ede-minor-mode) + (ede-toplevel))) + (default-directory (if rootproj + (ede-project-root-directory rootproj) + default-directory)) + ;; CScope has to be run from the project root where + ;; cscope.out is. + (b (cedet-cscope-search (oref tool :searchfor) + (oref tool :searchtype) + (oref tool :resulttype) + (oref tool :searchscope) + )) + ) + (semantic-symref-parse-tool-output tool b) + )) + +(defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-cscope)) + "Parse one line of grep output, and return it as a match list. +Moves cursor to end of the match." + (cond ((eq (oref tool :resulttype) 'file) + ;; Search for files + (when (re-search-forward "^\\([^\n]+\\)$" nil t) + (match-string 1))) + ((eq (oref tool :searchtype) 'tagcompletions) + ;; Search for files + (when (re-search-forward "^[^ ]+ [^ ]+ [^ ]+ \\(.*\\)$" nil t) + (let ((subtxt (match-string 1)) + (searchtxt (oref tool :searchfor))) + (if (string-match (concat "\\<" searchtxt "\\(\\w\\|\\s_\\)*\\>") + subtxt) + (match-string 0 subtxt) + ;; We have to return something at this point. + subtxt))) + ) + (t + (when (re-search-forward "^\\([^ ]+\\) [^ ]+ \\([0-9]+\\) " nil t) + (cons (string-to-number (match-string 2)) + (expand-file-name (match-string 1))) + )))) + +(provide 'semantic/symref/cscope) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/symref/cscope" +;; End: + +;;; semantic/symref/cscope.el ends here diff --git a/lisp/cedet/semantic/symref/filter.el b/lisp/cedet/semantic/symref/filter.el new file mode 100644 index 00000000000..97e5c92a6ab --- /dev/null +++ b/lisp/cedet/semantic/symref/filter.el @@ -0,0 +1,140 @@ +;;; semantic/symref/filter.el --- Filter symbol reference hits for accuracy. + +;;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Filter symbol reference hits for accuracy. +;; +;; Most symbol referencing tools, such as find/grep only find matching +;; strings, but cannot determine the difference between an actual use, +;; and something else with a similar name, or even a string in a comment. +;; +;; This file provides utilities for filtering down to accurate matches +;; starting at a basic filter level that doesn't use symref, up to filters +;; across symref results. + +;;; Code: + +(require 'semantic) +(require 'semantic/analyze) +(declare-function srecode-active-template-region "srecode/fields") +(declare-function srecode-delete "srecode/fields") +(declare-function srecode-field "srecode/fields") +(declare-function srecode-template-inserted-region "srecode/fields") +(declare-function srecode-overlaid-activate "srecode/fields") +(declare-function semantic-idle-summary-useful-context-p "semantic/idle") + +;;; FILTERS +;; +(defun semantic-symref-filter-hit (target &optional position) + "Determine if the tag TARGET is used at POSITION in the current buffer. +Return non-nil for a match." + (semantic-analyze-current-symbol + (lambda (start end prefix) + (let ((tag (car (nreverse prefix)))) + (and (semantic-tag-p tag) + (semantic-equivalent-tag-p target tag)))) + position)) + +;;; IN-BUFFER FILTERING + +;; The following does filtering in-buffer only, and not against +;; a symref results object. + +(defun semantic-symref-hits-in-region (target hookfcn start end) + "Find all occurances of the symbol TARGET that match TARGET the tag. +For each match, call HOOKFCN. +HOOKFCN takes three arguments that match +`semantic-analyze-current-symbol's use of HOOKfCN. + ( START END PREFIX ) + +Search occurs in the current buffer between START and END." + (require 'semantic/idle) + (save-excursion + (goto-char start) + (let* ((str (semantic-tag-name target)) + (case-fold-search semantic-case-fold) + (regexp (concat "\\<" (regexp-quote str) "\\>"))) + (while (re-search-forward regexp end t) + (when (semantic-idle-summary-useful-context-p) + (semantic-analyze-current-symbol + (lambda (start end prefix) + (let ((tag (car (nreverse prefix)))) + ;; check for semantic match on the text match. + (when (and (semantic-tag-p tag) + (semantic-equivalent-tag-p target tag)) + (save-excursion + (funcall hookfcn start end prefix))))) + (point))))))) + +(defun semantic-symref-rename-local-variable () + "Fancy way to rename the local variable under point. +Depends on the SRecode Field editing API." + (interactive) + ;; Do the replacement as needed. + (let* ((ctxt (semantic-analyze-current-context)) + (target (car (reverse (oref ctxt prefix)))) + (tag (semantic-current-tag)) + ) + + (when (or (not target) + (not (semantic-tag-with-position-p target))) + (error "Cannot identify symbol under point")) + + (when (not (semantic-tag-of-class-p target 'variable)) + (error "Can only rename variables")) + + (when (or (< (semantic-tag-start target) (semantic-tag-start tag)) + (> (semantic-tag-end target) (semantic-tag-end tag))) + (error "Can only rename variables declared in %s" + (semantic-tag-name tag))) + + ;; I think we're good for this example. Give it a go through + ;; our fancy interface from SRecode. + (require 'srecode/fields) + + ;; Make sure there is nothing active. + (let ((ar (srecode-active-template-region))) + (when ar (srecode-delete ar))) + + (let ((srecode-field-archive nil) + (region nil) + ) + (semantic-symref-hits-in-region + target (lambda (start end prefix) + ;; For every valid hit, create one field. + (srecode-field "LOCAL" :name "LOCAL" :start start :end end)) + (semantic-tag-start tag) (semantic-tag-end tag)) + + ;; Now that the fields are setup, create the region. + (setq region (srecode-template-inserted-region + "REGION" :start (semantic-tag-start tag) + :end (semantic-tag-end tag))) + + ;; Activate the region. + (srecode-overlaid-activate region) + + ) + )) + +(provide 'semantic/symref/filter) + +;;; semantic/symref/filter.el ends here diff --git a/lisp/cedet/semantic/symref/global.el b/lisp/cedet/semantic/symref/global.el new file mode 100644 index 00000000000..de3f7a552de --- /dev/null +++ b/lisp/cedet/semantic/symref/global.el @@ -0,0 +1,76 @@ +;;; semantic/symref/global.el --- Use GNU Global for symbol references + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric Ludlam <eludlam@mathworks.com> + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; GNU Global use with the semantic-symref system. + +(require 'cedet-global) +(require 'semantic/symref) + +;;; Code: +;;;###autoload +(defclass semantic-symref-tool-global (semantic-symref-tool-baseclass) + ( + ) + "A symref tool implementation using GNU Global. +The GNU Global command can be used to generate lists of tags in a way +similar to that of `grep'. This tool will parse the output to generate +the hit list. + +See the function `cedet-gnu-global-search' for more details.") + +(defmethod semantic-symref-perform-search ((tool semantic-symref-tool-global)) + "Perform a search with GNU Global." + (let ((b (cedet-gnu-global-search (oref tool :searchfor) + (oref tool :searchtype) + (oref tool :resulttype) + (oref tool :searchscope) + )) + ) + (semantic-symref-parse-tool-output tool b) + )) + +(defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-global)) + "Parse one line of grep output, and return it as a match list. +Moves cursor to end of the match." + (cond ((or (eq (oref tool :resulttype) 'file) + (eq (oref tool :searchtype) 'tagcompletions)) + ;; Search for files + (when (re-search-forward "^\\([^\n]+\\)$" nil t) + (match-string 1))) + (t + (when (re-search-forward "^\\([^ ]+\\) +\\([0-9]+\\) \\([^ ]+\\) " nil t) + (cons (string-to-number (match-string 2)) + (match-string 3)) + )))) + +(provide 'semantic/symref/global) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/symref/global" +;; End: + +;;; semantic/symref/global.el ends here diff --git a/lisp/cedet/semantic/symref/grep.el b/lisp/cedet/semantic/symref/grep.el new file mode 100644 index 00000000000..3033a41faaf --- /dev/null +++ b/lisp/cedet/semantic/symref/grep.el @@ -0,0 +1,202 @@ +;;; semantic/symref/grep.el --- Symref implementation using find/grep + +;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Implement the symref tool API using the external tools find/grep. +;; +;; The symref GREP tool uses grep in a project to find symbol references. +;; This is a lowest-common-denominator tool with sucky performance that +;; can be used in small projects to find symbol references. + +(require 'semantic/symref) +(require 'grep) + +(defvar ede-minor-mode) +(declare-function ede-toplevel "ede/files") +(declare-function ede-project-root-directory "ede/files") + +;;; Code: + +;;; GREP +;;;###autoload +(defclass semantic-symref-tool-grep (semantic-symref-tool-baseclass) + ( + ) + "A symref tool implementation using grep. +This tool uses EDE to find he root of the project, then executes +find-grep in the project. The output is parsed for hits +and those hits returned.") + +(defvar semantic-symref-filepattern-alist + '((c-mode "*.[ch]") + (c++-mode "*.[chCH]" "*.[ch]pp" "*.cc" "*.hh") + (html-mode "*.s?html" "*.php") + ) + "List of major modes and file extension pattern regexp. +See find -regex man page for format.") + +(defun semantic-symref-derive-find-filepatterns (&optional mode) + "Derive a list of file patterns for the current buffer. +Looks first in `semantic-symref-filepattern-alist'. If it is not +there, it then looks in `auto-mode-alist', and attempts to derive something +from that. +Optional argument MODE specifies the `major-mode' to test." + ;; First, try the filepattern alist. + (let* ((mode (or mode major-mode)) + (pat (cdr (assoc mode semantic-symref-filepattern-alist)))) + (when (not pat) + ;; No hit, try auto-mode-alist. + (dolist (X auto-mode-alist) + (when (eq (cdr X) mode) + ;; Only take in simple patterns, so try to convert this one. + (let ((Xp + (cond ((string-match "\\\\\\.\\([^\\'>]+\\)\\\\'" (car X)) + (concat "*." (match-string 1 (car X)))) + (t nil)))) + (when Xp + (setq pat (cons Xp pat)))) + ))) + ;; Convert the list into some find-flags. + (cond ((= (length pat) 1) + (concat "-name \"" (car pat) "\"")) + ((consp pat) + (concat "\\( " + (mapconcat (lambda (s) + (concat "-name \"" s "\"")) + pat + " -o ") + " \\)")) + (t + (error "Configuration for `semantic-symref-tool-grep' needed for %s" major-mode)) + ))) + +(defvar semantic-symref-grep-expand-keywords + (condition-case nil + (let* ((kw (copy-alist grep-expand-keywords)) + (C (assoc "<C>" kw)) + (R (assoc "<R>" kw))) + (setcdr C 'grepflags) + (setcdr R 'greppattern) + kw) + (error nil)) + "Grep expand keywords used when expanding templates for symref.") + +(defun semantic-symref-grep-use-template (rootdir filepattern grepflags greppattern) + "Use the grep template expand feature to create a grep command. +ROOTDIR is the root location to run the `find' from. +FILEPATTERN is a string represeting find flags for searching file patterns. +GREPFLAGS are flags passed to grep, such as -n or -l. +GREPPATTERN is the pattren used by grep." + ;; We have grep-compute-defaults. Lets use it. + (grep-compute-defaults) + (let* ((grep-expand-keywords semantic-symref-grep-expand-keywords) + (cmd (grep-expand-template grep-find-template + greppattern + filepattern + rootdir))) + ;; For some reason, my default has no <D> in it. + (when (string-match "find \\(\\.\\)" cmd) + (setq cmd (replace-match rootdir t t cmd 1))) + ;;(message "New command: %s" cmd) + cmd)) + +(defmethod semantic-symref-perform-search ((tool semantic-symref-tool-grep)) + "Perform a search with Grep." + ;; Grep doesn't support some types of searches. + (let ((st (oref tool :searchtype))) + (when (not (eq st 'symbol)) + (error "Symref impl GREP does not support searchtype of %s" st)) + ) + ;; Find the root of the project, and do a find-grep... + (let* (;; Find the file patterns to use. + (pat (cdr (assoc major-mode semantic-symref-filepattern-alist))) + (rootdir (cond + ;; Project root via EDE. + ((eq (oref tool :searchscope) 'project) + (let ((rootproj (when (and (featurep 'ede) ede-minor-mode) + (ede-toplevel)))) + (if rootproj + (ede-project-root-directory rootproj) + default-directory))) + ;; Calculate the target files as just in + ;; this directory... cause I'm lazy. + ((eq (oref tool :searchscope) 'target) + default-directory) + )) + (filepattern (semantic-symref-derive-find-filepatterns)) + ;; Grep based flags. + (grepflags (cond ((eq (oref tool :resulttype) 'file) + "-l ") + (t "-n "))) + (greppat (cond ((eq (oref tool :searchtype) 'regexp) + (oref tool searchfor)) + (t + (concat "'\\<" (oref tool searchfor) "\\>'")))) + ;; Misc + (b (get-buffer-create "*Semantic SymRef*")) + (ans nil) + ) + + (save-excursion + (set-buffer b) + (erase-buffer) + (setq default-directory rootdir) + + (if (not (fboundp 'grep-compute-defaults)) + + ;; find . -type f -print0 | xargs -0 -e grep -nH -e + ;; Note : I removed -e as it is not posix, nor necessary it seems. + + (let ((cmd (concat "find " default-directory " -type f " filepattern " -print0 " + "| xargs -0 grep -H " grepflags "-e " greppat))) + ;;(message "Old command: %s" cmd) + (call-process "sh" nil b nil "-c" cmd) + ) + (let ((cmd (semantic-symref-grep-use-template rootdir filepattern grepflags greppat))) + (call-process "sh" nil b nil "-c" cmd)) + )) + (setq ans (semantic-symref-parse-tool-output tool b)) + ;; Return the answer + ans)) + +(defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-grep)) + "Parse one line of grep output, and return it as a match list. +Moves cursor to end of the match." + (cond ((eq (oref tool :resulttype) 'file) + ;; Search for files + (when (re-search-forward "^\\([^\n]+\\)$" nil t) + (match-string 1))) + (t + (when (re-search-forward "^\\(\\(?:[a-zA-Z]:\\)?[^:\n]+\\):\\([0-9]+\\):" nil t) + (cons (string-to-number (match-string 2)) + (match-string 1)) + )))) + +(provide 'semantic/symref/grep) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/symref/grep" +;; End: + +;;; semantic/symref/grep.el ends here diff --git a/lisp/cedet/semantic/symref/idutils.el b/lisp/cedet/semantic/symref/idutils.el new file mode 100644 index 00000000000..e94084e6f2d --- /dev/null +++ b/lisp/cedet/semantic/symref/idutils.el @@ -0,0 +1,78 @@ +;;; semantic/symref/idutils.el --- Symref implementation for idutils + +;;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is 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 program 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: +;; +;; Support IDUtils use in the Semantic Symref tool. + +(require 'cedet-idutils) +(require 'semantic/symref) + +;;; Code: +;;;###autoload +(defclass semantic-symref-tool-idutils (semantic-symref-tool-baseclass) + ( + ) + "A symref tool implementation using ID Utils. +The udutils command set can be used to generate lists of tags in a way +similar to that of `grep'. This tool will parse the output to generate +the hit list. + +See the function `cedet-idutils-search' for more details.") + +(defmethod semantic-symref-perform-search ((tool semantic-symref-tool-idutils)) + "Perform a search with IDUtils." + (let ((b (cedet-idutils-search (oref tool :searchfor) + (oref tool :searchtype) + (oref tool :resulttype) + (oref tool :searchscope) + )) + ) + (semantic-symref-parse-tool-output tool b) + )) + +(defmethod semantic-symref-parse-tool-output-one-line ((tool semantic-symref-tool-idutils)) + "Parse one line of grep output, and return it as a match list. +Moves cursor to end of the match." + (cond ((eq (oref tool :resulttype) 'file) + ;; Search for files + (when (re-search-forward "^\\([^\n]+\\)$" nil t) + (match-string 1))) + ((eq (oref tool :searchtype) 'tagcompletions) + (when (re-search-forward "^\\([^ ]+\\) " nil t) + (match-string 1))) + (t + (when (re-search-forward "^\\([^ :]+\\):+\\([0-9]+\\):" nil t) + (cons (string-to-number (match-string 2)) + (expand-file-name (match-string 1) default-directory)) + )))) + +(provide 'semantic/symref/idutils) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/symref/idutils" +;; End: + +;;; semantic/symref/idutils.el ends here diff --git a/lisp/cedet/semantic/symref/list.el b/lisp/cedet/semantic/symref/list.el new file mode 100644 index 00000000000..08d2478283b --- /dev/null +++ b/lisp/cedet/semantic/symref/list.el @@ -0,0 +1,337 @@ +;;; semantic/symref/list.el --- Symref Output List UI. + +;;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is 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 program 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 this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: +;; +;; Provide a simple user facing API to finding symbol references. +;; +;; This UI will is the base of some refactoring tools. For any +;; refactor, the user will execture `semantic-symref' in a tag. Once +;; that data is collected, the output will be listed in a buffer. In +;; the output buffer, the user can then initiate different refactoring +;; operations. +;; +;; NOTE: Need to add some refactoring tools. + +(require 'semantic/symref) +(require 'semantic/complete) +(require 'pulse) + +;;; Code: + +;;;###autoload +(defun semantic-symref () + "Find references to the current tag. +This command uses the currently configured references tool within the +current project to find references to the current tag. The +references are the organized by file and the name of the function +they are used in. +Display the references in`semantic-symref-results-mode'" + (interactive) + (semantic-fetch-tags) + (let ((ct (semantic-current-tag)) + (res nil) + ) + ;; Must have a tag... + (when (not ct) (error "Place cursor inside tag to be searched for")) + ;; Check w/ user. + (when (not (y-or-n-p (format "Find references for %s? " (semantic-tag-name ct)))) + (error "Quit")) + ;; Gather results and tags + (message "Gathering References...") + (setq res (semantic-symref-find-references-by-name (semantic-tag-name ct))) + (semantic-symref-produce-list-on-results res (semantic-tag-name ct)))) + +;;;###autoload +(defun semantic-symref-symbol (sym) + "Find references to the symbol SYM. +This command uses the currently configured references tool within the +current project to find references to the input SYM. The +references are the organized by file and the name of the function +they are used in. +Display the references in`semantic-symref-results-mode'" + (interactive (list (semantic-tag-name (semantic-complete-read-tag-buffer-deep + "Symrefs for: ")))) + (semantic-fetch-tags) + (let ((res nil) + ) + ;; Gather results and tags + (message "Gathering References...") + (setq res (semantic-symref-find-references-by-name sym)) + (semantic-symref-produce-list-on-results res sym))) + + +(defun semantic-symref-produce-list-on-results (res str) + "Produce a symref list mode buffer on the results RES." + (when (not res) (error "No references found")) + (semantic-symref-result-get-tags res t) + (message "Gathering References...done") + ;; Build a refrences buffer. + (let ((buff (get-buffer-create + (format "*Symref %s" str))) + ) + (switch-to-buffer-other-window buff) + (set-buffer buff) + (semantic-symref-results-mode res)) + ) + +;;; RESULTS MODE +;; +(defgroup semantic-symref-results-mode nil + "Symref Results group." + :group 'semantic) + +(defvar semantic-symref-results-mode-map + (let ((km (make-sparse-keymap))) + (define-key km "\C-i" 'forward-button) + (define-key km "\M-C-i" 'backward-button) + (define-key km " " 'push-button) + (define-key km "-" 'semantic-symref-list-toggle-showing) + (define-key km "=" 'semantic-symref-list-toggle-showing) + (define-key km "+" 'semantic-symref-list-toggle-showing) + (define-key km "n" 'semantic-symref-list-next-line) + (define-key km "p" 'semantic-symref-list-prev-line) + (define-key km "q" 'semantic-symref-hide-buffer) + km) + "Keymap used in `semantic-symref-results-mode'.") + +(defcustom semantic-symref-results-mode-hook nil + "*Hook run when `semantic-symref-results-mode' starts." + :group 'semantic-symref + :type 'hook) + +(defvar semantic-symref-current-results nil + "The current results in a results mode buffer.") + +(defun semantic-symref-results-mode (results) + "Major-mode for displaying Semantic Symbol Reference RESULTS. +RESULTS is an object of class `semantic-symref-results'." + (interactive) + (kill-all-local-variables) + (setq major-mode 'semantic-symref-results-mode + mode-name "Symref" + ) + (use-local-map semantic-symref-results-mode-map) + (set (make-local-variable 'semantic-symref-current-results) + results) + (semantic-symref-results-dump results) + (goto-char (point-min)) + (buffer-disable-undo) + (set (make-local-variable 'font-lock-global-modes) nil) + (font-lock-mode -1) + (run-hooks 'semantic-symref-results-mode-hook) + ) + +(defun semantic-symref-hide-buffer () + "Hide buffer with sematinc-symref results" + (interactive) + (bury-buffer)) + +(defcustom semantic-symref-results-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-symref + :type semantic-format-tag-custom-list) + +(defun semantic-symref-results-dump (results) + "Dump the RESULTS into the current buffer." + ;; Get ready for the insert. + (toggle-read-only -1) + (erase-buffer) + + ;; Insert the contents. + (let ((lastfile nil) + ) + (dolist (T (oref results :hit-tags)) + + (when (not (equal lastfile (semantic-tag-file-name T))) + (setq lastfile (semantic-tag-file-name T)) + (insert-button lastfile + 'mouse-face 'custom-button-pressed-face + 'action 'semantic-symref-rb-goto-file + 'tag T + ) + (insert "\n")) + + (insert " ") + (insert-button "[+]" + 'mouse-face 'highlight + 'face nil + 'action 'semantic-symref-rb-toggle-expand-tag + 'tag T + 'state 'closed) + (insert " ") + (insert-button (funcall semantic-symref-results-summary-function + T nil t) + 'mouse-face 'custom-button-pressed-face + 'face nil + 'action 'semantic-symref-rb-goto-tag + 'tag T) + (insert "\n") + + )) + + ;; Clean up the mess + (toggle-read-only 1) + (set-buffer-modified-p nil) + ) + +;;; Commands for semantic-symref-results +;; +(defun semantic-symref-list-toggle-showing () + "Toggle showing the contents below the current line." + (interactive) + (beginning-of-line) + (when (re-search-forward "\\[[-+]\\]" (point-at-eol) t) + (forward-char -1) + (push-button))) + +(defun semantic-symref-rb-toggle-expand-tag (&optional button) + "Go to the file specified in the symref results buffer. +BUTTON is the button that was clicked." + (interactive) + (let* ((tag (button-get button 'tag)) + (buff (semantic-tag-buffer tag)) + (hits (semantic--tag-get-property tag :hit)) + (state (button-get button 'state)) + (text nil) + ) + (cond + ((eq state 'closed) + (toggle-read-only -1) + (save-excursion + (set-buffer buff) + (dolist (H hits) + (goto-char (point-min)) + (forward-line (1- H)) + (beginning-of-line) + (back-to-indentation) + (setq text (cons (buffer-substring (point) (point-at-eol)) text))) + (setq text (nreverse text)) + ) + (goto-char (button-start button)) + (forward-char 1) + (delete-char 1) + (insert "-") + (button-put button 'state 'open) + (save-excursion + (end-of-line) + (while text + (insert "\n") + (insert " ") + (insert-button (car text) + 'mouse-face 'highlight + 'face nil + 'action 'semantic-symref-rb-goto-match + 'tag tag + 'line (car hits)) + (setq text (cdr text) + hits (cdr hits)))) + (toggle-read-only 1) + ) + ((eq state 'open) + (toggle-read-only -1) + (button-put button 'state 'closed) + ;; Delete the various bits. + (goto-char (button-start button)) + (forward-char 1) + (delete-char 1) + (insert "+") + (save-excursion + (end-of-line) + (forward-char 1) + (delete-region (point) + (save-excursion + (forward-char 1) + (forward-line (length hits)) + (point)))) + (toggle-read-only 1) + ) + )) + ) + +(defun semantic-symref-rb-goto-file (&optional button) + "Go to the file specified in the symref results buffer. +BUTTON is the button that was clicked." + (let* ((tag (button-get button 'tag)) + (buff (semantic-tag-buffer tag)) + (win (selected-window)) + ) + (switch-to-buffer-other-window buff) + (pulse-momentary-highlight-one-line (point)) + (when (eq last-command-event ?\s) (select-window win)) + )) + + +(defun semantic-symref-rb-goto-tag (&optional button) + "Go to the file specified in the symref results buffer. +BUTTON is the button that was clicked." + (interactive) + (let* ((tag (button-get button 'tag)) + (buff (semantic-tag-buffer tag)) + (win (selected-window)) + ) + (switch-to-buffer-other-window buff) + (semantic-go-to-tag tag) + (pulse-momentary-highlight-one-line (point)) + (when (eq last-command-event ?\s) (select-window win)) + ) + ) + +(defun semantic-symref-rb-goto-match (&optional button) + "Go to the file specified in the symref results buffer. +BUTTON is the button that was clicked." + (interactive) + (let* ((tag (button-get button 'tag)) + (line (button-get button 'line)) + (buff (semantic-tag-buffer tag)) + (win (selected-window)) + ) + (switch-to-buffer-other-window buff) + (with-no-warnings (goto-line line)) + (pulse-momentary-highlight-one-line (point)) + (when (eq last-command-event ?\s) (select-window win)) + ) + ) + +(defun semantic-symref-list-next-line () + "Next line in `semantic-symref-results-mode'." + (interactive) + (forward-line 1) + (back-to-indentation)) + +(defun semantic-symref-list-prev-line () + "Next line in `semantic-symref-results-mode'." + (interactive) + (forward-line -1) + (back-to-indentation)) + +(provide 'semantic/symref/list) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/symref/list" +;; End: + +;;; semantic/symref/list.el ends here diff --git a/lisp/cedet/semantic/tag-file.el b/lisp/cedet/semantic/tag-file.el new file mode 100644 index 00000000000..f558db99877 --- /dev/null +++ b/lisp/cedet/semantic/tag-file.el @@ -0,0 +1,220 @@ +;;; semantic/tag-file.el --- Routines that find files based on tags. + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; A tag, by itself, can have representations in several files. +;; These routines will find those files. + +(require 'semantic/tag) + +(defvar ede-minor-mode) +(declare-function semanticdb-table-child-p "semantic/db") +(declare-function semanticdb-get-buffer "semantic/db") +(declare-function semantic-dependency-find-file-on-path "semantic/dep") +(declare-function ede-toplevel "ede/files") + +;;; Code: + +;;; Location a TAG came from. +;; +;;;###autoload +(define-overloadable-function semantic-go-to-tag (tag &optional parent) + "Go to the location of TAG. +TAG may be a stripped element, in which case PARENT specifies a +parent tag that has position information. +PARENT can also be a `semanticdb-table' object." + (:override + (save-match-data + (cond ((semantic-tag-in-buffer-p tag) + ;; We have a linked tag, go to that buffer. + (set-buffer (semantic-tag-buffer tag))) + ((semantic-tag-file-name tag) + ;; If it didn't have a buffer, but does have a file + ;; name, then we need to get to that file so the tag + ;; location is made accurate. + (set-buffer (find-file-noselect (semantic-tag-file-name tag)))) + ((and parent (semantic-tag-p parent) (semantic-tag-in-buffer-p parent)) + ;; The tag had nothing useful, but we have a parent with + ;; a buffer, then go there. + (set-buffer (semantic-tag-buffer parent))) + ((and parent (semantic-tag-p parent) (semantic-tag-file-name parent)) + ;; Tag had nothing, and the parent only has a file-name, then + ;; find that file, and switch to that buffer. + (set-buffer (find-file-noselect (semantic-tag-file-name parent)))) + ((and parent (featurep 'semantic/db) + (semanticdb-table-child-p parent)) + (set-buffer (semanticdb-get-buffer parent))) + (t + ;; Well, just assume things are in the current buffer. + nil + ))) + ;; We should be in the correct buffer now, try and figure out + ;; where the tag is. + (cond ((semantic-tag-with-position-p tag) + ;; If it's a number, go there + (goto-char (semantic-tag-start tag))) + ((semantic-tag-with-position-p parent) + ;; Otherwise, it's a trimmed vector, such as a parameter, + ;; or a structure part. If there is a parent, we can use it + ;; as a bounds for searching. + (goto-char (semantic-tag-start parent)) + ;; Here we make an assumption that the text returned by + ;; the parser and concocted by us actually exists + ;; in the buffer. + (re-search-forward (semantic-tag-name tag) + (semantic-tag-end parent) + t)) + ((semantic-tag-get-attribute tag :line) + ;; The tag has a line number in it. Go there. + (goto-char (point-min)) + (forward-line (1- (semantic-tag-get-attribute tag :line)))) + ((and (semantic-tag-p parent) (semantic-tag-get-attribute parent :line)) + ;; The tag has a line number in it. Go there. + (goto-char (point-min)) + (forward-line (1- (semantic-tag-get-attribute parent :line))) + (re-search-forward (semantic-tag-name tag) nil t)) + (t + ;; Take a guess that the tag has a unique name, and just + ;; search for it from the beginning of the buffer. + (goto-char (point-min)) + (re-search-forward (semantic-tag-name tag) nil t))) + ) + ) + +(make-obsolete-overload 'semantic-find-nonterminal + 'semantic-go-to-tag) + +;;; Dependencies +;; +;; A tag which is of type 'include specifies a dependency. +;; Dependencies usually represent a file of some sort. +;; Find the file described by a dependency. + +;;;###autoload +(define-overloadable-function semantic-dependency-tag-file (&optional tag) + "Find the filename represented from TAG. +Depends on `semantic-dependency-include-path' for searching. Always searches +`.' first, then searches additional paths." + (or tag (setq tag (car (semantic-find-tag-by-overlay nil)))) + (unless (semantic-tag-of-class-p tag 'include) + (signal 'wrong-type-argument (list tag 'include))) + (save-excursion + (let ((result nil) + (default-directory default-directory) + (edefind nil) + (tag-fname nil)) + (cond ((semantic-tag-in-buffer-p tag) + ;; If the tag has an overlay and buffer associated with it, + ;; switch to that buffer so that we get the right override metohds. + (set-buffer (semantic-tag-buffer tag))) + ((semantic-tag-file-name tag) + ;; If it didn't have a buffer, but does have a file + ;; name, then we need to get to that file so the tag + ;; location is made accurate. + ;;(set-buffer (find-file-noselect (semantic-tag-file-name tag))) + ;; + ;; 2/3/08 + ;; The above causes unnecessary buffer loads all over the place. Ick! + ;; All we really need is for 'default-directory' to be set correctly. + (setq default-directory (file-name-directory (semantic-tag-file-name tag))) + )) + ;; Setup the filename represented by this include + (setq tag-fname (semantic-tag-include-filename tag)) + + ;; First, see if this file exists in the current EDE project + (if (and (fboundp 'ede-expand-filename) ede-minor-mode + (setq edefind + (condition-case nil + (let ((proj (ede-toplevel))) + (when proj + (ede-expand-filename proj tag-fname))) + (error nil)))) + (setq result edefind)) + (if (not result) + (setq result + ;; I don't have a plan for refreshing tags with a dependency + ;; stuck on them somehow. I'm thinking that putting a cache + ;; onto the dependancy finding with a hash table might be best. + ;;(if (semantic--tag-get-property tag 'dependency-file) + ;; (semantic--tag-get-property tag 'dependency-file) + (:override + (save-excursion + (require 'semantic/dep) + (semantic-dependency-find-file-on-path + tag-fname (semantic-tag-include-system-p tag)))) + ;; ) + )) + (if (stringp result) + (progn + (semantic--tag-put-property tag 'dependency-file result) + result) + ;; @todo: Do something to make this get flushed w/ + ;; when the path is changed. + ;; @undo: Just eliminate + ;; (semantic--tag-put-property tag 'dependency-file 'none) + nil) + ))) + +(make-obsolete-overload 'semantic-find-dependency + 'semantic-dependency-tag-file) + +;;; PROTOTYPE FILE +;; +;; In C, a function in the .c file often has a representation in a +;; corresponding .h file. This routine attempts to find the +;; prototype file a given source file would be associated with. +;; This can be used by prototype manager programs. +(define-overloadable-function semantic-prototype-file (buffer) + "Return a file in which prototypes belonging to BUFFER should be placed. +Default behavior (if not overridden) looks for a token specifying the +prototype file, or the existence of an EDE variable indicating which +file prototypes belong in." + (:override + ;; Perform some default behaviors + (if (and (fboundp 'ede-header-file) ede-minor-mode) + (save-excursion + (set-buffer buffer) + (ede-header-file)) + ;; No EDE options for a quick answer. Search. + (save-excursion + (set-buffer buffer) + (if (re-search-forward "::Header:: \\([a-zA-Z0-9.]+\\)" nil t) + (match-string 1)))))) + +(semantic-alias-obsolete 'semantic-find-nonterminal + 'semantic-go-to-tag) + +(semantic-alias-obsolete 'semantic-find-dependency + 'semantic-dependency-tag-file) + + +(provide 'semantic/tag-file) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/tag-file" +;; End: + +;;; semantic/tag-file.el ends here diff --git a/lisp/cedet/semantic/tag-ls.el b/lisp/cedet/semantic/tag-ls.el new file mode 100644 index 00000000000..82d628cbf38 --- /dev/null +++ b/lisp/cedet/semantic/tag-ls.el @@ -0,0 +1,256 @@ +;;; semantic/tag-ls.el --- Language Specific override functions for tags + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; There are some features of tags that are too langauge dependent to +;; put in the core `semantic-tag' functionality. For instance, the +;; protection of a tag (as specified by UML) could be almost anything. +;; In Java, it is a type specifier. In C, there is a label. This +;; informatin can be derived, and thus should not be stored in the tag +;; itself. These are the functions that languages can use to derive +;; the information. + +(require 'semantic) + +;;; Code: + +;;; UML features: +;; +;; UML can represent several types of features of a tag +;; such as the `protection' of a symbol, or if it is abstract, +;; leaf, etc. Learn about UML to catch onto the lingo. + +(define-overloadable-function semantic-tag-calculate-parent (tag) + "Attempt to calculate the parent of TAG. +The default behavior (if not overriden with `tag-calculate-parent') +is to search a buffer found with TAG, and if externally defined, +search locally, then semanticdb for that tag (when enabled.)") + +(defun semantic-tag-calculate-parent-default (tag) + "Attempt to calculate the parent of TAG." + (when (semantic-tag-in-buffer-p tag) + (save-excursion + (set-buffer (semantic-tag-buffer tag)) + (save-excursion + (goto-char (semantic-tag-start tag)) + (semantic-current-tag-parent)) + ))) + +(define-overloadable-function semantic-tag-protection (tag &optional parent) + "Return protection information about TAG with optional PARENT. +This function returns on of the following symbols: + nil - No special protection. Language dependent. + 'public - Anyone can access this TAG. + 'private - Only methods in the local scope can access TAG. + 'protected - Like private for outside scopes, like public for child + classes. +Some languages may choose to provide additional return symbols specific +to themselves. Use of this function should allow for this. + +The default behavior (if not overridden with `tag-protection' +is to return a symbol based on type modifiers." + (and (not parent) + (semantic-tag-overlay tag) + (semantic-tag-in-buffer-p tag) + (setq parent (semantic-tag-calculate-parent tag))) + (:override)) + +(make-obsolete-overload 'semantic-nonterminal-protection + 'semantic-tag-protection) + +(defun semantic-tag-protection-default (tag &optional parent) + "Return the protection of TAG as a child of PARENT default action. +See `semantic-tag-protection'." + (let ((mods (semantic-tag-modifiers tag)) + (prot nil)) + (while (and (not prot) mods) + (if (stringp (car mods)) + (let ((s (car mods))) + (setq prot + ;; A few silly defaults to get things started. + (cond ((or (string= s "public") + (string= s "extern") + (string= s "export")) + 'public) + ((string= s "private") + 'private) + ((string= s "protected") + 'protected))))) + (setq mods (cdr mods))) + prot)) + +(defun semantic-tag-protected-p (tag protection &optional parent) + "Non-nil if TAG is is protected. +PROTECTION is a symbol which can be returned by the method +`semantic-tag-protection'. +PARENT is the parent data type which contains TAG. + +For these PROTECTIONs, true is returned if TAG is: +@table @asis +@item nil + Always true +@item private + True if nil. +@item protected + True if private or nil. +@item public + True if private, protected, or nil. +@end table" + (if (null protection) + t + (let ((tagpro (semantic-tag-protection tag parent))) + (or (and (eq protection 'private) + (null tagpro)) + (and (eq protection 'protected) + (or (null tagpro) + (eq tagpro 'private))) + (and (eq protection 'public) + (not (eq tagpro 'public))))) + )) + +(define-overloadable-function semantic-tag-abstract-p (tag &optional parent) + "Return non nil if TAG is abstract. +Optional PARENT is the parent tag of TAG. +In UML, abstract methods and classes have special meaning and behavior +in how methods are overridden. In UML, abstract methods are italicized. + +The default behavior (if not overridden with `tag-abstract-p' +is to return true if `abstract' is in the type modifiers.") + +(make-obsolete-overload 'semantic-nonterminal-abstract + 'semantic-tag-abstract-p) + +(defun semantic-tag-abstract-p-default (tag &optional parent) + "Return non-nil if TAG is abstract as a child of PARENT default action. +See `semantic-tag-abstract-p'." + (let ((mods (semantic-tag-modifiers tag)) + (abs nil)) + (while (and (not abs) mods) + (if (stringp (car mods)) + (setq abs (or (string= (car mods) "abstract") + (string= (car mods) "virtual")))) + (setq mods (cdr mods))) + abs)) + +(define-overloadable-function semantic-tag-leaf-p (tag &optional parent) + "Return non nil if TAG is leaf. +Optional PARENT is the parent tag of TAG. +In UML, leaf methods and classes have special meaning and behavior. + +The default behavior (if not overridden with `tag-leaf-p' +is to return true if `leaf' is in the type modifiers.") + +(make-obsolete-overload 'semantic-nonterminal-leaf + 'semantic-tag-leaf-p) + +(defun semantic-tag-leaf-p-default (tag &optional parent) + "Return non-nil if TAG is leaf as a child of PARENT default action. +See `semantic-tag-leaf-p'." + (let ((mods (semantic-tag-modifiers tag)) + (leaf nil)) + (while (and (not leaf) mods) + (if (stringp (car mods)) + ;; Use java FINAL as example default. There is none + ;; for C/C++ + (setq leaf (string= (car mods) "final"))) + (setq mods (cdr mods))) + leaf)) + +(define-overloadable-function semantic-tag-static-p (tag &optional parent) + "Return non nil if TAG is static. +Optional PARENT is the parent tag of TAG. +In UML, static methods and attributes mean that they are allocated +in the parent class, and are not instance specific. +UML notation specifies that STATIC entries are underlined.") + +(defun semantic-tag-static-p-default (tag &optional parent) + "Return non-nil if TAG is static as a child of PARENT default action. +See `semantic-tag-static-p'." + (let ((mods (semantic-tag-modifiers tag)) + (static nil)) + (while (and (not static) mods) + (if (stringp (car mods)) + (setq static (string= (car mods) "static"))) + (setq mods (cdr mods))) + static)) + +;;;###autoload +(define-overloadable-function semantic-tag-prototype-p (tag) + "Return non nil if TAG is a prototype. +For some laguages, such as C, a prototype is a declaration of +something without an implementation." + ) + +(defun semantic-tag-prototype-p-default (tag) + "Non-nil if TAG is a prototype." + (let ((p (semantic-tag-get-attribute tag :prototype-flag))) + (cond + ;; Trust the parser author. + (p p) + ;; Empty types might be a prototype. + ;; @todo - make this better. + ((eq (semantic-tag-class tag) 'type) + (not (semantic-tag-type-members tag))) + ;; No other heuristics. + (t nil)) + )) + +;;; FULL NAMES +;; +;; For programmer convenience, a full name is not specified in source +;; code. Instead some abbreviation is made, and the local environment +;; will contain the info needed to determine the full name. + +(define-overloadable-function semantic-tag-full-name (tag &optional stream-or-buffer) + "Return the fully qualified name of TAG in the package hierarchy. +STREAM-OR-BUFFER can be anything convertable by `semantic-something-to-stream', +but must be a toplevel semantic tag stream that contains TAG. +A Package Hierarchy is defined in UML by the way classes and methods +are organized on disk. Some language use this concept such that a +class can be accessed via it's fully qualified name, (such as Java.) +Other languages qualify names within a Namespace (such as C++) which +result in a different package like structure. Languages which do not +override this function with `tag-full-name' will use +`semantic-tag-name'. Override functions only need to handle +STREAM-OR-BUFFER with a tag stream value, or nil." + (let ((stream (semantic-something-to-tag-table + (or stream-or-buffer tag)))) + (:override-with-args (tag stream)))) + +(make-obsolete-overload 'semantic-nonterminal-full-name + 'semantic-tag-full-name) + +(defun semantic-tag-full-name-default (tag stream) + "Default method for `semantic-tag-full-name'. +Return the name of TAG found in the toplevel STREAM." + (semantic-tag-name tag)) + +(provide 'semantic/tag-ls) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/tag-ls" +;; End: + +;;; semantic/tag-ls.el ends here diff --git a/lisp/cedet/semantic/tag-write.el b/lisp/cedet/semantic/tag-write.el new file mode 100644 index 00000000000..88d0ecb2f24 --- /dev/null +++ b/lisp/cedet/semantic/tag-write.el @@ -0,0 +1,179 @@ +;;; semantic/tag-write.el --- Write tags to a text stream + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Routine for writing out a list of tags to a text stream. +;; +;; These routines will be used by semanticdb to output a tag list into +;; a text stream to be saved to a file. Ideally, you could use tag streams +;; to share tags between processes as well. +;; +;; As a bonus, these routines will also validate the tag structure, and make sure +;; that they conform to good semantic tag hygene. +;; + +(require 'semantic) + +;;; Code: +(defun semantic-tag-write-one-tag (tag &optional indent) + "Write a single tag TAG to standard out. +INDENT is the amount of indentation to use for this tag." + (when (not (semantic-tag-p tag)) + (signal 'wrong-type-argument (list tag 'semantic-tag-p))) + (when (not indent) (setq indent 0)) + ;(princ (make-string indent ? )) + (princ "(\"") + ;; Base parts + (let ((name (semantic-tag-name tag)) + (class (semantic-tag-class tag))) + (princ name) + (princ "\" ") + (princ (symbol-name class)) + ) + (let ((attr (semantic-tag-attributes tag)) + ) + ;; Attributes + (cond ((not attr) + (princ " nil")) + + ((= (length attr) 2) ;; One item + (princ " (") + (semantic-tag-write-one-attribute attr indent) + (princ ")") + ) + (t + ;; More than one tag. + (princ "\n") + (princ (make-string (+ indent 3) ? )) + (princ "(") + (while attr + (semantic-tag-write-one-attribute attr (+ indent 4)) + (setq attr (cdr (cdr attr))) + (when attr + (princ "\n") + (princ (make-string (+ indent 4) ? ))) + ) + (princ ")\n") + (princ (make-string (+ indent 3) ? )) + )) + ;; Properties - for now, always nil. + (let ((rs (semantic--tag-get-property tag 'reparse-symbol))) + (if (not rs) + (princ " nil") + ;; Else, put in the property list. + (princ " (reparse-symbol ") + (princ (symbol-name rs)) + (princ ")")) + )) + ;; Overlay + (if (semantic-tag-with-position-p tag) + (let ((bounds (semantic-tag-bounds tag))) + (princ " ") + (prin1 (apply 'vector bounds)) + ) + (princ " nil")) + ;; End it. + (princ ")") + ) + +(defun semantic-tag-write-tag-list (tlist &optional indent dontaddnewline) + "Write the tag list TLIST to the current stream. +INDENT indicates the current indentation level. +If optional DONTADDNEWLINE is non-nil, then don't add a newline." + (if (not indent) + (setq indent 0) + (unless dontaddnewline + ;; Assume cursor at end of current line. Add a CR, and make the list. + (princ "\n") + (princ (make-string indent ? )))) + (princ "( ") + (while tlist + (if (semantic-tag-p (car tlist)) + (semantic-tag-write-one-tag (car tlist) (+ indent 2)) + ;; If we don't have a tag in the tag list, use the below hack, and hope + ;; it doesn't contain anything bad. If we find something bad, go back here + ;; and start extending what's expected here. + (princ (format "%S" (car tlist)))) + (setq tlist (cdr tlist)) + (when tlist + (princ "\n") + (princ (make-string (+ indent 2) ? ))) + ) + (princ ")") + (princ (make-string indent ? )) + ) + + +;; Writing out random stuff. +(defun semantic-tag-write-one-attribute (attrs indent) + "Write out one attribute from the head of the list of attributes ATTRS. +INDENT is the current amount of indentation." + (when (not attrs) (signal 'wrong-type-argument (list 'listp attrs))) + (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag")) + + (princ (symbol-name (car attrs))) + (princ " ") + (semantic-tag-write-one-value (car (cdr attrs)) indent) + ) + +(defun semantic-tag-write-one-value (value indent) + "Write out a VALUE for something in a tag. +INDENT is the current tag indentation. +Items that are long lists of tags may need their own line." + (cond + ;; Another tag. + ((semantic-tag-p value) + (semantic-tag-write-one-tag value (+ indent 2))) + ;; A list of more tags + ((and (listp value) (semantic-tag-p (car value))) + (semantic-tag-write-tag-list value (+ indent 2)) + ) + ;; Some arbitrary data. + (t + (let ((str (format "%S" value))) + ;; Protect against odd data types in tags. + (if (= (aref str 0) ?#) + (progn + (princ "nil") + (message "Warning: Value %s not writable in tag." str)) + (princ str))))) + ) +;;; EIEIO USAGE +;;;###autoload +(defun semantic-tag-write-list-slot-value (value) + "Write out the VALUE of a slot for EIEIO. +The VALUE is a list of tags." + (if (not value) + (princ "nil") + (princ "\n '") + (semantic-tag-write-tag-list value 10 t) + )) + +(provide 'semantic/tag-write) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/tag-write" +;; End: + +;;; semantic/tag-write.el ends here diff --git a/lisp/cedet/semantic/tag.el b/lisp/cedet/semantic/tag.el new file mode 100644 index 00000000000..608f4f403ee --- /dev/null +++ b/lisp/cedet/semantic/tag.el @@ -0,0 +1,1365 @@ +;;; semantic/tag.el --- tag creation and access + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; I. The core production of semantic is the list of tags produced by the +;; different parsers. This file provides 3 APIs related to tag access: +;; +;; 1) Primitive Tag Access +;; There is a set of common features to all tags. These access +;; functions can get these values. +;; 2) Standard Tag Access +;; A Standard Tag should be produced by most traditional languages +;; with standard styles common to typed object oriented languages. +;; These functions can access these data elements from a tag. +;; 3) Generic Tag Access +;; Access to tag structure in a more direct way. +;; ** May not be forward compatible. +;; +;; II. There is also an API for tag creation. Use `semantic-tag' to create +;; a new tag. +;; +;; III. Tag Comparison. Allows explicit or comparitive tests to see +;; if two tags are the same. + +;;; Code: +;; + +;; Keep this only so long as we have obsolete fcns. +(require 'semantic/fw) +(require 'semantic/lex) + +(declare-function semantic-analyze-split-name "semantic/analyze/fcn") +(declare-function semantic-fetch-tags "semantic") +(declare-function semantic-clear-toplevel-cache "semantic") + +(defconst semantic-tag-version "2.0pre7" + "Version string of semantic tags made with this code.") + +(defconst semantic-tag-incompatible-version "1.0" + "Version string of semantic tags which are not currently compatible. +These old style tags may be loaded from a file with semantic db. +In this case, we must flush the old tags and start over.") + +;;; Primitive Tag access system: +;; +;; Raw tags in semantic are lists of 5 elements: +;; +;; (NAME CLASS ATTRIBUTES PROPERTIES OVERLAY) +;; +;; Where: +;; +;; - NAME is a string that represents the tag name. +;; +;; - CLASS is a symbol that represent the class of the tag (for +;; example, usual classes are `type', `function', `variable', +;; `include', `package', `code'). +;; +;; - ATTRIBUTES is a public list of attributes that describes +;; language data represented by the tag (for example, a variable +;; can have a `:constant-flag' attribute, a function an `:arguments' +;; attribute, etc.). +;; +;; - PROPERTIES is a private list of properties used internally. +;; +;; - OVERLAY represent the location of data described by the tag. +;; + +(defsubst semantic-tag-name (tag) + "Return the name of TAG. +For functions, variables, classes, typedefs, etc., this is the identifier +that is being defined. For tags without an obvious associated name, this +may be the statement type, e.g., this may return @code{print} for python's +print statement." + (car tag)) + +(defsubst semantic-tag-class (tag) + "Return the class of TAG. +That is, the symbol 'variable, 'function, 'type, or other. +There is no limit to the symbols that may represent the class of a tag. +Each parser generates tags with classes defined by it. + +For functional languages, typical tag classes are: + +@table @code +@item type +Data types, named map for a memory block. +@item function +A function or method, or named execution location. +@item variable +A variable, or named storage for data. +@item include +Statement that represents a file from which more tags can be found. +@item package +Statement that declairs this file's package name. +@item code +Code that has not name or binding to any other symbol, such as in a script. +@end table +" + (nth 1 tag)) + +(defsubst semantic-tag-attributes (tag) + "Return the list of public attributes of TAG. +That is a property list: (ATTRIBUTE-1 VALUE-1 ATTRIBUTE-2 VALUE-2...)." + (nth 2 tag)) + +(defsubst semantic-tag-properties (tag) + "Return the list of private properties of TAG. +That is a property list: (PROPERTY-1 VALUE-1 PROPERTY-2 VALUE-2...)." + (nth 3 tag)) + +(defsubst semantic-tag-overlay (tag) + "Return the OVERLAY part of TAG. +That is, an overlay or an unloaded buffer representation. +This function can also return an array of the form [ START END ]. +This occurs for tags that are not currently linked into a buffer." + (nth 4 tag)) + +(defsubst semantic--tag-overlay-cdr (tag) + "Return the cons cell whose car is the OVERLAY part of TAG. +That function is for internal use only." + (nthcdr 4 tag)) + +(defsubst semantic--tag-set-overlay (tag overlay) + "Set the overlay part of TAG with OVERLAY. +That function is for internal use only." + (setcar (semantic--tag-overlay-cdr tag) overlay)) + +(defsubst semantic-tag-start (tag) + "Return the start location of TAG." + (let ((o (semantic-tag-overlay tag))) + (if (semantic-overlay-p o) + (semantic-overlay-start o) + (aref o 0)))) + +(defsubst semantic-tag-end (tag) + "Return the end location of TAG." + (let ((o (semantic-tag-overlay tag))) + (if (semantic-overlay-p o) + (semantic-overlay-end o) + (aref o 1)))) + +(defsubst semantic-tag-bounds (tag) + "Return the location (START END) of data TAG describes." + (list (semantic-tag-start tag) + (semantic-tag-end tag))) + +(defun semantic-tag-set-bounds (tag start end) + "In TAG, set the START and END location of data it describes." + (let ((o (semantic-tag-overlay tag))) + (if (semantic-overlay-p o) + (semantic-overlay-move o start end) + (semantic--tag-set-overlay tag (vector start end))))) + +(defun semantic-tag-in-buffer-p (tag) + "Return the buffer TAG resides in IFF tag is already in a buffer. +If a tag is not in a buffer, return nil." + (let ((o (semantic-tag-overlay tag))) + ;; TAG is currently linked to a buffer, return it. + (when (and (semantic-overlay-p o) + (semantic-overlay-live-p o)) + (semantic-overlay-buffer o)))) + +(defsubst semantic--tag-get-property (tag property) + "From TAG, extract the value of PROPERTY. +Return the value found, or nil if PROPERTY is not one of the +properties of TAG. +That function is for internal use only." + (plist-get (semantic-tag-properties tag) property)) + +(defun semantic-tag-buffer (tag) + "Return the buffer TAG resides in. +If TAG has an originating file, read that file into a (maybe new) +buffer, and return it. +Return nil if there is no buffer for this tag." + (let ((buff (semantic-tag-in-buffer-p tag))) + (if buff + buff + ;; TAG has an originating file, read that file into a buffer, and + ;; return it. + (if (semantic--tag-get-property tag :filename) + (save-match-data + (find-file-noselect (semantic--tag-get-property tag :filename))) + ;; TAG is not in Emacs right now, no buffer is available. + )))) + +(defun semantic-tag-mode (&optional tag) + "Return the major mode active for TAG. +TAG defaults to the tag at point in current buffer. +If TAG has a :mode property return it. +If point is inside TAG bounds, return the major mode active at point. +Return the major mode active at beginning of TAG otherwise. +See also the function `semantic-ctxt-current-mode'." + (or tag (setq tag (semantic-current-tag))) + (or (semantic--tag-get-property tag :mode) + (let ((buffer (semantic-tag-buffer tag)) + (start (semantic-tag-start tag)) + (end (semantic-tag-end tag))) + (save-excursion + (and buffer (set-buffer buffer)) + ;; Unless point is inside TAG bounds, move it to the + ;; beginning of TAG. + (or (and (>= (point) start) (< (point) end)) + (goto-char start)) + (semantic-ctxt-current-mode))))) + +(defsubst semantic--tag-attributes-cdr (tag) + "Return the cons cell whose car is the ATTRIBUTES part of TAG. +That function is for internal use only." + (nthcdr 2 tag)) + +(defsubst semantic-tag-put-attribute (tag attribute value) + "Change value in TAG of ATTRIBUTE to VALUE. +If ATTRIBUTE already exists, its value is set to VALUE, otherwise the +new ATTRIBUTE VALUE pair is added. +Return TAG. +Use this function in a parser when not all attributes are known at the +same time." + (let* ((plist-cdr (semantic--tag-attributes-cdr tag))) + (when (consp plist-cdr) + (setcar plist-cdr + (semantic-tag-make-plist + (plist-put (car plist-cdr) attribute value)))) + tag)) + +(defun semantic-tag-put-attribute-no-side-effect (tag attribute value) + "Change value in TAG of ATTRIBUTE to VALUE without side effects. +All cons cells in the attribute list are replicated so that there +are no side effects if TAG is in shared lists. +If ATTRIBUTE already exists, its value is set to VALUE, otherwise the +new ATTRIBUTE VALUE pair is added. +Return TAG." + (let* ((plist-cdr (semantic--tag-attributes-cdr tag))) + (when (consp plist-cdr) + (setcar plist-cdr + (semantic-tag-make-plist + (plist-put (copy-sequence (car plist-cdr)) + attribute value)))) + tag)) + +(defsubst semantic-tag-get-attribute (tag attribute) + "From TAG, return the value of ATTRIBUTE. +ATTRIBUTE is a symbol whose specification value to get. +Return the value found, or nil if ATTRIBUTE is not one of the +attributes of TAG." + (plist-get (semantic-tag-attributes tag) attribute)) + +;; These functions are for internal use only! +(defsubst semantic--tag-properties-cdr (tag) + "Return the cons cell whose car is the PROPERTIES part of TAG. +That function is for internal use only." + (nthcdr 3 tag)) + +(defun semantic--tag-put-property (tag property value) + "Change value in TAG of PROPERTY to VALUE. +If PROPERTY already exists, its value is set to VALUE, otherwise the +new PROPERTY VALUE pair is added. +Return TAG. +That function is for internal use only." + (let* ((plist-cdr (semantic--tag-properties-cdr tag))) + (when (consp plist-cdr) + (setcar plist-cdr + (semantic-tag-make-plist + (plist-put (car plist-cdr) property value)))) + tag)) + +(defun semantic--tag-put-property-no-side-effect (tag property value) + "Change value in TAG of PROPERTY to VALUE without side effects. +All cons cells in the property list are replicated so that there +are no side effects if TAG is in shared lists. +If PROPERTY already exists, its value is set to VALUE, otherwise the +new PROPERTY VALUE pair is added. +Return TAG. +That function is for internal use only." + (let* ((plist-cdr (semantic--tag-properties-cdr tag))) + (when (consp plist-cdr) + (setcar plist-cdr + (semantic-tag-make-plist + (plist-put (copy-sequence (car plist-cdr)) + property value)))) + tag)) + +(defun semantic-tag-file-name (tag) + "Return the name of the file from which TAG originated. +Return nil if that information can't be obtained. +If TAG is from a loaded buffer, then that buffer's filename is used. +If TAG is unlinked, but has a :filename property, then that is used." + (let ((buffer (semantic-tag-in-buffer-p tag))) + (if buffer + (buffer-file-name buffer) + (semantic--tag-get-property tag :filename)))) + +;;; Tag tests and comparisons. +(defsubst semantic-tag-p (tag) + "Return non-nil if TAG is most likely a semantic tag." + (condition-case nil + (and (consp tag) + (stringp (car tag)) ; NAME + (symbolp (nth 1 tag)) (nth 1 tag) ; TAG-CLASS + (listp (nth 2 tag)) ; ATTRIBUTES + (listp (nth 3 tag)) ; PROPERTIES + ) + ;; If an error occurs, then it most certainly is not a tag. + (error nil))) + +(defsubst semantic-tag-of-class-p (tag class) + "Return non-nil if class of TAG is CLASS." + (eq (semantic-tag-class tag) class)) + +(defsubst semantic-tag-type-members (tag) + "Return the members of the type that TAG describes. +That is the value of the `:members' attribute." + (semantic-tag-get-attribute tag :members)) + +(defsubst semantic-tag-type (tag) + "Return the value of the `:type' attribute of TAG. +For a function it would be the data type of the return value. +For a variable, it is the storage type of that variable. +For a data type, the type is the style of datatype, such as +struct or union." + (semantic-tag-get-attribute tag :type)) + +(defun semantic-tag-with-position-p (tag) + "Return non-nil if TAG has positional information." + (and (semantic-tag-p tag) + (let ((o (semantic-tag-overlay tag))) + (or (and (semantic-overlay-p o) + (semantic-overlay-live-p o)) + (arrayp o))))) + +(defun semantic-equivalent-tag-p (tag1 tag2) + "Compare TAG1 and TAG2 and return non-nil if they are equivalent. +Use `equal' on elements the name, class, and position. +Use this function if tags are being copied and regrouped to test +for if two tags represent the same thing, but may be constructed +of different cons cells." + (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2)) + (semantic-tag-of-class-p tag1 (semantic-tag-class tag2)) + (or (and (not (semantic-tag-overlay tag1)) + (not (semantic-tag-overlay tag2))) + (and (semantic-tag-overlay tag1) + (semantic-tag-overlay tag2) + (equal (semantic-tag-bounds tag1) + (semantic-tag-bounds tag2)))))) + +(defun semantic-tag-similar-p (tag1 tag2 &rest ignorable-attributes) + "Test to see if TAG1 and TAG2 are similar. +Two tags are similar if their name, datatype, and various attributes +are the same. + +Similar tags that have sub-tags such as arg lists or type members, +are similar w/out checking the sub-list of tags. +Optional argument IGNORABLE-ATTRIBUTES are attributes to ignore while comparing similarity." + (let* ((A1 (and (equal (semantic-tag-name tag1) (semantic-tag-name tag2)) + (semantic-tag-of-class-p tag1 (semantic-tag-class tag2)) + (semantic-tag-of-type-p tag1 (semantic-tag-type tag2)))) + (attr1 (semantic-tag-attributes tag1)) + (A2 (= (length attr1) (length (semantic-tag-attributes tag2)))) + (A3 t) + ) + (when (and (not A2) ignorable-attributes) + (setq A2 t)) + (while (and A2 attr1 A3) + (let ((a (car attr1)) + (v (car (cdr attr1)))) + + (cond ((or (eq a :type) ;; already tested above. + (memq a ignorable-attributes)) ;; Ignore them... + nil) + + ;; Don't test sublists of tags + ((and (listp v) (semantic-tag-p (car v))) + nil) + + ;; The attributes are not the same? + ((not (equal v (semantic-tag-get-attribute tag2 a))) + (setq A3 nil)) + (t + nil)) + ) + (setq attr1 (cdr (cdr attr1)))) + + (and A1 A2 A3) + )) + +(defun semantic-tag-similar-with-subtags-p (tag1 tag2 &rest ignorable-attributes) + "Test to see if TAG1 and TAG2 are similar. +Uses `semantic-tag-similar-p' but also recurses through sub-tags, such +as argument lists and type members. +Optional argument IGNORABLE-ATTRIBUTES is passed down to +`semantic-tag-similar-p'." + (let ((C1 (semantic-tag-components tag1)) + (C2 (semantic-tag-components tag2)) + ) + (if (or (/= (length C1) (length C2)) + (not (semantic-tag-similar-p tag1 tag2 ignorable-attributes)) + ) + ;; Basic test fails. + nil + ;; Else, check component lists. + (catch 'component-dissimilar + (while C1 + + (if (not (semantic-tag-similar-with-subtags-p + (car C1) (car C2) ignorable-attributes)) + (throw 'component-dissimilar nil)) + + (setq C1 (cdr C1)) + (setq C2 (cdr C2)) + ) + ;; If we made it this far, we are ok. + t) ))) + + +(defun semantic-tag-of-type-p (tag type) + "Compare TAG's type against TYPE. Non nil if equivalent. +TYPE can be a string, or a tag of class 'type. +This can be complex since some tags might have a :type that is a tag, +while other tags might just have a string. This function will also be +return true of TAG's type is compared directly to the declaration of a +data type." + (let* ((tagtype (semantic-tag-type tag)) + (tagtypestring (cond ((stringp tagtype) + tagtype) + ((and (semantic-tag-p tagtype) + (semantic-tag-of-class-p tagtype 'type)) + (semantic-tag-name tagtype)) + (t ""))) + (typestring (cond ((stringp type) + type) + ((and (semantic-tag-p type) + (semantic-tag-of-class-p type 'type)) + (semantic-tag-name type)) + (t ""))) + ) + (and + tagtypestring + (or + ;; Matching strings (input type is string) + (and (stringp type) + (string= tagtypestring type)) + ;; Matching strings (tag type is string) + (and (stringp tagtype) + (string= tagtype typestring)) + ;; Matching tokens, and the type of the type is the same. + (and (string= tagtypestring typestring) + (if (and (semantic-tag-type tagtype) (semantic-tag-type type)) + (equal (semantic-tag-type tagtype) (semantic-tag-type type)) + t)) + )) + )) + +(defun semantic-tag-type-compound-p (tag) + "Return non-nil the type of TAG is compound. +Compound implies a structure or similar data type. +Returns the list of tag members if it is compound." + (let* ((tagtype (semantic-tag-type tag)) + ) + (when (and (semantic-tag-p tagtype) + (semantic-tag-of-class-p tagtype 'type)) + ;; We have the potential of this being a nifty compound type. + (semantic-tag-type-members tagtype) + ))) + +(defun semantic-tag-faux-p (tag) + "Return non-nil if TAG is a FAUX tag. +FAUX tags are created to represent a construct that is +not known to exist in the code. + +Example: When the class browser sees methods to a class, but +cannot find the class, it will create a faux tag to represent the +class to store those methods." + (semantic--tag-get-property tag :faux-flag)) + +;;; Tag creation +;; + +;; Is this function still necessary? +(defun semantic-tag-make-plist (args) + "Create a property list with ARGS. +Args is a property list of the form (KEY1 VALUE1 ... KEYN VALUEN). +Where KEY is a symbol, and VALUE is the value for that symbol. +The return value will be a new property list, with these KEY/VALUE +pairs eliminated: + + - KEY associated to nil VALUE. + - KEY associated to an empty string VALUE. + - KEY associated to a zero VALUE." + (let (plist key val) + (while args + (setq key (car args) + val (nth 1 args) + args (nthcdr 2 args)) + (or (member val '("" nil)) + (and (numberp val) (zerop val)) + (setq plist (cons key (cons val plist))))) + ;; It is not useful to reverse the new plist. + plist)) + +(defsubst semantic-tag (name class &rest attributes) + "Create a generic semantic tag. +NAME is a string representing the name of this tag. +CLASS is the symbol that represents the class of tag this is, +such as 'variable, or 'function. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (list name class (semantic-tag-make-plist attributes) nil nil)) + +(defsubst semantic-tag-new-variable (name type &optional default-value &rest attributes) + "Create a semantic tag of class 'variable. +NAME is the name of this variable. +TYPE is a string or semantic tag representing the type of this variable. +Optional DEFAULT-VALUE is a string representing the default value of this variable. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'variable + :type type + :default-value default-value + attributes)) + +(defsubst semantic-tag-new-function (name type arg-list &rest attributes) + "Create a semantic tag of class 'function. +NAME is the name of this function. +TYPE is a string or semantic tag representing the type of this function. +ARG-LIST is a list of strings or semantic tags representing the +arguments of this function. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'function + :type type + :arguments arg-list + attributes)) + +(defsubst semantic-tag-new-type (name type members parents &rest attributes) + "Create a semantic tag of class 'type. +NAME is the name of this type. +TYPE is a string or semantic tag representing the type of this type. +MEMBERS is a list of strings or semantic tags representing the +elements that make up this type if it is a composite type. +PARENTS is a cons cell. (EXPLICIT-PARENTS . INTERFACE-PARENTS) +EXPLICIT-PARENTS can be a single string (Just one parent) or a +list of parents (in a multiple inheritance situation). It can also +be nil. +INTERFACE-PARENTS is a list of strings representing the names of +all INTERFACES, or abstract classes inherited from. It can also be +nil. +This slot can be interesting because the form: + ( nil \"string\") +is a valid parent where there is no explicit parent, and only an +interface. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'type + :type type + :members members + :superclasses (car parents) + :interfaces (cdr parents) + attributes)) + +(defsubst semantic-tag-new-include (name system-flag &rest attributes) + "Create a semantic tag of class 'include. +NAME is the name of this include. +SYSTEM-FLAG represents that we were able to identify this include as belonging +to the system, as opposed to belonging to the local project. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'include + :system-flag system-flag + attributes)) + +(defsubst semantic-tag-new-package (name detail &rest attributes) + "Create a semantic tag of class 'package. +NAME is the name of this package. +DETAIL is extra information about this package, such as a location where +it can be found. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'package + :detail detail + attributes)) + +(defsubst semantic-tag-new-code (name detail &rest attributes) + "Create a semantic tag of class 'code. +NAME is a name for this code. +DETAIL is extra information about the code. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'code + :detail detail + attributes)) + +(defsubst semantic-tag-set-faux (tag) + "Set TAG to be a new FAUX tag. +FAUX tags represent constructs not found in the source code. +You can identify a faux tag with `semantic-tag-faux-p'" + (semantic--tag-put-property tag :faux-flag t)) + +(defsubst semantic-tag-set-name (tag name) + "Set TAG name to NAME." + (setcar tag name)) + +;;; Copying and cloning tags. +;; +(defsubst semantic-tag-clone (tag &optional name) + "Clone TAG, creating a new TAG. +If optional argument NAME is not nil it specifies a new name for the +cloned tag." + ;; Right now, TAG is a list. + (list (or name (semantic-tag-name tag)) + (semantic-tag-class tag) + (copy-sequence (semantic-tag-attributes tag)) + (copy-sequence (semantic-tag-properties tag)) + (semantic-tag-overlay tag))) + +(defun semantic-tag-copy (tag &optional name keep-file) + "Return a copy of TAG unlinked from the originating buffer. +If optional argument NAME is non-nil it specifies a new name for the +copied tag. +If optional argument KEEP-FILE is non-nil, and TAG was linked to a +buffer, the originating buffer file name is kept in the `:filename' +property of the copied tag. +If KEEP-FILE is a string, and the orginating buffer is NOT available, +then KEEP-FILE is stored on the `:filename' property. +This runs the tag hook `unlink-copy-hook`." + ;; Right now, TAG is a list. + (let ((copy (semantic-tag-clone tag name))) + + ;; Keep the filename if needed. + (when keep-file + (semantic--tag-put-property + copy :filename (or (semantic-tag-file-name copy) + (and (stringp keep-file) + keep-file) + ))) + + (when (semantic-tag-with-position-p tag) + ;; Convert the overlay to a vector, effectively 'unlinking' the tag. + (semantic--tag-set-overlay + copy (vector (semantic-tag-start copy) (semantic-tag-end copy))) + + ;; Force the children to be copied also. + ;;(let ((chil (semantic--tag-copy-list + ;; (semantic-tag-components-with-overlays tag) + ;; keep-file))) + ;;;; Put the list into TAG. + ;;) + + ;; Call the unlink-copy hook. This should tell tools that + ;; this tag is not part of any buffer. + (when (semantic-overlay-p (semantic-tag-overlay tag)) + (semantic--tag-run-hooks copy 'unlink-copy-hook)) + ) + copy)) + +;;(defun semantic--tag-copy-list (tags &optional keep-file) +;; "Make copies of TAGS and return the list of TAGS." +;; (let ((out nil)) +;; (dolist (tag tags out) +;; (setq out (cons (semantic-tag-copy tag nil keep-file) +;; out)) +;; ))) + +(defun semantic--tag-copy-properties (tag1 tag2) + "Copy private properties from TAG1 to TAG2. +Return TAG2. +This function is for internal use only." + (let ((plist (semantic-tag-properties tag1))) + (while plist + (semantic--tag-put-property tag2 (car plist) (nth 1 plist)) + (setq plist (nthcdr 2 plist))) + tag2)) + +;;; DEEP COPIES +;; +(defun semantic-tag-deep-copy-one-tag (tag &optional filter) + "Make a deep copy of TAG, applying FILTER to each child-tag. +Properties and overlay info are not copied. +FILTER takes TAG as an argument, and should returns a semantic-tag. +It is safe for FILTER to modify the input tag and return it." + (when (not filter) (setq filter 'identity)) + (when (not (semantic-tag-p tag)) + (signal 'wrong-type-argument (list tag 'semantic-tag-p))) + (funcall filter (list (semantic-tag-name tag) + (semantic-tag-class tag) + (semantic--tag-deep-copy-attributes + (semantic-tag-attributes tag) filter) + nil + nil))) + +(defun semantic--tag-deep-copy-attributes (attrs &optional filter) + "Make a deep copy of ATTRS, applying FILTER to each child-tag. + +It is safe to modify ATTR, and return a permutaion of that list. + +FILTER takes TAG as an argument, and should returns a semantic-tag. +It is safe for FILTER to modify the input tag and return it." + (when (car attrs) + (when (not (symbolp (car attrs))) (error "Bad Attribute List in tag")) + (cons (car attrs) + (cons (semantic--tag-deep-copy-value (nth 1 attrs) filter) + (semantic--tag-deep-copy-attributes (nthcdr 2 attrs) filter))))) + +(defun semantic--tag-deep-copy-value (value &optional filter) + "Make a deep copy of VALUE, applying FILTER to each child-tag. + +It is safe to modify VALUE, and return a permutaion of that list. + +FILTER takes TAG as an argument, and should returns a semantic-tag. +It is safe for FILTER to modify the input tag and return it." + (cond + ;; Another tag. + ((semantic-tag-p value) + (semantic-tag-deep-copy-one-tag value filter)) + + ;; A list of more tags + ((and (listp value) (semantic-tag-p (car value))) + (semantic--tag-deep-copy-tag-list value filter)) + + ;; Some arbitrary data. + (t value))) + +(defun semantic--tag-deep-copy-tag-list (tags &optional filter) + "Make a deep copy of TAGS, applying FILTER to each child-tag. + +It is safe to modify the TAGS list, and return a permutaion of that list. + +FILTER takes TAG as an argument, and should returns a semantic-tag. +It is safe for FILTER to modify the input tag and return it." + (when (car tags) + (if (semantic-tag-p (car tags)) + (cons (semantic-tag-deep-copy-one-tag (car tags) filter) + (semantic--tag-deep-copy-tag-list (cdr tags) filter)) + (cons (car tags) (semantic--tag-deep-copy-tag-list (cdr tags) filter))))) + + +;;; Standard Tag Access +;; + +;;; Common +;; +(defsubst semantic-tag-modifiers (tag) + "Return the value of the `:typemodifiers' attribute of TAG." + (semantic-tag-get-attribute tag :typemodifiers)) + +(defun semantic-tag-docstring (tag &optional buffer) + "Return the documentation of TAG. +That is the value defined by the `:documentation' attribute. +Optional argument BUFFER indicates where to get the text from. +If not provided, then only the POSITION can be provided. + +If you want to get documentation for languages that do not store +the documentation string in the tag itself, use +`semantic-documentation-for-tag' instead." + (let ((p (semantic-tag-get-attribute tag :documentation))) + (cond + ((stringp p) p) ;; it is the doc string. + + ((semantic-lex-token-with-text-p p) + (semantic-lex-token-text p)) + + ((and (semantic-lex-token-without-text-p p) + buffer) + (with-current-buffer buffer + (semantic-lex-token-text (car (semantic-lex p (1+ p)))))) + + (t nil)))) + +;;; Generic attributes for tags of any class. +;; +(defsubst semantic-tag-named-parent (tag) + "Return the parent of TAG. +That is the value of the `:parent' attribute. +If a definition can occur outside an actual parent structure, but +refers to that parent by name, then the :parent attribute should be used." + (semantic-tag-get-attribute tag :parent)) + +;;; Tags of class `type' + +(defun semantic-tag-type-superclasses (tag) + "Return the list of superclass names of the type that TAG describes." + (let ((supers (semantic-tag-get-attribute tag :superclasses))) + (cond ((stringp supers) + ;; If we have a string, make it a list. + (list supers)) + ((semantic-tag-p supers) + ;; If we have one tag, return just the name. + (list (semantic-tag-name supers))) + ((and (consp supers) (semantic-tag-p (car supers))) + ;; If we have a tag list, then return the names. + (mapcar (lambda (s) (semantic-tag-name s)) + supers)) + ((consp supers) + ;; A list of something, return it. + supers)))) + +(defun semantic--tag-find-parent-by-name (name supers) + "Find the superclass NAME in the list of SUPERS. +If a simple search doesn't do it, try splitting up the names +in SUPERS." + (let ((stag nil)) + (setq stag (semantic-find-first-tag-by-name name supers)) + + (when (not stag) + (require 'semantic/analyze/fcn) + (dolist (S supers) + (let* ((sname (semantic-tag-name S)) + (splitparts (semantic-analyze-split-name sname)) + (parts (if (stringp splitparts) + (list splitparts) + (nreverse splitparts)))) + (when (string= name (car parts)) + (setq stag S)) + ))) + + stag)) + +(defun semantic-tag-type-superclass-protection (tag parentstring) + "Return the inheritance protection in TAG from PARENTSTRING. +PARENTSTRING is the name of the parent being inherited. +The return protection is a symbol, 'public, 'protection, and 'private." + (let ((supers (semantic-tag-get-attribute tag :superclasses))) + (cond ((stringp supers) + 'public) + ((semantic-tag-p supers) + (let ((prot (semantic-tag-get-attribute supers :protection))) + (or (cdr (assoc prot '(("public" . public) + ("protected" . protected) + ("private" . private)))) + 'public))) + ((and (consp supers) (stringp (car supers))) + 'public) + ((and (consp supers) (semantic-tag-p (car supers))) + (let* ((stag (semantic--tag-find-parent-by-name parentstring supers)) + (prot (when stag + (semantic-tag-get-attribute stag :protection)))) + (or (cdr (assoc prot '(("public" . public) + ("protected" . protected) + ("private" . private)))) + (when (equal prot "unspecified") + (if (semantic-tag-of-type-p tag "class") + 'private + 'public)) + 'public)))) + )) + +(defsubst semantic-tag-type-interfaces (tag) + "Return the list of interfaces of the type that TAG describes." + ;; @todo - make this as robust as the above. + (semantic-tag-get-attribute tag :interfaces)) + +;;; Tags of class `function' +;; +(defsubst semantic-tag-function-arguments (tag) + "Return the arguments of the function that TAG describes. +That is the value of the `:arguments' attribute." + (semantic-tag-get-attribute tag :arguments)) + +(defsubst semantic-tag-function-throws (tag) + "Return the exceptions the function that TAG describes can throw. +That is the value of the `:throws' attribute." + (semantic-tag-get-attribute tag :throws)) + +(defsubst semantic-tag-function-parent (tag) + "Return the parent of the function that TAG describes. +That is the value of the `:parent' attribute. +A function has a parent if it is a method of a class, and if the +function does not appear in body of it's parent class." + (semantic-tag-named-parent tag)) + +(defsubst semantic-tag-function-destructor-p (tag) + "Return non-nil if TAG describes a destructor function. +That is the value of the `:destructor-flag' attribute." + (semantic-tag-get-attribute tag :destructor-flag)) + +(defsubst semantic-tag-function-constructor-p (tag) + "Return non-nil if TAG describes a constructor function. +That is the value of the `:constructor-flag' attribute." + (semantic-tag-get-attribute tag :constructor-flag)) + +;;; Tags of class `variable' +;; +(defsubst semantic-tag-variable-default (tag) + "Return the default value of the variable that TAG describes. +That is the value of the attribute `:default-value'." + (semantic-tag-get-attribute tag :default-value)) + +(defsubst semantic-tag-variable-constant-p (tag) + "Return non-nil if the variable that TAG describes is a constant. +That is the value of the attribute `:constant-flag'." + (semantic-tag-get-attribute tag :constant-flag)) + +;;; Tags of class `include' +;; +(defsubst semantic-tag-include-system-p (tag) + "Return non-nil if the include that TAG describes is a system include. +That is the value of the attribute `:system-flag'." + (semantic-tag-get-attribute tag :system-flag)) + +(define-overloadable-function semantic-tag-include-filename (tag) + "Return a filename representation of TAG. +The default action is to return the `semantic-tag-name'. +Some languages do not use full filenames in their include statements. +Override this method to translate the code represenation +into a filename. (A relative filename if necessary.) + +See `semantic-dependency-tag-file' to expand an include +tag to a full file name.") + +(defun semantic-tag-include-filename-default (tag) + "Return a filename representation of TAG. +Returns `semantic-tag-name'." + (semantic-tag-name tag)) + +;;; Tags of class `code' +;; +(defsubst semantic-tag-code-detail (tag) + "Return detail information from code that TAG describes. +That is the value of the attribute `:detail'." + (semantic-tag-get-attribute tag :detail)) + +;;; Tags of class `alias' +;; +(defsubst semantic-tag-new-alias (name meta-tag-class value &rest attributes) + "Create a semantic tag of class alias. +NAME is a name for this alias. +META-TAG-CLASS is the class of the tag this tag is an alias. +VALUE is the aliased definition. +ATTRIBUTES is a list of additional attributes belonging to this tag." + (apply 'semantic-tag name 'alias + :aliasclass meta-tag-class + :definition value + attributes)) + +(defsubst semantic-tag-alias-class (tag) + "Return the class of tag TAG is an alias." + (semantic-tag-get-attribute tag :aliasclass)) + +(define-overloadable-function semantic-tag-alias-definition (tag) + "Return the definition TAG is an alias. +The returned value is a tag of the class that +`semantic-tag-alias-class' returns for TAG. +The default is to return the value of the :definition attribute. +Return nil if TAG is not of class 'alias." + (when (semantic-tag-of-class-p tag 'alias) + (:override + (semantic-tag-get-attribute tag :definition)))) + +;;; Language Specific Tag access via overload +;; +;;;###autoload +(define-overloadable-function semantic-tag-components (tag) + "Return a list of components for TAG. +A Component is a part of TAG which itself may be a TAG. +Examples include the elements of a structure in a +tag of class `type, or the list of arguments to a +tag of class 'function." + ) + +(defun semantic-tag-components-default (tag) + "Return a list of components for TAG. +Perform the described task in `semantic-tag-components'." + (cond ((semantic-tag-of-class-p tag 'type) + (semantic-tag-type-members tag)) + ((semantic-tag-of-class-p tag 'function) + (semantic-tag-function-arguments tag)) + (t nil))) + +(define-overloadable-function semantic-tag-components-with-overlays (tag) + "Return the list of top level components belonging to TAG. +Children are any sub-tags which contain overlays. + +Default behavior is to get `semantic-tag-components' in addition +to the components of an anonymous types (if applicable.) + +Note for language authors: + If a mode defines a language tag that has tags in it with overlays +you should still return them with this function. +Ignoring this step will prevent several features from working correctly." + ) + +(defun semantic-tag-components-with-overlays-default (tag) + "Return the list of top level components belonging to TAG. +Children are any sub-tags which contain overlays. +The default action collects regular components of TAG, in addition +to any components beloning to an anonymous type." + (let ((explicit-children (semantic-tag-components tag)) + (type (semantic-tag-type tag)) + (anon-type-children nil) + (all-children nil)) + ;; Identify if this tag has an anonymous structure as + ;; its type. This implies it may have children with overlays. + (when (and type (semantic-tag-p type)) + (setq anon-type-children (semantic-tag-components type)) + ;; Add anonymous children + (while anon-type-children + (when (semantic-tag-with-position-p (car anon-type-children)) + (setq all-children (cons (car anon-type-children) all-children))) + (setq anon-type-children (cdr anon-type-children)))) + ;; Add explicit children + (while explicit-children + (when (semantic-tag-with-position-p (car explicit-children)) + (setq all-children (cons (car explicit-children) all-children))) + (setq explicit-children (cdr explicit-children))) + ;; Return + (nreverse all-children))) + +(defun semantic-tag-children-compatibility (tag &optional positiononly) + "Return children of TAG. +If POSITIONONLY is nil, use `semantic-tag-components'. +If POSITIONONLY is non-nil, use `semantic-tag-components-with-overlays'. +DO NOT use this fcn in new code. Use one of the above instead." + (if positiononly + (semantic-tag-components-with-overlays tag) + (semantic-tag-components tag))) + +;;; Tag Region +;; +;; A Tag represents a region in a buffer. You can narrow to that tag. +;; +(defun semantic-narrow-to-tag (&optional tag) + "Narrow to the region specified by the bounds of TAG. +See `semantic-tag-bounds'." + (interactive) + (if (not tag) (setq tag (semantic-current-tag))) + (narrow-to-region (semantic-tag-start tag) + (semantic-tag-end tag))) + +(defmacro semantic-with-buffer-narrowed-to-current-tag (&rest body) + "Execute BODY with the buffer narrowed to the current tag." + `(save-restriction + (semantic-narrow-to-tag (semantic-current-tag)) + ,@body)) +(put 'semantic-with-buffer-narrowed-to-current-tag 'lisp-indent-function 0) +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec semantic-with-buffer-narrowed-to-current-tag + (def-body)))) + +(defmacro semantic-with-buffer-narrowed-to-tag (tag &rest body) + "Narrow to TAG, and execute BODY." + `(save-restriction + (semantic-narrow-to-tag ,tag) + ,@body)) +(put 'semantic-with-buffer-narrowed-to-tag 'lisp-indent-function 1) +(add-hook 'edebug-setup-hook + (lambda () + (def-edebug-spec semantic-with-buffer-narrowed-to-tag + (def-body)))) + +;;; Tag Hooks +;; +;; Semantic may want to provide special hooks when specific operations +;; are about to happen on a given tag. These routines allow for hook +;; maintenance on a tag. + +;; Internal global variable used to manage tag hooks. For example, +;; some implementation of `remove-hook' checks that the hook variable +;; is `default-boundp'. +(defvar semantic--tag-hook-value) + +(defun semantic-tag-add-hook (tag hook function &optional append) + "Onto TAG, add to the value of HOOK the function FUNCTION. +FUNCTION is added (if necessary) at the beginning of the hook list +unless the optional argument APPEND is non-nil, in which case +FUNCTION is added at the end. +HOOK should be a symbol, and FUNCTION may be any valid function. +See also the function `add-hook'." + (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))) + (add-hook 'semantic--tag-hook-value function append) + (semantic--tag-put-property tag hook semantic--tag-hook-value) + semantic--tag-hook-value)) + +(defun semantic-tag-remove-hook (tag hook function) + "Onto TAG, remove from the value of HOOK the function FUNCTION. +HOOK should be a symbol, and FUNCTION may be any valid function. If +FUNCTION isn't the value of HOOK, or, if FUNCTION doesn't appear in +the list of hooks to run in HOOK, then nothing is done. +See also the function `remove-hook'." + (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook))) + (remove-hook 'semantic--tag-hook-value function) + (semantic--tag-put-property tag hook semantic--tag-hook-value) + semantic--tag-hook-value)) + +(defun semantic--tag-run-hooks (tag hook &rest args) + "Run for TAG all expressions saved on the property HOOK. +Each hook expression must take at least one argument, the TAG. +For any given situation, additional ARGS may be passed." + (let ((semantic--tag-hook-value (semantic--tag-get-property tag hook)) + (arglist (cons tag args))) + (condition-case err + ;; If a hook bombs, ignore it! Usually this is tied into + ;; some sort of critical system. + (apply 'run-hook-with-args 'semantic--tag-hook-value arglist) + (error (message "Error: %S" err))))) + +;;; Tags and Overlays +;; +;; Overlays are used so that we can quickly identify tags from +;; buffer positions and regions using built in Emacs commands. +;; +(defsubst semantic--tag-unlink-list-from-buffer (tags) + "Convert TAGS from using an overlay to using an overlay proxy. +This function is for internal use only." + (mapcar 'semantic--tag-unlink-from-buffer tags)) + +(defun semantic--tag-unlink-from-buffer (tag) + "Convert TAG from using an overlay to using an overlay proxy. +This function is for internal use only." + (when (semantic-tag-p tag) + (let ((o (semantic-tag-overlay tag))) + (when (semantic-overlay-p o) + (semantic--tag-set-overlay + tag (vector (semantic-overlay-start o) + (semantic-overlay-end o))) + (semantic-overlay-delete o)) + ;; Look for a link hook on TAG. + (semantic--tag-run-hooks tag 'unlink-hook) + ;; Fix the sub-tags which contain overlays. + (semantic--tag-unlink-list-from-buffer + (semantic-tag-components-with-overlays tag))))) + +(defsubst semantic--tag-link-list-to-buffer (tags) + "Convert TAGS from using an overlay proxy to using an overlay. +This function is for internal use only." + (mapcar 'semantic--tag-link-to-buffer tags)) + +(defun semantic--tag-link-to-buffer (tag) + "Convert TAG from using an overlay proxy to using an overlay. +This function is for internal use only." + (when (semantic-tag-p tag) + (let ((o (semantic-tag-overlay tag))) + (when (and (vectorp o) (= (length o) 2)) + (setq o (semantic-make-overlay (aref o 0) (aref o 1) + (current-buffer))) + (semantic--tag-set-overlay tag o) + (semantic-overlay-put o 'semantic tag) + ;; Clear the :filename property + (semantic--tag-put-property tag :filename nil)) + ;; Look for a link hook on TAG. + (semantic--tag-run-hooks tag 'link-hook) + ;; Fix the sub-tags which contain overlays. + (semantic--tag-link-list-to-buffer + (semantic-tag-components-with-overlays tag))))) + +(defun semantic--tag-unlink-cache-from-buffer () + "Convert all tags in the current cache to use overlay proxys. +This function is for internal use only." + (require 'semantic) + (semantic--tag-unlink-list-from-buffer + ;; @todo- use fetch-tags-fast? + (semantic-fetch-tags))) + +(defvar semantic--buffer-cache) + +(defun semantic--tag-link-cache-to-buffer () + "Convert all tags in the current cache to use overlays. +This function is for internal use only." + (require 'semantic) + (condition-case nil + ;; In this unique case, we cannot call the usual toplevel fn. + ;; because we don't want a reparse, we want the old overlays. + (semantic--tag-link-list-to-buffer + semantic--buffer-cache) + ;; Recover when there is an error restoring the cache. + (error (message "Error recovering tag list") + (semantic-clear-toplevel-cache) + nil))) + +;;; Tag Cooking +;; +;; Raw tags from a parser follow a different positional format than +;; those used in the buffer cache. Raw tags need to be cooked into +;; semantic cache friendly tags for use by the masses. +;; +(defsubst semantic--tag-expanded-p (tag) + "Return non-nil if TAG is expanded. +This function is for internal use only. +See also the function `semantic--expand-tag'." + ;; In fact a cooked tag is actually a list of cooked tags + ;; because a raw tag can be expanded in several cooked ones! + (when (consp tag) + (while (and (semantic-tag-p (car tag)) + (vectorp (semantic-tag-overlay (car tag)))) + (setq tag (cdr tag))) + (null tag))) + +(defvar semantic-tag-expand-function nil + "Function used to expand a tag. +It is passed each tag production, and must return a list of tags +derived from it, or nil if it does not need to be expanded. + +Languages with compound definitions should use this function to expand +from one compound symbol into several. For example, in C or Java the +following definition is easily parsed into one tag: + + int a, b; + +This function should take this compound tag and turn it into two tags, +one for A, and the other for B.") +(make-variable-buffer-local 'semantic-tag-expand-function) + +(defun semantic--tag-expand (tag) + "Convert TAG from a raw state to a cooked state, and expand it. +Returns a list of cooked tags. + + The parser returns raw tags with positional data START END at the +end of the tag data structure (a list for now). We convert it from +that to a cooked state that uses an overlay proxy, that is, a vector +\[START END]. + + The raw tag is changed with side effects and maybe expanded in +several derived tags when the variable `semantic-tag-expand-function' +is set. + +This function is for internal use only." + (if (semantic--tag-expanded-p tag) + ;; Just return TAG if it is already expanded (by a grammar + ;; semantic action), or if it isn't recognized as a valid + ;; semantic tag. + tag + + ;; Try to cook the tag. This code will be removed when tag will + ;; be directly created with the right format. + (condition-case nil + (let ((ocdr (semantic--tag-overlay-cdr tag))) + ;; OCDR contains the sub-list of TAG whose car is the + ;; OVERLAY part of TAG. That is, a list (OVERLAY START END). + ;; Convert it into an overlay proxy ([START END]). + (semantic--tag-set-overlay + tag (vector (nth 1 ocdr) (nth 2 ocdr))) + ;; Remove START END positions at end of tag. + (setcdr ocdr nil) + ;; At this point (length TAG) must be 5! + ;;(unless (= (length tag) 5) + ;; (error "Tag expansion failed")) + ) + (error + (message "A Rule must return a single tag-line list!") + (debug tag) + nil)) + ;; Expand based on local configuration + (if semantic-tag-expand-function + (or (funcall semantic-tag-expand-function tag) + (list tag)) + (list tag)))) + +;; Foreign tags +;; +(defmacro semantic-foreign-tag-invalid (tag) + "Signal that TAG is an invalid foreign tag." + `(signal 'wrong-type-argument '(semantic-foreign-tag-p ,tag))) + +(defsubst semantic-foreign-tag-p (tag) + "Return non-nil if TAG is a foreign tag. +That is, a tag unlinked from the originating buffer, which carries the +originating buffer file name, and major mode." + (and (semantic-tag-p tag) + (semantic--tag-get-property tag :foreign-flag))) + +(defsubst semantic-foreign-tag-check (tag) + "Check that TAG is a valid foreign tag. +Signal an error if not." + (or (semantic-foreign-tag-p tag) + (semantic-foreign-tag-invalid tag))) + +(defun semantic-foreign-tag (&optional tag) + "Return a copy of TAG as a foreign tag, or nil if it can't be done. +TAG defaults to the tag at point in current buffer. +See also `semantic-foreign-tag-p'." + (or tag (setq tag (semantic-current-tag))) + (when (semantic-tag-p tag) + (let ((ftag (semantic-tag-copy tag nil t)) + ;; Do extra work for the doc strings, since this is a + ;; common use case. + (doc (condition-case nil + (semantic-documentation-for-tag tag) + (error nil)))) + ;; A foreign tag must carry its originating buffer file name! + (when (semantic--tag-get-property ftag :filename) + (semantic--tag-put-property ftag :mode (semantic-tag-mode tag)) + (semantic--tag-put-property ftag :documentation doc) + (semantic--tag-put-property ftag :foreign-flag t) + ftag)))) + +;; High level obtain/insert foreign tag overloads +(define-overloadable-function semantic-obtain-foreign-tag (&optional tag) + "Obtain a foreign tag from TAG. +TAG defaults to the tag at point in current buffer. +Return the obtained foreign tag or nil if failed." + (semantic-foreign-tag tag)) + +(defun semantic-insert-foreign-tag-default (foreign-tag) + "Insert FOREIGN-TAG into the current buffer. +The default behavior assumes the current buffer is a language file, +and attempts to insert a prototype/function call." + ;; Long term goal: Have a mechanism for a tempo-like template insert + ;; for the given tag. + (insert (semantic-format-tag-prototype foreign-tag))) + +(define-overloadable-function semantic-insert-foreign-tag (foreign-tag) + "Insert FOREIGN-TAG into the current buffer. +Signal an error if FOREIGN-TAG is not a valid foreign tag. +This function is overridable with the symbol `insert-foreign-tag'." + (semantic-foreign-tag-check foreign-tag) + (:override) + (message (semantic-format-tag-summarize foreign-tag))) + +;;; Support log modes here +(define-mode-local-override semantic-insert-foreign-tag + log-edit-mode (foreign-tag) + "Insert foreign tags into log-edit mode." + (insert (concat "(" (semantic-format-tag-name foreign-tag) "): "))) + +(define-mode-local-override semantic-insert-foreign-tag + change-log-mode (foreign-tag) + "Insert foreign tags into log-edit mode." + (insert (concat "(" (semantic-format-tag-name foreign-tag) "): "))) + +;;; Compatibility +;; +(defconst semantic-token-version + semantic-tag-version) +(defconst semantic-token-incompatible-version + semantic-tag-incompatible-version) + +(defsubst semantic-token-type-parent (tag) + "Return the parent of the type that TAG describes. +The return value is a list. A value of nil means no parents. +The `car' of the list is either the parent class, or a list +of parent classes. The `cdr' of the list is the list of +interfaces, or abstract classes which are parents of TAG." + (cons (semantic-tag-get-attribute tag :superclasses) + (semantic-tag-type-interfaces tag))) +(make-obsolete 'semantic-token-type-parent + "\ +use `semantic-tag-type-superclass' \ +and `semantic-tag-type-interfaces' instead") + +(semantic-alias-obsolete 'semantic-tag-make-assoc-list + 'semantic-tag-make-plist) + +(semantic-varalias-obsolete 'semantic-expand-nonterminal + 'semantic-tag-expand-function) + +(provide 'semantic/tag) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/tag" +;; End: + +;;; semantic/tag.el ends here diff --git a/lisp/cedet/semantic/texi.el b/lisp/cedet/semantic/texi.el new file mode 100644 index 00000000000..5f00b1ab928 --- /dev/null +++ b/lisp/cedet/semantic/texi.el @@ -0,0 +1,682 @@ +;;; semantic/texi.el --- Semantic details for Texinfo files + +;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Parse Texinfo buffers using regular expressions. The core parser +;; engine is the function `semantic-texi-parse-headings'. The +;; parser plug-in is the function `semantic-texi-parse-region' that +;; overrides `semantic-parse-region'. + +(require 'semantic) +(require 'semantic/format) +(require 'texinfo) + +(eval-when-compile + (require 'semantic/db) + (require 'semantic/db-find) + (require 'semantic/ctxt) + (require 'semantic/find) + (require 'semantic/doc)) + +(defvar ede-minor-mode) +(declare-function lookup-words "ispell") +(declare-function ede-current-project "ede") + +(defvar semantic-texi-super-regex + "^@\\(top\\|chapter\\|\\(sub\\)*section\\|unnumbered\\(\\(sub\\)*sec\\)?\\|\ +\\(chap\\|\\(sub\\)+\\|major\\)?heading\\|appendix\\(\\(sub\\)*sec\\)?\\|\ +centerchap\\|def\\(var\\|un\\|fn\\|opt\\)x?\\)" + "Regular expression used to find special sections in a Texinfo file.") + +(defvar semantic-texi-name-field-list + '( ("defvar" . 1) + ("defvarx" . 1) + ("defun" . 1) + ("defunx" . 1) + ("defopt" . 1) + ("deffn" . 2) + ("deffnx" . 2) + ) + "List of definition commands, and the field position. +The field position is the field number (based at 1) where the +name of this section is.") + +;;; Code: +(defun semantic-texi-parse-region (&rest ignore) + "Parse the current texinfo buffer for semantic tags. +IGNORE any arguments, always parse the whole buffer. +Each tag returned is of the form: + (\"NAME\" section (:members CHILDREN)) +or + (\"NAME\" def) + +It is an override of 'parse-region and must be installed by the +function `semantic-install-function-overrides'." + (mapcar 'semantic-texi-expand-tag + (semantic-texi-parse-headings))) + +(defun semantic-texi-parse-changes () + "Parse changes in the current texinfo buffer." + ;; NOTE: For now, just schedule a full reparse. + ;; To be implemented later. + (semantic-parse-tree-set-needs-rebuild)) + +(defun semantic-texi-expand-tag (tag) + "Expand the texinfo tag TAG." + (let ((chil (semantic-tag-components tag))) + (if chil + (semantic-tag-put-attribute + tag :members (mapcar 'semantic-texi-expand-tag chil))) + (car (semantic--tag-expand tag)))) + +(defun semantic-texi-parse-headings () + "Parse the current texinfo buffer for all semantic tags now." + (let ((pass1 nil)) + ;; First search and snarf. + (save-excursion + (goto-char (point-min)) + (let ((semantic--progress-reporter + (make-progress-reporter + (format "Parsing %s..." + (file-name-nondirectory buffer-file-name)) + (point-min) (point-max)))) + (while (re-search-forward semantic-texi-super-regex nil t) + (setq pass1 (cons (match-beginning 0) pass1)) + (progress-reporter-update semantic--progress-reporter (point))) + (progress-reporter-done semantic--progress-reporter))) + (setq pass1 (nreverse pass1)) + ;; Now, make some tags while creating a set of children. + (car (semantic-texi-recursive-combobulate-list pass1 0)) + )) + +(defsubst semantic-texi-new-section-tag (name members start end) + "Create a semantic tag of class section. +NAME is the name of this section. +MEMBERS is a list of semantic tags representing the elements that make +up this section. +START and END define the location of data described by the tag." + (append (semantic-tag name 'section :members members) + (list start end))) + +(defsubst semantic-texi-new-def-tag (name start end) + "Create a semantic tag of class def. +NAME is the name of this definition. +START and END define the location of data described by the tag." + (append (semantic-tag name 'def) + (list start end))) + +(defun semantic-texi-set-endpoint (metataglist pnt) + "Set the end point of the first section tag in METATAGLIST to PNT. +METATAGLIST is a list of tags in the intermediate tag format used by the +texinfo parser. PNT is the new point to set." + (let ((metatag nil)) + (while (and metataglist + (not (eq (semantic-tag-class (car metataglist)) 'section))) + (setq metataglist (cdr metataglist))) + (setq metatag (car metataglist)) + (when metatag + (setcar (nthcdr (1- (length metatag)) metatag) pnt) + metatag))) + +(defun semantic-texi-recursive-combobulate-list (sectionlist level) + "Rearrange SECTIONLIST to be a hierarchical tag list starting at LEVEL. +Return the rearranged new list, with all remaining tags from +SECTIONLIST starting at ELT 2. Sections not are not dealt with as soon as a +tag with greater section value than LEVEL is found." + (let ((newl nil) + (oldl sectionlist) + tag + ) + (save-excursion + (catch 'level-jump + (while oldl + (goto-char (car oldl)) + (if (looking-at "@\\(\\w+\\)") + (let* ((word (match-string 1)) + (levelmatch (assoc word texinfo-section-list)) + text begin tmp + ) + ;; Set begin to the right location + (setq begin (point)) + ;; Get out of here if there if we made it that far. + (if (and levelmatch (<= (car (cdr levelmatch)) level)) + (progn + (when newl + (semantic-texi-set-endpoint newl begin)) + (throw 'level-jump t))) + ;; Recombobulate + (if levelmatch + (let ((end (match-end 1))) + ;; Levels sometimes have a @node just in front. + ;; That node statement should be included in the space + ;; for this entry. + (save-excursion + (skip-chars-backward "\n \t") + (beginning-of-line) + (when (looking-at "@node\\>") + (setq begin (point)))) + ;; When there is a match, the descriptive text + ;; consists of the rest of the line. + (goto-char end) + (skip-chars-forward " \t") + (setq text (buffer-substring-no-properties + (point) + (progn (end-of-line) (point)))) + ;; Next, recurse into the body to find the end. + (setq tmp (semantic-texi-recursive-combobulate-list + (cdr oldl) (car (cdr levelmatch)))) + ;; Build a tag + (setq tag (semantic-texi-new-section-tag + text (car tmp) begin (point))) + ;; Before appending the newtag, update the previous tag + ;; if it is a section tag. + (when newl + (semantic-texi-set-endpoint newl begin)) + ;; Append new tag to our master list. + (setq newl (cons tag newl)) + ;; continue + (setq oldl (cdr tmp)) + ) + ;; No match means we have a def*, so get the name from + ;; it based on the type of thingy we found. + (setq levelmatch (assoc word semantic-texi-name-field-list) + tmp (or (cdr levelmatch) 1)) + (forward-sexp tmp) + (skip-chars-forward " \t") + (setq text (buffer-substring-no-properties + (point) + (progn (forward-sexp 1) (point)))) + ;; Seek the end of this definition + (goto-char begin) + (semantic-texi-forward-deffn) + (setq tag (semantic-texi-new-def-tag text begin (point)) + newl (cons tag newl)) + ;; continue + (setq oldl (cdr oldl))) + ) + (error "Problem finding section in semantic/texi parser")) + ;; (setq oldl (cdr oldl)) + ) + ;; When oldl runs out, force a new endpoint as point-max + (when (not oldl) + (semantic-texi-set-endpoint newl (point-max))) + )) + (cons (nreverse newl) oldl))) + +(defun semantic-texi-forward-deffn () + "Move forward over one deffn type definition. +The cursor should be on the @ sign." + (when (looking-at "@\\(\\w+\\)") + (let* ((type (match-string 1)) + (seek (concat "^@end\\s-+" (regexp-quote type)))) + (re-search-forward seek nil t)))) + +(define-mode-local-override semantic-tag-components + texinfo-mode (tag) + "Return components belonging to TAG." + (semantic-tag-get-attribute tag :members)) + + +;;; Overrides: Context Parsing +;; +;; How to treat texi as a language? +;; +(defvar semantic-texi-environment-regexp + (if (string-match texinfo-environment-regexp "@menu") + ;; Make sure our Emacs has menus in it. + texinfo-environment-regexp + ;; If no menus, then merge in the menu concept. + (when (string-match "cartouche" texinfo-environment-regexp) + (concat (substring texinfo-environment-regexp + 0 (match-beginning 0)) + "menu\\|" + (substring texinfo-environment-regexp + (match-beginning 0))))) + "Regular expression for matching texinfo enviroments. +uses `texinfo-environment-regexp', but makes sure that it +can handle the @menu environment.") + +(define-mode-local-override semantic-up-context texinfo-mode () + "Handle texinfo constructs which do not use parenthetical nesting." + (let ((done nil)) + (save-excursion + (let ((parenthetical (semantic-up-context-default)) + ) + (when (not parenthetical) + ;; We are in parenthises. Are they the types of parens + ;; belonging to a texinfo construct? + (forward-word -1) + (when (looking-at "@\\w+{") + (setq done (point)))))) + ;; If we are not in a parenthetical node, then find a block instead. + ;; Use the texinfo support to find block start/end constructs. + (save-excursion + (while (and (not done) + (re-search-backward semantic-texi-environment-regexp nil t)) + ;; For any hit, if we find an @end foo, then jump to the + ;; matching @foo. If it is not an end, then we win! + (if (not (looking-at "@end\\s-+\\(\\w+\\)")) + (setq done (point)) + ;; Skip over this block + (let ((env (match-string 1))) + (re-search-backward (concat "@" env)))) + )) + ;; All over, post what we find. + (if done + ;; We found something, so use it. + (progn (goto-char done) + nil) + t))) + +(define-mode-local-override semantic-beginning-of-context texinfo-mode (&optional point) + "Move to the beginning of the context surrounding POINT." + (if (semantic-up-context point) + ;; If we can't go up, we can't do this either. + t + ;; We moved, so now we need to skip into whatever this thing is. + (forward-word 1) ;; skip the command + (if (looking-at "\\s-*{") + ;; In a short command. Go in. + (down-list 1) + ;; An environment. Go to the next line. + (end-of-line) + (forward-char 1)) + nil)) + +(define-mode-local-override semantic-ctxt-current-class-list + texinfo-mode (&optional point) + "Determine the class of tags that can be used at POINT. +For texinfo, there two possibilities returned. +1) 'function - for a call to a texinfo function +2) 'word - indicates an english word. +It would be nice to know function arguments too, but not today." + (let ((sym (semantic-ctxt-current-symbol))) + (if (and sym (= (aref (car sym) 0) ?@)) + '(function) + '(word)))) + + +;;; Overrides : Formatting +;; +;; Various override to better format texi tags. +;; + +(define-mode-local-override semantic-format-tag-abbreviate + texinfo-mode (tag &optional parent color) + "Texinfo tags abbreviation." + (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 + texinfo-mode (tag &optional parent color) + "Texinfo tags abbreviation." + (semantic-format-tag-abbreviate tag parent color)) + + +;;; Texi Unique Features +;; +(defun semantic-tag-texi-section-text-bounds (tag) + "Get the bounds to the text of TAG. +The text bounds is the text belonging to this node excluding +the text of any child nodes, but including any defuns." + (let ((memb (semantic-tag-components tag))) + ;; Members.. if one is a section, check it out. + (while (and memb (not (semantic-tag-of-class-p (car memb) 'section))) + (setq memb (cdr memb))) + ;; No members? ... then a simple problem! + (if (not memb) + (semantic-tag-bounds tag) + ;; Our end is their beginning... + (list (semantic-tag-start tag) (semantic-tag-start (car memb)))))) + +(defun semantic-texi-current-environment (&optional point) + "Return as a string the type of the current environment. +Optional argument POINT is where to look for the environment." + (save-excursion + (when point (goto-char (point))) + (while (and (or (not (looking-at semantic-texi-environment-regexp)) + (looking-at "@end")) + (not (semantic-up-context))) + ) + (when (looking-at semantic-texi-environment-regexp) + (match-string 1)))) + + +;;; Analyzer +;; +(eval-when-compile + (require 'semantic/analyze)) + +(define-mode-local-override semantic-analyze-current-context + texinfo-mode (point) + "Analysis context makes no sense for texinfo. Return nil." + (let* ((prefixandbounds (semantic-ctxt-current-symbol-and-bounds (point))) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + (prefixclass (semantic-ctxt-current-class-list)) + ) + (when prefix + (require 'semantic/analyze) + (semantic-analyze-context + "Context-for-texinfo" + :buffer (current-buffer) + :scope nil + :bounds bounds + :prefix prefix + :prefixtypes nil + :prefixclass prefixclass) + ) + )) + +(defvar semantic-texi-command-completion-list + (append (mapcar (lambda (a) (car a)) texinfo-section-list) + (condition-case nil + texinfo-environments + (error + ;; XEmacs doesn't use the above. Split up its regexp + (split-string texinfo-environment-regexp "\\\\|\\|\\^@\\\\(\\|\\\\)") + )) + ;; Is there a better list somewhere? Here are few + ;; of the top of my head. + "anchor" "asis" + "bullet" + "code" "copyright" + "defun" "deffn" "defoption" "defvar" "dfn" + "emph" "end" + "ifinfo" "iftex" "inforef" "item" "itemx" + "kdb" + "node" + "ref" + "set" "setfilename" "settitle" + "value" "var" + "xref" + ) + "List of commands that we might bother completing.") + +(define-mode-local-override semantic-analyze-possible-completions + texinfo-mode (context) + "List smart completions at point. +Since texinfo is not a programming language the default version is not +useful. Insted, look at the current symbol. If it is a command +do primitive texinfo built ins. If not, use ispell to lookup words +that start with that symbol." + (let ((prefix (car (oref context :prefix))) + ) + (cond ((member 'function (oref context :prefixclass)) + ;; Do completion for texinfo commands + (let* ((cmd (substring prefix 1)) + (lst (all-completions + cmd semantic-texi-command-completion-list))) + (mapcar (lambda (f) (semantic-tag (concat "@" f) 'function)) + lst)) + ) + ((member 'word (oref context :prefixclass)) + ;; Do completion for words via ispell. + (require 'ispell) + (let ((word-list (lookup-words prefix))) + (mapcar (lambda (f) (semantic-tag f 'word)) word-list)) + ) + (t nil)) + )) + + +;;; Parser Setup +;; +(defun semantic-default-texi-setup () + "Set up a buffer for parsing of Texinfo files." + ;; This will use our parser. + (semantic-install-function-overrides + '((parse-region . semantic-texi-parse-region) + (parse-changes . semantic-texi-parse-changes))) + (setq semantic-parser-name "TEXI" + ;; Setup a dummy parser table to enable parsing! + semantic--parse-table t + imenu-create-index-function 'semantic-create-imenu-index + semantic-command-separation-character "@" + semantic-type-relation-separator-character '(":") + semantic-symbol->name-assoc-list '((section . "Section") + (def . "Definition") + ) + semantic-imenu-expandable-tag-classes '(section) + semantic-imenu-bucketize-file nil + semantic-imenu-bucketize-type-members nil + senator-step-at-start-end-tag-classes '(section) + semantic-stickyfunc-sticky-classes '(section) + ) + ;; (local-set-key [(f9)] 'semantic-texi-update-doc-from-texi) + ) + +(add-hook 'texinfo-mode-hook 'semantic-default-texi-setup) + + +;;; Special features of Texinfo tag streams +;; +;; This section provides specialized access into texinfo files. +;; Because texinfo files often directly refer to functions and programs +;; it is useful to access the texinfo file from the C code for document +;; maintainance. +(defun semantic-texi-associated-files (&optional buffer) + "Find texinfo files associated with BUFFER." + (save-excursion + (if buffer (set-buffer buffer)) + (cond ((and (fboundp 'ede-documentation-files) + ede-minor-mode (ede-current-project)) + ;; When EDE is active, ask it. + (ede-documentation-files) + ) + ((and (featurep 'semantic/db) (semanticdb-minor-mode-p)) + ;; See what texinfo files we have loaded in the database + (let ((tabs (semanticdb-get-database-tables + semanticdb-current-database)) + (r nil)) + (while tabs + (if (eq (oref (car tabs) major-mode) 'texinfo-mode) + (setq r (cons (oref (car tabs) file) r))) + (setq tabs (cdr tabs))) + r)) + (t + (directory-files default-directory nil "\\.texi$")) + ))) + +;; Turns out this might not be useful. +;; Delete later if that is true. +(defun semantic-texi-find-documentation (name &optional type) + "Find the function or variable NAME of TYPE in the texinfo source. +NAME is a string representing some functional symbol. +TYPE is a string, such as \"variable\" or \"Command\" used to find +the correct definition in case NAME qualifies as several things. +When this function exists, POINT is at the definition. +If the doc was not found, an error is thrown. +Note: TYPE not yet implemented." + (let ((f (semantic-texi-associated-files)) + stream match) + (while (and f (not match)) + (unless stream + (with-current-buffer (find-file-noselect (car f)) + (setq stream (semantic-fetch-tags)))) + (setq match (semantic-find-first-tag-by-name name stream)) + (when match + (set-buffer (semantic-tag-buffer match)) + (goto-char (semantic-tag-start match))) + (setq f (cdr f))))) + +;; (defun semantic-texi-update-doc-from-texi (&optional tag) +;; "Update the documentation in the texinfo deffn class tag TAG. +;; The current buffer must be a texinfo file containing TAG. +;; If TAG is nil, determine a tag based on the current position." +;; (interactive) +;; (unless (or (featurep 'semantic/db) +;; (require 'semantic/db-mode) +;; (semanticdb-minor-mode-p)) +;; (error "Texinfo updating only works when `semanticdb' is being used")) +;; (semantic-fetch-tags) +;; (unless tag +;; (beginning-of-line) +;; (setq tag (semantic-current-tag))) +;; (unless (semantic-tag-of-class-p tag 'def) +;; (error "Only deffns (or defun or defvar) can be updated")) +;; (let* ((name (semantic-tag-name tag)) +;; (tags (semanticdb-strip-find-results +;; (semanticdb-with-match-any-mode +;; (semanticdb-brute-deep-find-tags-by-name name)) +;; 'name)) +;; (docstring nil) +;; (docstringproto nil) +;; (docstringvar nil) +;; (doctag nil) +;; (doctagproto nil) +;; (doctagvar nil) +;; ) +;; (save-excursion +;; (while (and tags (not docstring)) +;; (let ((sourcetag (car tags))) +;; ;; There could be more than one! Come up with a better +;; ;; solution someday. +;; (when (semantic-tag-buffer sourcetag) +;; (set-buffer (semantic-tag-buffer sourcetag)) +;; (unless (eq major-mode 'texinfo-mode) +;; (cond ((semantic-tag-get-attribute sourcetag :prototype-flag) +;; ;; If we found a match with doc that is a prototype, then store +;; ;; that, but don't exit till we find the real deal. +;; (setq docstringproto (semantic-documentation-for-tag sourcetag) +;; doctagproto sourcetag)) +;; ((eq (semantic-tag-class sourcetag) 'variable) +;; (setq docstringvar (semantic-documentation-for-tag sourcetag) +;; doctagvar sourcetag)) +;; ((semantic-tag-get-attribute sourcetag :override-function-flag) +;; nil) +;; (t +;; (setq docstring (semantic-documentation-for-tag sourcetag)))) +;; (setq doctag (if docstring sourcetag nil)))) +;; (setq tags (cdr tags))))) +;; ;; If we found a prototype of the function that has some doc, but not the +;; ;; actual function, lets make due with that. +;; (if (not docstring) +;; (cond ((stringp docstringvar) +;; (setq docstring docstringvar +;; doctag doctagvar)) +;; ((stringp docstringproto) +;; (setq docstring docstringproto +;; doctag doctagproto)))) +;; ;; Test for doc string +;; (unless docstring +;; (error "Could not find documentation for %s" (semantic-tag-name tag))) +;; ;; If we have a string, do the replacement. +;; (delete-region (semantic-tag-start tag) +;; (semantic-tag-end tag)) +;; ;; Use useful functions from the docaument library. +;; (require 'document) +;; (document-insert-texinfo doctag (semantic-tag-buffer doctag)) +;; )) + +;; (defun semantic-texi-update-doc-from-source (&optional tag) +;; "Update the documentation for the source TAG. +;; The current buffer must be a non-texinfo source file containing TAG. +;; If TAG is nil, determine the tag based on the current position. +;; The current buffer must include TAG." +;; (interactive) +;; (when (eq major-mode 'texinfo-mode) +;; (error "Not a source file")) +;; (semantic-fetch-tags) +;; (unless tag +;; (setq tag (semantic-current-tag))) +;; (unless (semantic-documentation-for-tag tag) +;; (error "Cannot find interesting documentation to use for %s" +;; (semantic-tag-name tag))) +;; (let* ((name (semantic-tag-name tag)) +;; (texi (semantic-texi-associated-files)) +;; (doctag nil) +;; (docbuff nil)) +;; (while (and texi (not doctag)) +;; (set-buffer (find-file-noselect (car texi))) +;; (setq doctag (car (semantic-deep-find-tags-by-name +;; name (semantic-fetch-tags))) +;; docbuff (if doctag (current-buffer) nil)) +;; (setq texi (cdr texi))) +;; (unless doctag +;; (error "Tag %s is not yet documented. Use the `document' command" +;; name)) +;; ;; Ok, we should have everything we need. Do the deed. +;; (if (get-buffer-window docbuff) +;; (set-buffer docbuff) +;; (switch-to-buffer docbuff)) +;; (goto-char (semantic-tag-start doctag)) +;; (delete-region (semantic-tag-start doctag) +;; (semantic-tag-end doctag)) +;; ;; Use useful functions from the document library. +;; (require 'document) +;; (document-insert-texinfo tag (semantic-tag-buffer tag)) +;; )) + +;; (defun semantic-texi-update-doc (&optional tag) +;; "Update the documentation for TAG. +;; If the current buffer is a texinfo file, then find the source doc, and +;; update it. If the current buffer is a source file, then get the +;; documentation for this item, find the existing doc in the associated +;; manual, and update that." +;; (interactive) +;; (cond ;;((eq major-mode 'texinfo-mode) +;; ;; (semantic-texi-update-doc-from-texi tag)) +;; (t +;; (semantic-texi-update-doc-from-source tag)))) + +(defun semantic-texi-goto-source (&optional tag) + "Jump to the source for the definition in the texinfo file TAG. +If TAG is nil, it is derived from the deffn under POINT." + (interactive) + (unless (or (featurep 'semantic/db) (semanticdb-minor-mode-p)) + (error "Texinfo updating only works when `semanticdb' is being used")) + (semantic-fetch-tags) + (unless tag + (beginning-of-line) + (setq tag (semantic-current-tag))) + (unless (semantic-tag-of-class-p tag 'def) + (error "Only deffns (or defun or defvar) can be updated")) + (let* ((name (semantic-tag-name tag)) + (tags (semanticdb-fast-strip-find-results + (semanticdb-with-match-any-mode + (semanticdb-brute-deep-find-tags-by-name name nil 'name)) + )) + + (done nil) + ) + (save-excursion + (while (and tags (not done)) + (set-buffer (semantic-tag-buffer (car tags))) + (unless (eq major-mode 'texinfo-mode) + (switch-to-buffer (semantic-tag-buffer (car tags))) + (goto-char (semantic-tag-start (car tags))) + (setq done t)) + (setq tags (cdr tags))) + (if (not done) + (error "Could not find tag for %s" (semantic-tag-name tag))) + ))) + +(provide 'semantic/texi) + +;;; semantic/texi.el ends here diff --git a/lisp/cedet/semantic/util-modes.el b/lisp/cedet/semantic/util-modes.el new file mode 100644 index 00000000000..6b64287840e --- /dev/null +++ b/lisp/cedet/semantic/util-modes.el @@ -0,0 +1,1237 @@ +;;; semantic/util-modes.el --- Semantic minor modes + +;;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2007, 2008, 2009 +;;; Free Software Foundation, Inc. + +;; Authors: Eric M. Ludlam <zappo@gnu.org> +;; David Ponce <david@dponce.com> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic utility minor modes. +;; + +;;; Code: +(require 'semantic) + +;;; Group for all semantic enhancing modes +(defgroup semantic-modes nil + "Minor modes associated with the Semantic architecture." + :group 'semantic) + +;;;; +;;;; Semantic minor modes stuff +;;;; +(defcustom semantic-update-mode-line t + "If non-nil, show enabled minor modes in the mode line. +Only minor modes that are not turned on globally are shown in the mode +line." + :group 'semantic + :type 'boolean + :require 'semantic/util-modes + :initialize 'custom-initialize-default + :set (lambda (sym val) + (set-default sym val) + ;; Update status of all Semantic enabled buffers + (semantic-map-buffers + #'semantic-mode-line-update))) + +(defcustom semantic-mode-line-prefix + (propertize "S" 'face 'bold) + "Prefix added to minor mode indicators in the mode line." + :group 'semantic + :type 'string + :require 'semantic/util-modes + :initialize 'custom-initialize-default) + +(defvar semantic-minor-modes-status nil + "String showing Semantic minor modes which are locally enabled. +It is displayed in the mode line.") +(make-variable-buffer-local 'semantic-minor-modes-status) + +(defvar semantic-minor-mode-alist nil + "Alist saying how to show Semantic minor modes in the mode line. +Like variable `minor-mode-alist'.") + +(defun semantic-mode-line-update () + "Update display of Semantic minor modes in the mode line. +Only minor modes that are locally enabled are shown in the mode line." + (setq semantic-minor-modes-status nil) + (if semantic-update-mode-line + (let ((ml semantic-minor-mode-alist) + mm ms see) + (while ml + (setq mm (car ml) + ms (cadr mm) + mm (car mm) + ml (cdr ml)) + (when (and (symbol-value mm) + ;; Only show local minor mode status + (not (memq mm semantic-init-hook))) + (and ms + (symbolp ms) + (setq ms (symbol-value ms))) + (and (stringp ms) + (not (member ms see)) ;; Don't duplicate same status + (setq see (cons ms see) + ms (if (string-match "^[ ]*\\(.+\\)" ms) + (match-string 1 ms))) + (setq semantic-minor-modes-status + (if semantic-minor-modes-status + (concat semantic-minor-modes-status "/" ms) + ms))))) + (if semantic-minor-modes-status + (setq semantic-minor-modes-status + (concat + " " + (if (string-match "^[ ]*\\(.+\\)" + semantic-mode-line-prefix) + (match-string 1 semantic-mode-line-prefix) + "S") + "/" + semantic-minor-modes-status)))))) + +(defun semantic-desktop-ignore-this-minor-mode (buffer) + "Installed as a minor-mode initializer for Desktop mode. +BUFFER is the buffer to not initialize a Semantic minor mode in." + nil) + +(defun semantic-add-minor-mode (toggle name &optional keymap) + "Register a new Semantic minor mode. +TOGGLE is a symbol which is the name of a buffer-local variable that +is toggled on or off to say whether the minor mode is active or not. +It is also an interactive function to toggle the mode. + +NAME specifies what will appear in the mode line when the minor mode +is active. NAME should be either a string starting with a space, or a +symbol whose value is such a string. + +Optional KEYMAP is the keymap for the minor mode that will be added to +`minor-mode-map-alist'." + ;; Add a dymmy semantic minor mode to display the status + (or (assq 'semantic-minor-modes-status minor-mode-alist) + (setq minor-mode-alist (cons (list 'semantic-minor-modes-status + 'semantic-minor-modes-status) + minor-mode-alist))) + (if (fboundp 'add-minor-mode) + ;; Emacs 21 & XEmacs + (add-minor-mode toggle "" keymap) + ;; Emacs 20 + (or (assq toggle minor-mode-alist) + (setq minor-mode-alist (cons (list toggle "") minor-mode-alist))) + (or (not keymap) + (assq toggle minor-mode-map-alist) + (setq minor-mode-map-alist (cons (cons toggle keymap) + minor-mode-map-alist)))) + ;; Record how to display this minor mode in the mode line + (let ((mm (assq toggle semantic-minor-mode-alist))) + (if mm + (setcdr mm (list name)) + (setq semantic-minor-mode-alist (cons (list toggle name) + semantic-minor-mode-alist)))) + + ;; Semantic minor modes don't work w/ Desktop restore. + ;; This line will disable this minor mode from being restored + ;; by Desktop. + (when (boundp 'desktop-minor-mode-handlers) + (add-to-list 'desktop-minor-mode-handlers + (cons toggle 'semantic-desktop-ignore-this-minor-mode))) + ) + +(defun semantic-toggle-minor-mode-globally (mode &optional arg) + "Toggle minor mode MODE in every Semantic enabled buffer. +Return non-nil if MODE is turned on in every Semantic enabled buffer. +If ARG is positive, enable, if it is negative, disable. If ARG is +nil, then toggle. Otherwise do nothing. MODE must be a valid minor +mode defined in `minor-mode-alist' and must be too an interactive +function used to toggle the mode." + (or (and (fboundp mode) (assq mode minor-mode-alist)) + (error "Semantic minor mode %s not found" mode)) + (if (not arg) + (if (memq mode semantic-init-hook) + (setq arg -1) + (setq arg 1))) + ;; Add or remove the MODE toggle function from + ;; `semantic-init-hook'. Then turn MODE on or off in every + ;; Semantic enabled buffer. + (cond + ;; Turn off if ARG < 0 + ((< arg 0) + (remove-hook 'semantic-init-hook mode) + (semantic-map-buffers #'(lambda () (funcall mode -1))) + nil) + ;; Turn on if ARG > 0 + ((> arg 0) + (add-hook 'semantic-init-hook mode) + (semantic-map-buffers #'(lambda () (funcall mode 1))) + t) + ;; Otherwise just check MODE state + (t + (memq mode semantic-init-hook)) + )) + +;;;; +;;;; Minor mode to highlight areas that a user edits. +;;;; + +;;;###autoload +(defun global-semantic-highlight-edits-mode (&optional arg) + "Toggle global use of option `semantic-highlight-edits-mode'. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle." + (interactive "P") + (setq global-semantic-highlight-edits-mode + (semantic-toggle-minor-mode-globally + 'semantic-highlight-edits-mode arg))) + +;;;###autoload +(defcustom global-semantic-highlight-edits-mode nil + "If non-nil enable global use of variable `semantic-highlight-edits-mode'. +When this mode is enabled, changes made to a buffer are highlighted +until the buffer is reparsed." + :group 'semantic + :group 'semantic-modes + :type 'boolean + :require 'semantic/util-modes + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-semantic-highlight-edits-mode (if val 1 -1)))) + +(defcustom semantic-highlight-edits-mode-hook nil + "Hook run at the end of function `semantic-highlight-edits-mode'." + :group 'semantic + :type 'hook) + +(defface semantic-highlight-edits-face + '((((class color) (background dark)) + ;; Put this back to something closer to black later. + (:background "gray20")) + (((class color) (background light)) + (:background "gray90"))) + "Face used to show dirty tokens in `semantic-highlight-edits-mode'." + :group 'semantic-faces) + +(defun semantic-highlight-edits-new-change-hook-fcn (overlay) + "Function set into `semantic-edits-new-change-hook'. +Argument OVERLAY is the overlay created to mark the change. +This function will set the face property on this overlay." + (semantic-overlay-put overlay 'face 'semantic-highlight-edits-face)) + +(defvar semantic-highlight-edits-mode-map + (let ((km (make-sparse-keymap))) + km) + "Keymap for highlight-edits minor mode.") + +(defvar semantic-highlight-edits-mode nil + "Non-nil if highlight-edits minor mode is enabled. +Use the command `semantic-highlight-edits-mode' to change this variable.") +(make-variable-buffer-local 'semantic-highlight-edits-mode) + +(defun semantic-highlight-edits-mode-setup () + "Setup option `semantic-highlight-edits-mode'. +The minor mode can be turned on only if semantic feature is available +and the current buffer was set up for parsing. When minor mode is +enabled parse the current buffer if needed. Return non-nil if the +minor mode is enabled." + (if semantic-highlight-edits-mode + (if (not (and (featurep 'semantic) (semantic-active-p))) + (progn + ;; Disable minor mode if semantic stuff not available + (setq semantic-highlight-edits-mode nil) + (error "Buffer %s was not set up for parsing" + (buffer-name))) + (semantic-make-local-hook 'semantic-edits-new-change-hooks) + (add-hook 'semantic-edits-new-change-hooks + 'semantic-highlight-edits-new-change-hook-fcn nil t) + ) + ;; Remove hooks + (remove-hook 'semantic-edits-new-change-hooks + 'semantic-highlight-edits-new-change-hook-fcn t) + ) + semantic-highlight-edits-mode) + +;;;###autoload +(defun semantic-highlight-edits-mode (&optional arg) + "Minor mode for highlighting changes made in a buffer. +Changes are tracked by semantic so that the incremental parser can work +properly. +This mode will highlight those changes as they are made, and clear them +when the incremental parser accounts for those edits. +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled." + (interactive + (list (or current-prefix-arg + (if semantic-highlight-edits-mode 0 1)))) + (setq semantic-highlight-edits-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not semantic-highlight-edits-mode))) + (semantic-highlight-edits-mode-setup) + (run-hooks 'semantic-highlight-edits-mode-hook) + (if (interactive-p) + (message "highlight-edits minor mode %sabled" + (if semantic-highlight-edits-mode "en" "dis"))) + (semantic-mode-line-update) + semantic-highlight-edits-mode) + +(semantic-add-minor-mode 'semantic-highlight-edits-mode + "e" + semantic-highlight-edits-mode-map) + + +;;;; +;;;; Minor mode to show unmatched-syntax elements +;;;; + +;;;###autoload +(defun global-semantic-show-unmatched-syntax-mode (&optional arg) + "Toggle global use of option `semantic-show-unmatched-syntax-mode'. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle." + (interactive "P") + (setq global-semantic-show-unmatched-syntax-mode + (semantic-toggle-minor-mode-globally + 'semantic-show-unmatched-syntax-mode arg))) + +;;;###autoload +(defcustom global-semantic-show-unmatched-syntax-mode nil + "If non-nil, enable global use of `semantic-show-unmatched-syntax-mode'. +When this mode is enabled, syntax in the current buffer which the +semantic parser cannot match is highlighted with a red underline." + :group 'semantic + :group 'semantic-modes + :type 'boolean + :require 'semantic/util-modes + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-semantic-show-unmatched-syntax-mode (if val 1 -1)))) + +(defcustom semantic-show-unmatched-syntax-mode-hook nil + "Hook run at the end of function `semantic-show-unmatched-syntax-mode'." + :group 'semantic + :type 'hook) + +(defface semantic-unmatched-syntax-face + '((((class color) (background dark)) + (:underline "red")) + (((class color) (background light)) + (:underline "red"))) + "Face used to show unmatched syntax in. +The face is used in `semantic-show-unmatched-syntax-mode'." + :group 'semantic-faces) + +(defsubst semantic-unmatched-syntax-overlay-p (overlay) + "Return non-nil if OVERLAY is an unmatched syntax one." + (eq (semantic-overlay-get overlay 'semantic) 'unmatched)) + +(defun semantic-showing-unmatched-syntax-p () + "Return non-nil if an unmatched syntax overlay was found in buffer." + (let ((ol (semantic-overlays-in (point-min) (point-max))) + found) + (while (and ol (not found)) + (setq found (semantic-unmatched-syntax-overlay-p (car ol)) + ol (cdr ol))) + found)) + +(defun semantic-show-unmatched-lex-tokens-fetch () + "Fetch a list of unmatched lexical tokens from the current buffer. +Uses the overlays which have accurate bounds, and rebuilds what was +originally passed in." + (let ((ol (semantic-overlays-in (point-min) (point-max))) + (ustc nil)) + (while ol + (if (semantic-unmatched-syntax-overlay-p (car ol)) + (setq ustc (cons (cons 'thing + (cons (semantic-overlay-start (car ol)) + (semantic-overlay-end (car ol)))) + ustc))) + (setq ol (cdr ol))) + (nreverse ustc)) + ) + +(defun semantic-clean-unmatched-syntax-in-region (beg end) + "Remove all unmatched syntax overlays between BEG and END." + (let ((ol (semantic-overlays-in beg end))) + (while ol + (if (semantic-unmatched-syntax-overlay-p (car ol)) + (semantic-overlay-delete (car ol))) + (setq ol (cdr ol))))) + +(defsubst semantic-clean-unmatched-syntax-in-buffer () + "Remove all unmatched syntax overlays found in current buffer." + (semantic-clean-unmatched-syntax-in-region + (point-min) (point-max))) + +(defsubst semantic-clean-token-of-unmatched-syntax (token) + "Clean the area covered by TOKEN of unmatched syntax markers." + (semantic-clean-unmatched-syntax-in-region + (semantic-tag-start token) (semantic-tag-end token))) + +(defun semantic-show-unmatched-syntax (syntax) + "Function set into `semantic-unmatched-syntax-hook'. +This will highlight elements in SYNTAX as unmatched syntax." + ;; This is called when `semantic-show-unmatched-syntax-mode' is + ;; enabled. Highlight the unmatched syntax, and then add a semantic + ;; property to that overlay so we can add it to the official list of + ;; semantic supported overlays. This gets it cleaned up for errors, + ;; buffer cleaning, and the like. + (semantic-clean-unmatched-syntax-in-buffer) ;Clear previous highlighting + (if syntax + (let (o) + (while syntax + (setq o (semantic-make-overlay (semantic-lex-token-start (car syntax)) + (semantic-lex-token-end (car syntax)))) + (semantic-overlay-put o 'semantic 'unmatched) + (semantic-overlay-put o 'face 'semantic-unmatched-syntax-face) + (setq syntax (cdr syntax)))) + )) + +(defun semantic-next-unmatched-syntax (point &optional bound) + "Find the next overlay for unmatched syntax after POINT. +Do not search past BOUND if non-nil." + (save-excursion + (goto-char point) + (let ((os point) (ol nil)) + (while (and os (< os (or bound (point-max))) (not ol)) + (setq os (semantic-overlay-next-change os)) + (when os + ;; Get overlays at position + (setq ol (semantic-overlays-at os)) + ;; find the overlay that belongs to semantic + ;; and starts at the found position. + (while (and ol (listp ol)) + (and (semantic-unmatched-syntax-overlay-p (car ol)) + (setq ol (car ol))) + (if (listp ol) + (setq ol (cdr ol)))))) + ol))) + +(defvar semantic-show-unmatched-syntax-mode-map + (let ((km (make-sparse-keymap))) + (define-key km "\C-c,`" 'semantic-show-unmatched-syntax-next) + km) + "Keymap for command `semantic-show-unmatched-syntax-mode'.") + +(defvar semantic-show-unmatched-syntax-mode nil + "Non-nil if show-unmatched-syntax minor mode is enabled. +Use the command `semantic-show-unmatched-syntax-mode' to change this +variable.") +(make-variable-buffer-local 'semantic-show-unmatched-syntax-mode) + +(defun semantic-show-unmatched-syntax-mode-setup () + "Setup the `semantic-show-unmatched-syntax' minor mode. +The minor mode can be turned on only if semantic feature is available +and the current buffer was set up for parsing. When minor mode is +enabled parse the current buffer if needed. Return non-nil if the +minor mode is enabled." + (if semantic-show-unmatched-syntax-mode + (if (not (and (featurep 'semantic) (semantic-active-p))) + (progn + ;; Disable minor mode if semantic stuff not available + (setq semantic-show-unmatched-syntax-mode nil) + (error "Buffer %s was not set up for parsing" + (buffer-name))) + ;; Add hooks + (semantic-make-local-hook 'semantic-unmatched-syntax-hook) + (add-hook 'semantic-unmatched-syntax-hook + 'semantic-show-unmatched-syntax nil t) + (semantic-make-local-hook 'semantic-pre-clean-token-hooks) + (add-hook 'semantic-pre-clean-token-hooks + 'semantic-clean-token-of-unmatched-syntax nil t) + ;; Show unmatched syntax elements + (if (not (semantic--umatched-syntax-needs-refresh-p)) + (semantic-show-unmatched-syntax + (semantic-unmatched-syntax-tokens)))) + ;; Remove hooks + (remove-hook 'semantic-unmatched-syntax-hook + 'semantic-show-unmatched-syntax t) + (remove-hook 'semantic-pre-clean-token-hooks + 'semantic-clean-token-of-unmatched-syntax t) + ;; Cleanup unmatched-syntax highlighting + (semantic-clean-unmatched-syntax-in-buffer)) + semantic-show-unmatched-syntax-mode) + +;;;###autoload +(defun semantic-show-unmatched-syntax-mode (&optional arg) + "Minor mode to highlight unmatched lexical syntax tokens. +When a parser executes, some elements in the buffer may not match any +parser rules. These text characters are considered unmatched syntax. +Often time, the display of unmatched syntax can expose coding +problems before the compiler is run. + +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled. + +\\{semantic-show-unmatched-syntax-mode-map}" + (interactive + (list (or current-prefix-arg + (if semantic-show-unmatched-syntax-mode 0 1)))) + (setq semantic-show-unmatched-syntax-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not semantic-show-unmatched-syntax-mode))) + (semantic-show-unmatched-syntax-mode-setup) + (run-hooks 'semantic-show-unmatched-syntax-mode-hook) + (if (interactive-p) + (message "show-unmatched-syntax minor mode %sabled" + (if semantic-show-unmatched-syntax-mode "en" "dis"))) + (semantic-mode-line-update) + semantic-show-unmatched-syntax-mode) + +(semantic-add-minor-mode 'semantic-show-unmatched-syntax-mode + "u" + semantic-show-unmatched-syntax-mode-map) + +(defun semantic-show-unmatched-syntax-next () + "Move forward to the next occurrence of unmatched syntax." + (interactive) + (let ((o (semantic-next-unmatched-syntax (point)))) + (if o + (goto-char (semantic-overlay-start o))))) + + +;;;; +;;;; Minor mode to display the parser state in the modeline. +;;;; + +;;;###autoload +(defcustom global-semantic-show-parser-state-mode nil + "If non-nil enable global use of `semantic-show-parser-state-mode'. +When enabled, the current parse state of the current buffer is displayed +in the mode line. See `semantic-show-parser-state-marker' for details +on what is displayed." + :group 'semantic + :type 'boolean + :require 'semantic/util-modes + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-semantic-show-parser-state-mode (if val 1 -1)))) + +;;;###autoload +(defun global-semantic-show-parser-state-mode (&optional arg) + "Toggle global use of option `semantic-show-parser-state-mode'. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle." + (interactive "P") + (setq global-semantic-show-parser-state-mode + (semantic-toggle-minor-mode-globally + 'semantic-show-parser-state-mode arg))) + +(defcustom semantic-show-parser-state-mode-hook nil + "Hook run at the end of function `semantic-show-parser-state-mode'." + :group 'semantic + :type 'hook) + +(defvar semantic-show-parser-state-mode-map + (let ((km (make-sparse-keymap))) + km) + "Keymap for show-parser-state minor mode.") + +(defvar semantic-show-parser-state-mode nil + "Non-nil if show-parser-state minor mode is enabled. +Use the command `semantic-show-parser-state-mode' to change this variable.") +(make-variable-buffer-local 'semantic-show-parser-state-mode) + +(defun semantic-show-parser-state-mode-setup () + "Setup option `semantic-show-parser-state-mode'. +The minor mode can be turned on only if semantic feature is available +and the current buffer was set up for parsing. When minor mode is +enabled parse the current buffer if needed. Return non-nil if the +minor mode is enabled." + (if semantic-show-parser-state-mode + (if (not (and (featurep 'semantic) (semantic-active-p))) + (progn + ;; Disable minor mode if semantic stuff not available + (setq semantic-show-parser-state-mode nil) + (error "Buffer %s was not set up for parsing" + (buffer-name))) + ;; Set up mode line + + (when (not + (memq 'semantic-show-parser-state-string mode-line-modified)) + (setq mode-line-modified + (append mode-line-modified + '(semantic-show-parser-state-string)))) + ;; Add hooks + (semantic-make-local-hook 'semantic-edits-new-change-hooks) + (add-hook 'semantic-edits-new-change-hooks + 'semantic-show-parser-state-marker nil t) + (semantic-make-local-hook 'semantic-edits-incremental-reparse-failed-hook) + (add-hook 'semantic-edits-incremental-reparse-failed-hook + 'semantic-show-parser-state-marker nil t) + (semantic-make-local-hook 'semantic-after-partial-cache-change-hook) + (add-hook 'semantic-after-partial-cache-change-hook + 'semantic-show-parser-state-marker nil t) + (semantic-make-local-hook 'semantic-after-toplevel-cache-change-hook) + (add-hook 'semantic-after-toplevel-cache-change-hook + 'semantic-show-parser-state-marker nil t) + (semantic-show-parser-state-marker) + + (semantic-make-local-hook 'semantic-before-auto-parse-hooks) + (add-hook 'semantic-before-auto-parse-hooks + 'semantic-show-parser-state-auto-marker nil t) + (semantic-make-local-hook 'semantic-after-auto-parse-hooks) + (add-hook 'semantic-after-auto-parse-hooks + 'semantic-show-parser-state-marker nil t) + + (semantic-make-local-hook 'semantic-before-idle-scheduler-reparse-hook) + (add-hook 'semantic-before-idle-scheduler-reparse-hook + 'semantic-show-parser-state-auto-marker nil t) + (semantic-make-local-hook 'semantic-after-idle-scheduler-reparse-hook) + (add-hook 'semantic-after-idle-scheduler-reparse-hook + 'semantic-show-parser-state-marker nil t) + ) + ;; Remove parts of mode line + (setq mode-line-modified + (delq 'semantic-show-parser-state-string mode-line-modified)) + ;; Remove hooks + (remove-hook 'semantic-edits-new-change-hooks + 'semantic-show-parser-state-marker t) + (remove-hook 'semantic-edits-incremental-reparse-failed-hook + 'semantic-show-parser-state-marker t) + (remove-hook 'semantic-after-partial-cache-change-hook + 'semantic-show-parser-state-marker t) + (remove-hook 'semantic-after-toplevel-cache-change-hook + 'semantic-show-parser-state-marker t) + + (remove-hook 'semantic-before-auto-parse-hooks + 'semantic-show-parser-state-auto-marker t) + (remove-hook 'semantic-after-auto-parse-hooks + 'semantic-show-parser-state-marker t) + + (remove-hook 'semantic-before-idle-scheduler-reparse-hook + 'semantic-show-parser-state-auto-marker t) + (remove-hook 'semantic-after-idle-scheduler-reparse-hook + 'semantic-show-parser-state-marker t) + ) + semantic-show-parser-state-mode) + +;;;###autoload +(defun semantic-show-parser-state-mode (&optional arg) + "Minor mode for displaying parser cache state in the modeline. +The cache can be in one of three states. They are +Up to date, Partial reprase needed, and Full reparse needed. +The state is indicated in the modeline with the following characters: + `-' -> The cache is up to date. + `!' -> The cache requires a full update. + `~' -> The cache needs to be incrementally parsed. + `%' -> The cache is not currently parseable. + `@' -> Auto-parse in progress (not set here.) +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled." + (interactive + (list (or current-prefix-arg + (if semantic-show-parser-state-mode 0 1)))) + (setq semantic-show-parser-state-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not semantic-show-parser-state-mode))) + (semantic-show-parser-state-mode-setup) + (run-hooks 'semantic-show-parser-state-mode-hook) + (if (interactive-p) + (message "show-parser-state minor mode %sabled" + (if semantic-show-parser-state-mode "en" "dis"))) + (semantic-mode-line-update) + semantic-show-parser-state-mode) + +(semantic-add-minor-mode 'semantic-show-parser-state-mode + "" + semantic-show-parser-state-mode-map) + +(defvar semantic-show-parser-state-string nil + "String showing the parser state for this buffer. +See `semantic-show-parser-state-marker' for details.") +(make-variable-buffer-local 'semantic-show-parser-state-string) + +(defun semantic-show-parser-state-marker (&rest ignore) + "Set `semantic-show-parser-state-string' to indicate parser state. +This marker is one of the following: + `-' -> The cache is up to date. + `!' -> The cache requires a full update. + `~' -> The cache needs to be incrementally parsed. + `%' -> The cache is not currently parseable. + `@' -> Auto-parse in progress (not set here.) +Arguments IGNORE are ignored, and accepted so this can be used as a hook +in many situations." + (setq semantic-show-parser-state-string + (cond ((semantic-parse-tree-needs-rebuild-p) + "!") + ((semantic-parse-tree-needs-update-p) + "^") + ((semantic-parse-tree-unparseable-p) + "%") + (t + "-"))) + ;;(message "Setup mode line indicator to [%s]" semantic-show-parser-state-string) + (semantic-mode-line-update)) + +(defun semantic-show-parser-state-auto-marker () + "Hook function run before an autoparse. +Set up `semantic-show-parser-state-marker' to show `@' +to indicate a parse in progress." + (unless (semantic-parse-tree-up-to-date-p) + (setq semantic-show-parser-state-string "@") + (semantic-mode-line-update) + ;; For testing. + ;;(sit-for 1) + )) + + +;;;; +;;;; Minor mode to make function decls sticky. +;;;; + +;;;###autoload +(defun global-semantic-stickyfunc-mode (&optional arg) + "Toggle global use of option `semantic-stickyfunc-mode'. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle." + (interactive "P") + (setq global-semantic-stickyfunc-mode + (semantic-toggle-minor-mode-globally + 'semantic-stickyfunc-mode arg))) + +;;;###autoload +(defcustom global-semantic-stickyfunc-mode nil + "If non-nil, enable global use of `semantic-stickyfunc-mode'. +This minor mode only works for Emacs 21 or later. +When enabled, the header line is enabled, and the first line +of the current function or method is displayed in it. +This makes it appear that the first line of that tag is +`sticky' to the top of the window." + :group 'semantic + :group 'semantic-modes + :type 'boolean + :require 'semantic/util-modes + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-semantic-stickyfunc-mode (if val 1 -1)))) + +(defcustom semantic-stickyfunc-mode-hook nil + "Hook run at the end of function `semantic-stickyfunc-mode'." + :group 'semantic + :type 'hook) + +(defvar semantic-stickyfunc-mode-map + (let ((km (make-sparse-keymap))) + (define-key km [ header-line down-mouse-1 ] 'semantic-stickyfunc-menu) + km) + "Keymap for stickyfunc minor mode.") + +(defvar semantic-stickyfunc-popup-menu nil + "Menu used if the user clicks on the header line used by stickyfunc mode.") + +(easy-menu-define + semantic-stickyfunc-popup-menu + semantic-stickyfunc-mode-map + "Stickyfunc Menu" + '("Stickyfunc Mode" :visible (progn nil) + [ "Copy Headerline Tag" senator-copy-tag + :active (semantic-current-tag) + :help "Copy the current tag to the tag ring"] + [ "Kill Headerline Tag" senator-kill-tag + :active (semantic-current-tag) + :help "Kill tag text to the kill ring, and copy the tag to the tag ring" + ] + [ "Copy Headerline Tag to Register" senator-copy-tag-to-register + :active (semantic-current-tag) + :help "Copy the current tag to a register" + ] + [ "Narrow To Headerline Tag" senator-narrow-to-defun + :active (semantic-current-tag) + :help "Narrow to the bounds of the current tag."] + [ "Fold Headerline Tag" senator-fold-tag-toggle + :active (semantic-current-tag) + :style toggle + :selected (let ((tag (semantic-current-tag))) + (and tag (semantic-tag-folded-p tag))) + :help "Fold the current tag to one line" + ] + "---" + [ "About This Header Line" + (lambda () (interactive) + (describe-function 'semantic-stickyfunc-mode)) t]) + ) + +(defvar semantic-stickyfunc-mode nil + "Non-nil if stickyfunc minor mode is enabled. +Use the command `semantic-stickyfunc-mode' to change this variable.") +(make-variable-buffer-local 'semantic-stickyfunc-mode) + +(defcustom semantic-stickyfunc-indent-string + (if (and window-system (not (featurep 'xemacs))) + (concat + (condition-case nil + ;; Test scroll bar location + (let ((charwidth (frame-char-width)) + (scrollpos (frame-parameter (selected-frame) + 'vertical-scroll-bars)) + ) + (if (or (eq scrollpos 'left) + ;; Now wait a minute. If you turn scroll-bar-mode + ;; on, then off, the new value is t, not left. + ;; Will this mess up older emacs where the default + ;; was on the right? I don't think so since they don't + ;; support a header line. + (eq scrollpos t)) + (let ((w (when (boundp 'scroll-bar-width) + (symbol-value 'scroll-bar-width)))) + + (if (not w) + (setq w (frame-parameter (selected-frame) + 'scroll-bar-width))) + + ;; in 21.2, the frame parameter is sometimes empty + ;; so we need to get the value here. + (if (not w) + (setq w (+ (get 'scroll-bar-width 'x-frame-parameter) + ;; In 21.4, or perhaps 22.1 the x-frame + ;; parameter is different from the frame + ;; parameter by only 1 pixel. + 1))) + + (if (not w) + " " + (setq w (+ 2 w)) ; Some sort of border around + ; the scrollbar. + (make-string (/ w charwidth) ? ))) + "")) + (error "")) + (condition-case nil + ;; Test fringe size. + (let* ((f (window-fringes)) + (fw (car f)) + (numspace (/ fw (frame-char-width))) + ) + (make-string numspace ? )) + (error + ;; Well, the fancy new Emacs functions failed. Try older + ;; tricks. + (condition-case nil + ;; I'm not so sure what's up with the 21.1-21.3 fringe. + ;; It looks to be about 1 space wide. + (if (get 'fringe 'face) + " " + "") + (error "")))) + ) + ;; Not Emacs or a window system means no scrollbar or fringe, + ;; and perhaps not even a header line to worry about. + "") + "String used to indent the stickyfunc header. +Customize this string to match the space used by scrollbars and +fringe so it does not appear that the code is moving left/right +when it lands in the sticky line." + :group 'semantic + :type 'string) + +(defvar semantic-stickyfunc-old-hlf nil + "Value of the header line when entering sticky func mode.") + +(defconst semantic-stickyfunc-header-line-format + (cond ((featurep 'xemacs) + nil) + ((>= emacs-major-version 22) + '(:eval (list + ;; Magic bit I found on emacswiki. + (propertize " " 'display '((space :align-to 0))) + (semantic-stickyfunc-fetch-stickyline)))) + ((= emacs-major-version 21) + '(:eval (list semantic-stickyfunc-indent-string + (semantic-stickyfunc-fetch-stickyline)))) + (t nil)) + "The header line format used by sticky func mode.") + +(defun semantic-stickyfunc-mode-setup () + "Setup option `semantic-stickyfunc-mode'. +For semantic enabled buffers, make the function declaration for the top most +function \"sticky\". This is accomplished by putting the first line of +text for that function in Emacs 21's header line." + (if semantic-stickyfunc-mode + (progn + (unless (and (featurep 'semantic) (semantic-active-p)) + ;; Disable minor mode if semantic stuff not available + (setq semantic-stickyfunc-mode nil) + (error "Buffer %s was not set up for parsing" (buffer-name))) + (unless (boundp 'default-header-line-format) + ;; Disable if there are no header lines to use. + (setq semantic-stickyfunc-mode nil) + (error "Sticky Function mode requires Emacs 21")) + ;; Enable the mode + ;; Save previous buffer local value of header line format. + (when (and (local-variable-p 'header-line-format (current-buffer)) + (not (eq header-line-format + semantic-stickyfunc-header-line-format))) + (set (make-local-variable 'semantic-stickyfunc-old-hlf) + header-line-format)) + (setq header-line-format semantic-stickyfunc-header-line-format) + ) + ;; Disable sticky func mode + ;; Restore previous buffer local value of header line format if + ;; the current one is the sticky func one. + (when (eq header-line-format semantic-stickyfunc-header-line-format) + (kill-local-variable 'header-line-format) + (when (local-variable-p 'semantic-stickyfunc-old-hlf (current-buffer)) + (setq header-line-format semantic-stickyfunc-old-hlf) + (kill-local-variable 'semantic-stickyfunc-old-hlf)))) + semantic-stickyfunc-mode) + +;;;###autoload +(defun semantic-stickyfunc-mode (&optional arg) + "Minor mode to show the title of a tag in the header line. +Enables/disables making the header line of functions sticky. +A function (or other tag class specified by +`semantic-stickyfunc-sticky-classes') has a header line, meaning the +first line which describes the rest of the construct. This first +line is what is displayed in the Emacs 21 header line. + +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled." + (interactive + (list (or current-prefix-arg + (if semantic-stickyfunc-mode 0 1)))) + (setq semantic-stickyfunc-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not semantic-stickyfunc-mode))) + (semantic-stickyfunc-mode-setup) + (run-hooks 'semantic-stickyfunc-mode-hook) + (if (interactive-p) + (message "Stickyfunc minor mode %sabled" + (if semantic-stickyfunc-mode "en" "dis"))) + (semantic-mode-line-update) + semantic-stickyfunc-mode) + +(defvar semantic-stickyfunc-sticky-classes + '(function type) + "List of tag classes which sticky func will display in the header line.") +(make-variable-buffer-local 'semantic-stickyfunc-sticky-classes) + +(defun semantic-stickyfunc-tag-to-stick () + "Return the tag to stick at the current point." + (let ((tags (nreverse (semantic-find-tag-by-overlay (point))))) + ;; Get rid of non-matching tags. + (while (and tags + (not (member + (semantic-tag-class (car tags)) + semantic-stickyfunc-sticky-classes)) + ) + (setq tags (cdr tags))) + (car tags))) + +(defun semantic-stickyfunc-fetch-stickyline () + "Make the function at the top of the current window sticky. +Capture it's function declaration, and place it in the header line. +If there is no function, disable the header line." + (let ((str + (save-excursion + (goto-char (window-start (selected-window))) + (forward-line -1) + (end-of-line) + ;; Capture this function + (let* ((tag (semantic-stickyfunc-tag-to-stick))) + ;; TAG is nil if there was nothing of the apropriate type there. + (if (not tag) + ;; Set it to be the text under the header line + (buffer-substring (point-at-bol) (point-at-eol)) + ;; Get it + (goto-char (semantic-tag-start tag)) + ;; Klaus Berndl <klaus.berndl@sdm.de>: + ;; goto the tag name; this is especially needed for languages + ;; like c++ where a often used style is like: + ;; void + ;; ClassX::methodM(arg1...) + ;; { + ;; ... + ;; } + ;; Without going to the tag-name we would get"void" in the + ;; header line which is IMHO not really useful + (search-forward (semantic-tag-name tag) nil t) + (buffer-substring (point-at-bol) (point-at-eol)) + )))) + (start 0)) + (while (string-match "%" str start) + (setq str (replace-match "%%" t t str 0) + start (1+ (match-end 0))) + ) + ;; In 21.4 (or 22.1) the heder doesn't expand tabs. Hmmmm. + ;; We should replace them here. + ;; + ;; This hack assumes that tabs are kept smartly at tab boundaries + ;; instead of in a tab boundary where it might only represent 4 spaces. + (while (string-match "\t" str start) + (setq str (replace-match " " t t str 0))) + str)) + +(defun semantic-stickyfunc-menu (event) + "Popup a menu that can help a user understand stickyfunc-mode. +Argument EVENT describes the event that caused this function to be called." + (interactive "e") + (let* ((startwin (selected-window)) + (win (car (car (cdr event)))) + ) + (select-window win t) + (save-excursion + (goto-char (window-start win)) + (sit-for 0) + (popup-menu semantic-stickyfunc-popup-menu event) + ) + (select-window startwin))) + + +(semantic-add-minor-mode 'semantic-stickyfunc-mode + "" ;; Don't need indicator. It's quite visible + semantic-stickyfunc-mode-map) + + + +;;;; +;;;; Minor mode to make highlight the current function +;;;; + +;; Highlight the first like of the function we are in if it is different +;; from the the tag going off the top of the screen. + +;;;###autoload +(defun global-semantic-highlight-func-mode (&optional arg) + "Toggle global use of option `semantic-highlight-func-mode'. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle." + (interactive "P") + (setq global-semantic-highlight-func-mode + (semantic-toggle-minor-mode-globally + 'semantic-highlight-func-mode arg))) + +;;;###autoload +(defcustom global-semantic-highlight-func-mode nil + "If non-nil, enable global use of `semantic-highlight-func-mode'. +When enabled, the first line of the current tag is highlighted." + :group 'semantic + :group 'semantic-modes + :type 'boolean + :require 'semantic/util-modes + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-semantic-highlight-func-mode (if val 1 -1)))) + +(defcustom semantic-highlight-func-mode-hook nil + "Hook run at the end of function `semantic-highlight-func-mode'." + :group 'semantic + :type 'hook) + +(defvar semantic-highlight-func-mode-map + (let ((km (make-sparse-keymap)) + (m3 (if (featurep 'xemacs) [ button3 ] [ mouse-3 ])) + ) + (define-key km m3 'semantic-highlight-func-menu) + km) + "Keymap for highlight-func minor mode.") + +(defvar semantic-highlight-func-popup-menu nil + "Menu used if the user clicks on the header line used by `semantic-highlight-func-mode'.") + +(easy-menu-define + semantic-highlight-func-popup-menu + semantic-highlight-func-mode-map + "Highlight-Func Menu" + '("Highlight-Func Mode" :visible (progn nil) + [ "Copy Tag" senator-copy-tag + :active (semantic-current-tag) + :help "Copy the current tag to the tag ring"] + [ "Kill Tag" senator-kill-tag + :active (semantic-current-tag) + :help "Kill tag text to the kill ring, and copy the tag to the tag ring" + ] + [ "Copy Tag to Register" senator-copy-tag-to-register + :active (semantic-current-tag) + :help "Copy the current tag to a register" + ] + [ "Narrow To Tag" senator-narrow-to-defun + :active (semantic-current-tag) + :help "Narrow to the bounds of the current tag."] + [ "Fold Tag" senator-fold-tag-toggle + :active (semantic-current-tag) + :style toggle + :selected (let ((tag (semantic-stickyfunc-tag-to-stick))) + (and tag (semantic-tag-folded-p tag))) + :help "Fold the current tag to one line" + ] + "---" + [ "About This Tag" semantic-describe-tag t]) + ) + +(defun semantic-highlight-func-menu (event) + "Popup a menu that displays things to do to the current tag. +Argument EVENT describes the event that caused this function to be called." + (interactive "e") + (let* ((startwin (selected-window)) + (win (semantic-event-window event)) + ) + (select-window win t) + (save-excursion + ;(goto-char (window-start win)) + (mouse-set-point event) + (sit-for 0) + (semantic-popup-menu semantic-highlight-func-popup-menu) + ) + (select-window startwin))) + +(defvar semantic-highlight-func-mode nil + "Non-nil if highlight-func minor mode is enabled. +Use the command `semantic-highlight-func-mode' to change this variable.") +(make-variable-buffer-local 'semantic-highlight-func-mode) + +(defvar semantic-highlight-func-ct-overlay nil + "Overlay used to highlight the tag the cursor is in.") +(make-variable-buffer-local 'semantic-highlight-func-ct-overlay) + +(defface semantic-highlight-func-current-tag-face + '((((class color) (background dark)) + ;; Put this back to something closer to black later. + (:background "gray20")) + (((class color) (background light)) + (:background "gray90"))) + "Face used to show the top of current function." + :group 'semantic-faces) + + +(defun semantic-highlight-func-mode-setup () + "Setup option `semantic-highlight-func-mode'. +For semantic enabled buffers, highlight the first line of the +current tag declaration." + (if semantic-highlight-func-mode + (progn + (unless (and (featurep 'semantic) (semantic-active-p)) + ;; Disable minor mode if semantic stuff not available + (setq semantic-highlight-func-mode nil) + (error "Buffer %s was not set up for parsing" (buffer-name))) + ;; Setup our hook + (add-hook 'post-command-hook 'semantic-highlight-func-highlight-current-tag nil t) + ) + ;; Disable highlight func mode + (remove-hook 'post-command-hook 'semantic-highlight-func-highlight-current-tag t) + (semantic-highlight-func-highlight-current-tag t) + ) + semantic-highlight-func-mode) + +;;;###autoload +(defun semantic-highlight-func-mode (&optional arg) + "Minor mode to highlight the first line of the current tag. +Enables/disables making the header line of functions sticky. +A function (or other tag class specified by +`semantic-stickyfunc-sticky-classes') is highlighted, meaning the +first line which describes the rest of the construct. + +See `semantic-stickyfunc-mode' for putting a function in the +header line. This mode recycles the stickyfunc configuration +classes list. + +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled." + (interactive + (list (or current-prefix-arg + (if semantic-highlight-func-mode 0 1)))) + (setq semantic-highlight-func-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not semantic-highlight-func-mode))) + (semantic-highlight-func-mode-setup) + (run-hooks 'semantic-highlight-func-mode-hook) + (if (interactive-p) + (message "Highlight-Func minor mode %sabled" + (if semantic-highlight-func-mode "en" "dis"))) + semantic-highlight-func-mode) + +(defun semantic-highlight-func-highlight-current-tag (&optional disable) + "Highlight the current tag under point. +Optional argument DISABLE will turn off any active highlight. +If the current tag for this buffer is different from the last time this +function was called, move the overlay." + (when (and (not (minibufferp)) + (or (not semantic-highlight-func-ct-overlay) + (eq (semantic-overlay-buffer + semantic-highlight-func-ct-overlay) + (current-buffer)))) + (let* ((tag (semantic-stickyfunc-tag-to-stick)) + (ol semantic-highlight-func-ct-overlay)) + (when (not ol) + ;; No overlay in this buffer. Make one. + (setq ol (semantic-make-overlay (point-min) (point-min) + (current-buffer) t nil)) + (semantic-overlay-put ol 'highlight-func t) + (semantic-overlay-put ol 'face 'semantic-highlight-func-current-tag-face) + (semantic-overlay-put ol 'keymap semantic-highlight-func-mode-map) + (semantic-overlay-put ol 'help-echo + "Current Function : mouse-3 - Context menu") + (setq semantic-highlight-func-ct-overlay ol) + ) + + ;; TAG is nil if there was nothing of the apropriate type there. + (if (or (not tag) disable) + ;; No tag, make the overlay go away. + (progn + (semantic-overlay-put ol 'tag nil) + (semantic-overlay-move ol (point-min) (point-min) (current-buffer)) + ) + + ;; We have a tag, if it is the same, do nothing. + (unless (eq (semantic-overlay-get ol 'tag) tag) + (save-excursion + (goto-char (semantic-tag-start tag)) + (search-forward (semantic-tag-name tag) nil t) + (semantic-overlay-put ol 'tag tag) + (semantic-overlay-move ol (point-at-bol) (point-at-eol)) + ) + ) + ))) + nil) + +(semantic-add-minor-mode 'semantic-highlight-func-mode + "" ;; Don't need indicator. It's quite visible + nil) + +(provide 'semantic/util-modes) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/util-modes" +;; End: + +;;; semantic/util-modes.el ends here diff --git a/lisp/cedet/semantic/util.el b/lisp/cedet/semantic/util.el new file mode 100644 index 00000000000..669bf68f432 --- /dev/null +++ b/lisp/cedet/semantic/util.el @@ -0,0 +1,508 @@ +;;; semantic/util.el --- Utilities for use with semantic tag tables + +;;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2007, +;;; 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic utility API for use with semantic tag tables. +;; + +(require 'semantic) + +(eval-when-compile + (require 'semantic/db-find) + ;; For semantic-find-tags-by-class, semantic--find-tags-by-function, + ;; and semantic-brute-find-tag-standard: + (require 'semantic/find)) + +(declare-function data-debug-insert-stuff-list "data-debug") +(declare-function data-debug-insert-thing "data-debug") +(declare-function semantic-ctxt-current-symbol-and-bounds "semantic/ctxt") + +;;; Code: + +(defvar semantic-type-relation-separator-character '(".") + "Character strings used to separate a parent/child relationship. +This list of strings are used for displaying or finding separators +in variable field dereferencing. The first character will be used for +display. In C, a type field is separated like this: \"type.field\" +thus, the character is a \".\". In C, and additional value of \"->\" +would be in the list, so that \"type->field\" could be found.") +(make-variable-buffer-local 'semantic-type-relation-separator-character) + +(defvar semantic-equivalent-major-modes nil + "List of major modes which are considered equivalent. +Equivalent modes share a parser, and a set of override methods. +A value of nil means that the current major mode is the only one.") +(make-variable-buffer-local 'semantic-equivalent-major-modes) + +;; These semanticdb calls will throw warnings in the byte compiler. +;; Doing the right thing to make them available at compile time +;; really messes up the compilation sequence. +(defun semantic-file-tag-table (file) + "Return a tag table for FILE. +If it is loaded, return the stream after making sure it's ok. +If FILE is not loaded, check to see if `semanticdb' feature exists, + and use it to get tags from files not in memory. +If FILE is not loaded, and semanticdb is not available, find the file + and parse it." + (save-match-data + (if (find-buffer-visiting file) + (save-excursion + (set-buffer (find-buffer-visiting file)) + (semantic-fetch-tags)) + ;; File not loaded + (if (and (require 'semantic/db-mode) + (semanticdb-minor-mode-p)) + ;; semanticdb is around, use it. + (semanticdb-file-stream file) + ;; Get the stream ourselves. + (save-excursion + (set-buffer (find-file-noselect file)) + (semantic-fetch-tags)))))) + +(semantic-alias-obsolete 'semantic-file-token-stream + 'semantic-file-tag-table) + +(defun semantic-something-to-tag-table (something) + "Convert SOMETHING into a semantic tag table. +Something can be a tag with a valid BUFFER property, a tag table, a +buffer, or a filename. If SOMETHING is nil return nil." + (cond + ;; A list of tags + ((and (listp something) + (semantic-tag-p (car something))) + something) + ;; A buffer + ((bufferp something) + (save-excursion + (set-buffer something) + (semantic-fetch-tags))) + ;; A Tag: Get that tag's buffer + ((and (semantic-tag-with-position-p something) + (semantic-tag-in-buffer-p something)) + (save-excursion + (set-buffer (semantic-tag-buffer something)) + (semantic-fetch-tags))) + ;; Tag with a file name in it + ((and (semantic-tag-p something) + (semantic-tag-file-name something) + (file-exists-p (semantic-tag-file-name something))) + (semantic-file-tag-table + (semantic-tag-file-name something))) + ;; A file name + ((and (stringp something) + (file-exists-p something)) + (semantic-file-tag-table something)) + ;; A Semanticdb table + ((and (featurep 'semantic/db) + (semanticdb-minor-mode-p) + (semanticdb-abstract-table-child-p something)) + (semanticdb-refresh-table something) + (semanticdb-get-tags something)) + ;; Semanticdb find-results + ((and (featurep 'semantic/db) + (semanticdb-minor-mode-p) + (require 'semantic/db-find) + (semanticdb-find-results-p something)) + (semanticdb-strip-find-results something)) + ;; NOTE: This commented out since if a search result returns + ;; empty, that empty would turn into everything on the next search. + ;; Use the current buffer for nil +;; ((null something) +;; (semantic-fetch-tags)) + ;; don't know what it is + (t nil))) + +(semantic-alias-obsolete 'semantic-something-to-stream + 'semantic-something-to-tag-table) + +;;; Recursive searching through dependency trees +;; +;; This will depend on the general searching APIS defined above. +;; but will add full recursion through the dependencies list per +;; stream. +(defun semantic-recursive-find-nonterminal-by-name (name buffer) + "Recursively find the first occurrence of NAME. +Start search with BUFFER. Recurse through all dependencies till found. +The return item is of the form (BUFFER TOKEN) where BUFFER is the buffer +in which TOKEN (the token found to match NAME) was found. + +THIS ISN'T USED IN SEMANTIC. DELETE ME SOON." + (save-excursion + (set-buffer buffer) + (let* ((stream (semantic-fetch-tags)) + (includelist (or (semantic-find-tags-by-class 'include stream) + "empty.silly.thing")) + (found (semantic-find-first-tag-by-name name stream)) + (unfound nil)) + (while (and (not found) includelist) + (let ((fn (semantic-dependency-tag-file (car includelist)))) + (if (and fn (not (member fn unfound))) + (save-excursion + (save-match-data + (set-buffer (find-file-noselect fn))) + (message "Scanning %s" (buffer-file-name)) + (setq stream (semantic-fetch-tags)) + (setq found (semantic-find-first-tag-by-name name stream)) + (if found + (setq found (cons (current-buffer) (list found))) + (setq includelist + (append includelist + (semantic-find-tags-by-class + 'include stream)))) + (setq unfound (cons fn unfound))))) + (setq includelist (cdr includelist))) + found))) +(make-obsolete 'semantic-recursive-find-nonterminal-by-name + "Do not use this function.") + +;;; Completion APIs +;; +;; These functions provide minibuffer reading/completion for lists of +;; nonterminals. +(defvar semantic-read-symbol-history nil + "History for a symbol read.") + +(defun semantic-read-symbol (prompt &optional default stream filter) + "Read a symbol name from the user for the current buffer. +PROMPT is the prompt to use. +Optional arguments: +DEFAULT is the default choice. If no default is given, one is read +from under point. +STREAM is the list of tokens to complete from. +FILTER is provides a filter on the types of things to complete. +FILTER must be a function to call on each element." + (if (not default) (setq default (thing-at-point 'symbol))) + (if (not stream) (setq stream (semantic-fetch-tags))) + (setq stream + (if filter + (semantic--find-tags-by-function filter stream) + (semantic-brute-find-tag-standard stream))) + (if (and default (string-match ":" prompt)) + (setq prompt + (concat (substring prompt 0 (match-end 0)) + " (default: " default ") "))) + (completing-read prompt stream nil t "" + 'semantic-read-symbol-history + default)) + +(defun semantic-read-variable (prompt &optional default stream) + "Read a variable name from the user for the current buffer. +PROMPT is the prompt to use. +Optional arguments: +DEFAULT is the default choice. If no default is given, one is read +from under point. +STREAM is the list of tokens to complete from." + (semantic-read-symbol + prompt default + (or (semantic-find-tags-by-class + 'variable (or stream (current-buffer))) + (error "No local variables")))) + +(defun semantic-read-function (prompt &optional default stream) + "Read a function name from the user for the current buffer. +PROMPT is the prompt to use. +Optional arguments: +DEFAULT is the default choice. If no default is given, one is read +from under point. +STREAM is the list of tags to complete from." + (semantic-read-symbol + prompt default + (or (semantic-find-tags-by-class + 'function (or stream (current-buffer))) + (error "No local functions")))) + +(defun semantic-read-type (prompt &optional default stream) + "Read a type name from the user for the current buffer. +PROMPT is the prompt to use. +Optional arguments: +DEFAULT is the default choice. If no default is given, one is read +from under point. +STREAM is the list of tags to complete from." + (semantic-read-symbol + prompt default + (or (semantic-find-tags-by-class + 'type (or stream (current-buffer))) + (error "No local types")))) + + +;;; Interactive Functions for +;; +(defun semantic-describe-tag (&optional tag) + "Describe TAG in the minibuffer. +If TAG is nil, describe the tag under the cursor." + (interactive) + (if (not tag) (setq tag (semantic-current-tag))) + (semantic-fetch-tags) + (if tag (message (semantic-format-tag-summarize tag)))) + + +;;; Putting keys on tags. +;; +(defun semantic-add-label (label value &optional tag) + "Add a LABEL with VALUE on TAG. +If TAG is not specified, use the tag at point." + (interactive "sLabel: \nXValue (eval): ") + (if (not tag) + (progn + (semantic-fetch-tags) + (setq tag (semantic-current-tag)))) + (semantic--tag-put-property tag (intern label) value) + (message "Added label %s with value %S" label value)) + +(defun semantic-show-label (label &optional tag) + "Show the value of LABEL on TAG. +If TAG is not specified, use the tag at point." + (interactive "sLabel: ") + (if (not tag) + (progn + (semantic-fetch-tags) + (setq tag (semantic-current-tag)))) + (message "%s: %S" label (semantic--tag-get-property tag (intern label)))) + + +;;; Hacks +;; +;; Some hacks to help me test these functions +(defun semantic-describe-buffer-var-helper (varsym buffer) + "Display to standard out the value of VARSYM in BUFFER." + (require 'data-debug) + (let ((value (save-excursion + (set-buffer buffer) + (symbol-value varsym)))) + (cond + ((and (consp value) + (< (length value) 10)) + ;; Draw the list of things in the list. + (princ (format " %s: #<list of %d items>\n" + varsym (length value))) + (data-debug-insert-stuff-list + value " " ) + ) + (t + ;; Else do a one-liner. + (data-debug-insert-thing + value " " (concat " " (symbol-name varsym) ": ")) + )))) + +(defun semantic-describe-buffer () + "Describe the semantic environment for the current buffer." + (interactive) + (let ((buff (current-buffer)) + ) + + (with-output-to-temp-buffer (help-buffer) + (help-setup-xref (list #'semantic-describe-buffer) (interactive-p)) + (with-current-buffer standard-output + (princ "Semantic Configuration in ") + (princ (buffer-name buff)) + (princ "\n\n") + + (princ "Buffer specific configuration items:\n") + (let ((vars '(major-mode + semantic-case-fold + semantic-expand-nonterminal + semantic-parser-name + semantic-parse-tree-state + semantic-lex-analyzer + semantic-lex-reset-hooks + ))) + (dolist (V vars) + (semantic-describe-buffer-var-helper V buff))) + + (princ "\nGeneral configuration items:\n") + (let ((vars '(semantic-inhibit-functions + semantic-init-hook + semantic-init-db-hook + semantic-unmatched-syntax-hook + semantic--before-fetch-tags-hook + semantic-after-toplevel-bovinate-hook + semantic-after-toplevel-cache-change-hook + semantic-before-toplevel-cache-flush-hook + semantic-dump-parse + + ))) + (dolist (V vars) + (semantic-describe-buffer-var-helper V buff))) + + (princ "\n\n") + (mode-local-describe-bindings-2 buff) + ))) + ) + +(defun semantic-current-tag-interactive (p) + "Display the current token. +Argument P is the point to search from in the current buffer." + (interactive "d") + (require 'semantic/find) + (let ((tok (semantic-brute-find-innermost-tag-by-position + p (current-buffer)))) + (message (mapconcat 'semantic-abbreviate-nonterminal tok ",")) + (car tok)) + ) + +(defun semantic-hack-search () + "Display info about something under the cursor using generic methods." + (interactive) + (require 'semantic/find) + (let ((strm (cdr (semantic-fetch-tags))) + (res nil)) + (setq res (semantic-brute-find-tag-by-position (point) strm)) + (if res + (progn + (pop-to-buffer "*SEMANTIC HACK RESULTS*") + (require 'pp) + (erase-buffer) + (insert (pp-to-string res) "\n") + (goto-char (point-min)) + (shrink-window-if-larger-than-buffer)) + (message "nil")))) + +(defun semantic-assert-valid-token (tok) + "Assert that TOK is a valid token." + (if (semantic-tag-p tok) + (if (semantic-tag-with-position-p tok) + (let ((o (semantic-tag-overlay tok))) + (if (and (semantic-overlay-p o) + (not (semantic-overlay-live-p o))) + (let ((debug-on-error t)) + (error "Tag %s is invalid!" (semantic-tag-name tok))) + ;; else, tag is OK. + )) + ;; Positionless tags are also ok. + ) + (let ((debug-on-error t)) + (error "Not a semantic tag: %S" tok)))) + +(defun semantic-sanity-check (&optional cache over notfirst) + "Perform a sanity check on the current buffer. +The buffer's set of overlays, and those overlays found via the cache +are verified against each other. +CACHE, and OVER are the semantic cache, and the overlay list. +NOTFIRST indicates that this was not the first call in the recursive use." + (interactive) + (if (and (not cache) (not over) (not notfirst)) + (setq cache semantic--buffer-cache + over (semantic-overlays-in (point-min) (point-max)))) + (while cache + (let ((chil (semantic-tag-components-with-overlays (car cache)))) + (if (not (memq (semantic-tag-overlay (car cache)) over)) + (message "Tag %s not in buffer overlay list." + (semantic-format-tag-concise-prototype (car cache)))) + (setq over (delq (semantic-tag-overlay (car cache)) over)) + (setq over (semantic-sanity-check chil over t)) + (setq cache (cdr cache)))) + (if (not notfirst) + ;; Strip out all overlays which aren't semantic overlays + (let ((o nil)) + (while over + (when (and (semantic-overlay-get (car over) 'semantic) + (not (eq (semantic-overlay-get (car over) 'semantic) + 'unmatched))) + (setq o (cons (car over) o))) + (setq over (cdr over))) + (message "Remaining overlays: %S" o))) + over) + +;;; Interactive commands (from Senator). + +;; The Senator library from upstream CEDET is not included in the +;; built-in version of Emacs. The plan is to fold it into the +;; different parts of CEDET and Emacs, so that it works +;; "transparently". Here are some interactive commands based on +;; Senator. + +;; Symbol completion + +(defun semantic-find-tag-for-completion (prefix) + "Find all tags with name starting with PREFIX. +This uses `semanticdb' when available." + (let (result ctxt) + ;; Try the Semantic analyzer + (condition-case nil + (and (featurep 'semantic/analyze) + (setq ctxt (semantic-analyze-current-context)) + (setq result (semantic-analyze-possible-completions ctxt))) + (error nil)) + (or result + ;; If the analyzer fails, then go into boring completion. + (if (and (featurep 'semantic/db) + (semanticdb-minor-mode-p) + (require 'semantic/db-find)) + (semanticdb-fast-strip-find-results + (semanticdb-deep-find-tags-for-completion prefix)) + (semantic-deep-find-tags-for-completion prefix (current-buffer)))))) + +(defun semantic-complete-symbol (&optional predicate) + "Complete the symbol under point, using Semantic facilities. +When called from a program, optional arg PREDICATE is a predicate +determining which symbols are considered." + (interactive) + (require 'semantic/ctxt) + (let* ((start (car (nth 2 (semantic-ctxt-current-symbol-and-bounds + (point))))) + (pattern (regexp-quote (buffer-substring start (point)))) + collection completion) + (when start + (if (and semantic--completion-cache + (eq (nth 0 semantic--completion-cache) (current-buffer)) + (= (nth 1 semantic--completion-cache) start) + (save-excursion + (goto-char start) + (looking-at (nth 3 semantic--completion-cache)))) + ;; Use cached value. + (setq collection (nthcdr 4 semantic--completion-cache)) + ;; Perform new query. + (setq collection (semantic-find-tag-for-completion pattern)) + (setq semantic--completion-cache + (append (list (current-buffer) start 0 pattern) + collection)))) + (if (null collection) + (let ((str (if pattern (format " for \"%s\"" pattern) ""))) + (if (window-minibuffer-p (selected-window)) + (minibuffer-message (format " [No completions%s]" str)) + (message "Can't find completion%s" str))) + (setq completion (try-completion pattern collection predicate)) + (if (string= pattern completion) + (let ((list (all-completions pattern collection predicate))) + (setq list (sort list 'string<)) + (if (> (length list) 1) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list list pattern)) + ;; Bury any out-of-date completions buffer. + (let ((win (get-buffer-window "*Completions*" 0))) + (if win (with-selected-window win (bury-buffer)))))) + ;; Exact match + (delete-region start (point)) + (insert completion) + ;; Bury any out-of-date completions buffer. + (let ((win (get-buffer-window "*Completions*" 0))) + (if win (with-selected-window win (bury-buffer)))))))) + +(provide 'semantic/util) + +;;; Minor modes +;; +(require 'semantic/util-modes) + +;;; semantic/util.el ends here diff --git a/lisp/cedet/semantic/wisent.el b/lisp/cedet/semantic/wisent.el new file mode 100644 index 00000000000..35671aa7ada --- /dev/null +++ b/lisp/cedet/semantic/wisent.el @@ -0,0 +1,346 @@ +;;; semantic/wisent.el --- Wisent - Semantic gateway + +;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2007 +;;; Free Software Foundation, Inc. + +;; Author: David Ponce <david@dponce.com> +;; Maintainer: David Ponce <david@dponce.com> +;; Created: 30 Aug 2001 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Here are functions necessary to use the Wisent LALR parser from +;; Semantic environment. + +;;; History: +;; + +;;; Code: + +(require 'semantic) +(require 'semantic/wisent/wisent) + +;;; Lexical analysis +;; +(defvar wisent-lex-istream nil + "Input stream of `semantic-lex' syntactic tokens.") + +(defvar wisent-lex-lookahead nil + "Extra lookahead token. +When non-nil it is directly returned by `wisent-lex-function'.") + +;; Maintain this alias for compatibility until all WY grammars have +;; been translated again to Elisp code. +(semantic-alias-obsolete 'wisent-lex-make-token-table + 'semantic-lex-make-type-table) + +(defmacro wisent-lex-eoi () + "Return an End-Of-Input lexical token. +The EOI token is like this: ($EOI "" POINT-MAX . POINT-MAX)." + `(cons ',wisent-eoi-term + (cons "" + (cons (point-max) (point-max))))) + +(defmacro define-wisent-lexer (name doc &rest body) + "Create a new lexical analyzer with NAME. +DOC is a documentation string describing this analyzer. +When a token is available in `wisent-lex-istream', eval BODY forms +sequentially. BODY must return a lexical token for the LALR parser. + +Each token in input was produced by `semantic-lex', it is a list: + + (TOKSYM START . END) + +TOKSYM is a terminal symbol used in the grammar. +START and END mark boundary in the current buffer of that token's +value. + +Returned tokens must have the form: + + (TOKSYM VALUE START . END) + +where VALUE is the buffer substring between START and END positions." + `(defun + ,name () ,doc + (cond + (wisent-lex-lookahead + (prog1 wisent-lex-lookahead + (setq wisent-lex-lookahead nil))) + (wisent-lex-istream + ,@body) + ((wisent-lex-eoi))))) + +(define-wisent-lexer wisent-lex + "Return the next available lexical token in Wisent's form. +The variable `wisent-lex-istream' contains the list of lexical tokens +produced by `semantic-lex'. Pop the next token available and convert +it to a form suitable for the Wisent's parser." + (let* ((tk (car wisent-lex-istream))) + ;; Eat input stream + (setq wisent-lex-istream (cdr wisent-lex-istream)) + (cons (semantic-lex-token-class tk) + (cons (semantic-lex-token-text tk) + (semantic-lex-token-bounds tk))))) + +;;; Syntax analysis +;; +(defvar wisent-error-function nil + "Function used to report parse error. +By default use the function `wisent-message'.") +(make-variable-buffer-local 'wisent-error-function) + +(defvar wisent-lexer-function 'wisent-lex + "Function used to obtain the next lexical token in input. +Should be a lexical analyzer created with `define-wisent-lexer'.") +(make-variable-buffer-local 'wisent-lexer-function) + +;; Tag production +;; +(defsubst wisent-raw-tag (semantic-tag) + "Return raw form of given Semantic tag SEMANTIC-TAG. +Should be used in semantic actions, in grammars, to build a Semantic +parse tree." + (nconc semantic-tag + (if (or $region + (setq $region (nthcdr 2 wisent-input))) + (list (car $region) (cdr $region)) + (list (point-max) (point-max))))) + +(defsubst wisent-cook-tag (raw-tag) + "From raw form of Semantic tag RAW-TAG, return a list of cooked tags. +Should be used in semantic actions, in grammars, to build a Semantic +parse tree." + (let* ((cooked (semantic--tag-expand raw-tag)) + (l cooked)) + (while l + (semantic--tag-put-property (car l) 'reparse-symbol $nterm) + (setq l (cdr l))) + cooked)) + +;; Unmatched syntax collector +;; +(defun wisent-collect-unmatched-syntax (nomatch) + "Add lexical token NOMATCH to the cache of unmatched tokens. +See also the variable `semantic-unmatched-syntax-cache'. + +NOMATCH is in Wisent's form: (SYMBOL VALUE START . END) +and will be collected in `semantic-lex' form: (SYMBOL START . END)." + (let ((region (cddr nomatch))) + (and (number-or-marker-p (car region)) + (number-or-marker-p (cdr region)) + (setq semantic-unmatched-syntax-cache + (cons (cons (car nomatch) region) + semantic-unmatched-syntax-cache))))) + +;; Parser plug-ins +;; +;; The following functions permit to plug the Wisent LALR parser in +;; Semantic toolkit. They use the standard API provided by Semantic +;; to plug parsers in. +;; +;; Two plug-ins are available, BUT ONLY ONE MUST BE USED AT A TIME: +;; +;; - `wisent-parse-stream' designed to override the standard function +;; `semantic-parse-stream'. +;; +;; - `wisent-parse-region' designed to override the standard function +;; `semantic-parse-region'. +;; +;; Maybe the latter is faster because it eliminates a lot of function +;; call. +;; +(defun wisent-parse-stream (stream goal) + "Parse STREAM using the Wisent LALR parser. +GOAL is a nonterminal symbol to start parsing at. +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 tags found. +The LALR parser automaton must be available in buffer local variable +`semantic--parse-table'. + +Must be installed by `semantic-install-function-overrides' to override +the standard function `semantic-parse-stream'." + (let (wisent-lex-istream wisent-lex-lookahead la-elt cache) + + ;; IMPLEMENTATION NOTES: + ;; `wisent-parse' returns a lookahead token when it stopped + ;; parsing before encountering the end of input. To re-enter the + ;; parser it is necessary to push back in the lexical input stream + ;; the last lookahead token issued. Because the format of + ;; lookahead tokens and tokens in STREAM can be different the + ;; lookahead token is put in the variable `wisent-lex-lookahead' + ;; before calling `wisent-parse'. Wisent's lexers always pop the + ;; next lexical token from that variable when non nil, then from + ;; the lexical input stream. + ;; + ;; The first element of STREAM is used to keep lookahead tokens + ;; across successive calls to `wisent-parse-stream'. In fact + ;; what is kept is a stack of lookaheads encountered so far. It + ;; is cleared when `wisent-parse' returns a valid semantic tag, + ;; or twice the same lookahead token! The latter indicates that + ;; there is a syntax error on that token. If so, tokens currently + ;; in the lookahead stack have not been used, and are moved into + ;; `semantic-unmatched-syntax-cache'. When the parser will be + ;; re-entered, a new lexical token will be read from STREAM. + ;; + ;; The first element of STREAM that contains the lookahead stack + ;; has this format (compatible with the format of `semantic-lex' + ;; tokens): + ;; + ;; (LOOKAHEAD-STACK START . END) + ;; + ;; where LOOKAHEAD-STACK is a list of lookahead tokens. And + ;; START/END are the bounds of the lookahead at top of stack. + + ;; Retrieve lookahead token from stack + (setq la-elt (car stream)) + (if (consp (car la-elt)) + ;; The first elt of STREAM contains a lookahead stack + (setq wisent-lex-lookahead (caar la-elt) + stream (cdr stream)) + (setq la-elt nil)) + ;; Parse + (setq wisent-lex-istream stream + cache (semantic-safe "wisent-parse-stream: %s" + (condition-case error-to-filter + (wisent-parse semantic--parse-table + wisent-lexer-function + wisent-error-function + goal) + (args-out-of-range + (if (and (not debug-on-error) + (= wisent-parse-max-stack-size + (nth 2 error-to-filter))) + (progn + (message "wisent-parse-stream: %s" + (error-message-string error-to-filter)) + (message "wisent-parse-max-stack-size \ +might need to be increased")) + (apply 'signal error-to-filter)))))) + ;; Manage returned lookahead token + (if wisent-lookahead + (if (eq (caar la-elt) wisent-lookahead) + ;; It is already at top of lookahead stack + (progn + (setq cache nil + la-elt (car la-elt)) + (while la-elt + ;; Collect unmatched tokens from the stack + (run-hook-with-args + 'wisent-discarding-token-functions (car la-elt)) + (setq la-elt (cdr la-elt)))) + ;; New lookahead token + (if (or (consp cache) ;; Clear the stack if parse succeeded + (null la-elt)) + (setq la-elt (cons nil nil))) + ;; Push it into the stack + (setcar la-elt (cons wisent-lookahead (car la-elt))) + ;; Update START/END + (setcdr la-elt (cddr wisent-lookahead)) + ;; Push (LOOKAHEAD-STACK START . END) in STREAM + (setq wisent-lex-istream (cons la-elt wisent-lex-istream)))) + ;; Return (STREAM SEMANTIC-STREAM) + (list wisent-lex-istream + (if (consp cache) cache '(nil)) + ))) + +(defun wisent-parse-region (start end &optional goal depth returnonerror) + "Parse the area between START and END using the Wisent LALR parser. +Return the list of semantic tags found. +Optional arguments GOAL is a nonterminal symbol to start parsing at, +DEPTH is the lexical depth to scan, and RETURNONERROR is a flag to +stop parsing on syntax error, when non-nil. +The LALR parser automaton must be available in buffer local variable +`semantic--parse-table'. + +Must be installed by `semantic-install-function-overrides' to override +the standard function `semantic-parse-region'." + (if (or (< start (point-min)) (> end (point-max)) (< end start)) + (error "Invalid bounds [%s %s] passed to `wisent-parse-region'" + start end)) + (let* ((case-fold-search semantic-case-fold) + (wisent-lex-istream (semantic-lex start end depth)) + ptree tag cooked lstack wisent-lex-lookahead) + ;; Loop while there are lexical tokens available + (while wisent-lex-istream + ;; Parse + (setq wisent-lex-lookahead (car lstack) + tag (semantic-safe "wisent-parse-region: %s" + (wisent-parse semantic--parse-table + wisent-lexer-function + wisent-error-function + goal))) + ;; Manage returned lookahead token + (if wisent-lookahead + (if (eq (car lstack) wisent-lookahead) + ;; It is already at top of lookahead stack + (progn + (setq tag nil) + (while lstack + ;; Collect unmatched tokens from lookahead stack + (run-hook-with-args + 'wisent-discarding-token-functions (car lstack)) + (setq lstack (cdr lstack)))) + ;; Push new lookahead token into the stack + (setq lstack (cons wisent-lookahead lstack)))) + ;; Manage the parser result + (cond + ;; Parse succeeded, cook result + ((consp tag) + (setq lstack nil ;; Clear the lookahead stack + cooked (semantic--tag-expand tag) + ptree (append cooked ptree)) + (while cooked + (setq tag (car cooked) + cooked (cdr cooked)) + (or (semantic--tag-get-property tag 'reparse-symbol) + (semantic--tag-put-property tag 'reparse-symbol goal))) + ) + ;; Return on error if requested + (returnonerror + (setq wisent-lex-istream nil) + )) + ;; Work in progress... + (if wisent-lex-istream + (and (eq semantic-working-type 'percent) + (boundp 'semantic--progress-reporter) + semantic--progress-reporter + (progress-reporter-update + semantic--progress-reporter + (/ (* 100 (semantic-lex-token-start + (car wisent-lex-istream))) + (point-max)))))) + ;; Return parse tree + (nreverse ptree))) + +;;; Interfacing with edebug +;; +(add-hook + 'edebug-setup-hook + #'(lambda () + + (def-edebug-spec define-wisent-lexer + (&define name stringp def-body) + ) + + )) + +(provide 'semantic/wisent) + +;;; semantic/wisent.el ends here diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el new file mode 100644 index 00000000000..64426e51d98 --- /dev/null +++ b/lisp/cedet/semantic/wisent/comp.el @@ -0,0 +1,3539 @@ +;;; semantic/wisent/comp.el --- GNU Bison for Emacs - Grammar compiler + +;; Copyright (C) 1984, 1986, 1989, 1992, 1995, 2000, 2001, 2002, 2003, +;; 2004, 2005, 2006, 2007, 2009 Free Software Foundation, Inc. + +;; Author: David Ponce <david@dponce.com> +;; Maintainer: David Ponce <david@dponce.com> +;; Created: 30 January 2002 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Grammar compiler that produces Wisent's LALR automatons. +;; +;; Wisent (the European Bison ;-) is an Elisp implementation of the +;; GNU Compiler Compiler Bison. The Elisp code is a port of the C +;; code of GNU Bison 1.28 & 1.31. +;; +;; For more details on the basic concepts for understanding Wisent, +;; read the Bison manual ;) +;; +;; For more details on Wisent itself read the Wisent manual. + +;;; History: +;; + +;;; Code: +(require 'semantic/wisent) + +;;;; ------------------- +;;;; Misc. useful things +;;;; ------------------- + +;; As much as possible I would like to keep the name of global +;; variables used in Bison without polluting too much the Elisp global +;; name space. Elisp dynamic binding allows that ;-) + +;; Here are simple macros to easily define and use set of variables +;; binded locally, without all these "reference to free variable" +;; compiler warnings! + +(defmacro wisent-context-name (name) + "Return the context name from NAME." + `(if (and ,name (symbolp ,name)) + (intern (format "wisent-context-%s" ,name)) + (error "Invalid context name: %S" ,name))) + +(defmacro wisent-context-bindings (name) + "Return the variables in context NAME." + `(symbol-value (wisent-context-name ,name))) + +(defmacro wisent-defcontext (name &rest vars) + "Define a context NAME that will bind variables VARS." + (let* ((context (wisent-context-name name)) + (bindings (mapcar #'(lambda (v) (list 'defvar v)) vars))) + `(eval-when-compile + ,@bindings + (defvar ,context ',vars)))) +(put 'wisent-defcontext 'lisp-indent-function 1) + +(defmacro wisent-with-context (name &rest body) + "Bind variables in context NAME then eval BODY." + `(let* ,(wisent-context-bindings name) + ,@body)) +(put 'wisent-with-context 'lisp-indent-function 1) + +;; A naive implementation of data structures! But it suffice here ;-) + +(defmacro wisent-struct (name &rest fields) + "Define a simple data structure called NAME. +Which contains data stored in FIELDS. FIELDS is a list of symbols +which are field names or pairs (FIELD INITIAL-VALUE) where +INITIAL-VALUE is a constant used as the initial value of FIELD when +the data structure is created. INITIAL-VALUE defaults to nil. + +This defines a `make-NAME' constructor, get-able `NAME-FIELD' and +set-able `set-NAME-FIELD' accessors." + (let ((size (length fields)) + (i 0) + accors field sufx fun ivals) + (while (< i size) + (setq field (car fields) + fields (cdr fields)) + (if (consp field) + (setq ivals (cons (cadr field) ivals) + field (car field)) + (setq ivals (cons nil ivals))) + (setq sufx (format "%s-%s" name field) + fun (intern (format "%s" sufx)) + accors (cons `(defmacro ,fun (s) + (list 'aref s ,i)) + accors) + fun (intern (format "set-%s" sufx)) + accors (cons `(defmacro ,fun (s v) + (list 'aset s ,i v)) + accors) + i (1+ i))) + `(progn + (defmacro ,(intern (format "make-%s" name)) () + (cons 'vector ',(nreverse ivals))) + ,@accors))) +(put 'wisent-struct 'lisp-indent-function 1) + +;; Other utilities + +(defsubst wisent-pad-string (s n &optional left) + "Fill string S with spaces. +Return a new string of at least N characters. Insert spaces on right. +If optional LEFT is non-nil insert spaces on left." + (let ((i (length s))) + (if (< i n) + (if left + (concat (make-string (- n i) ?\ ) s) + (concat s (make-string (- n i) ?\ ))) + s))) + +;;;; ------------------------ +;;;; Environment dependencies +;;;; ------------------------ + +(defconst wisent-BITS-PER-WORD + (let ((i 1)) + (while (not (zerop (lsh 1 i))) + (setq i (1+ i))) + i)) + +(defsubst wisent-WORDSIZE (n) + "(N + BITS-PER-WORD - 1) / BITS-PER-WORD." + (/ (1- (+ n wisent-BITS-PER-WORD)) wisent-BITS-PER-WORD)) + +(defsubst wisent-SETBIT (x i) + "X[I/BITS-PER-WORD] |= 1 << (I % BITS-PER-WORD)." + (let ((k (/ i wisent-BITS-PER-WORD))) + (aset x k (logior (aref x k) + (lsh 1 (% i wisent-BITS-PER-WORD)))))) + +(defsubst wisent-RESETBIT (x i) + "X[I/BITS-PER-WORD] &= ~(1 << (I % BITS-PER-WORD))." + (let ((k (/ i wisent-BITS-PER-WORD))) + (aset x k (logand (aref x k) + (lognot (lsh 1 (% i wisent-BITS-PER-WORD))))))) + +(defsubst wisent-BITISSET (x i) + "(X[I/BITS-PER-WORD] & (1 << (I % BITS-PER-WORD))) != 0." + (not (zerop (logand (aref x (/ i wisent-BITS-PER-WORD)) + (lsh 1 (% i wisent-BITS-PER-WORD)))))) + +(eval-when-compile + (or (fboundp 'noninteractive) + ;; Silence the Emacs byte compiler + (defun noninteractive nil)) + ) + +(defsubst wisent-noninteractive () + "Return non-nil if running without interactive terminal." + (if (featurep 'xemacs) + (noninteractive) + noninteractive)) + +(defvar wisent-debug-flag nil + "Non-nil means enable some debug stuff.") + +;;;; -------------- +;;;; Logging/Output +;;;; -------------- +(defconst wisent-log-buffer-name "*wisent-log*" + "Name of the log buffer.") + +(defvar wisent-new-log-flag nil + "Non-nil means to start a new report.") + +(defvar wisent-verbose-flag nil + "*Non-nil means to report verbose information on generated parser.") + +(defun wisent-toggle-verbose-flag () + "Toggle whether to report verbose information on generated parser." + (interactive) + (setq wisent-verbose-flag (not wisent-verbose-flag)) + (when (interactive-p) + (message "Verbose report %sabled" + (if wisent-verbose-flag "en" "dis")))) + +(defmacro wisent-log-buffer () + "Return the log buffer. +Its name is defined in constant `wisent-log-buffer-name'." + `(get-buffer-create wisent-log-buffer-name)) + +(defmacro wisent-clear-log () + "Delete the entire contents of the log buffer." + `(with-current-buffer (wisent-log-buffer) + (erase-buffer))) + +(eval-when-compile (defvar byte-compile-current-file)) + +(defun wisent-source () + "Return the current source file name or nil." + (let ((source (or (and (boundp 'byte-compile-current-file) + byte-compile-current-file) + load-file-name (buffer-file-name)))) + (if source + (file-relative-name source)))) + +(defun wisent-new-log () + "Start a new entry into the log buffer." + (setq wisent-new-log-flag nil) + (let ((text (format "\n\n*** Wisent %s - %s\n\n" + (or (wisent-source) (buffer-name)) + (format-time-string "%Y-%m-%d %R")))) + (with-current-buffer (wisent-log-buffer) + (goto-char (point-max)) + (insert text)))) + +(defsubst wisent-log (&rest args) + "Insert text into the log buffer. +`format' is applied to ARGS and the result string is inserted into the +log buffer returned by the function `wisent-log-buffer'." + (and wisent-new-log-flag (wisent-new-log)) + (with-current-buffer (wisent-log-buffer) + (insert (apply 'format args)))) + +(defconst wisent-log-file "wisent.output" + "The log file. +Used when running without interactive terminal.") + +(defun wisent-append-to-log-file () + "Append contents of logging buffer to `wisent-log-file'." + (if (get-buffer wisent-log-buffer-name) + (condition-case err + (with-current-buffer (wisent-log-buffer) + (widen) + (if (> (point-max) (point-min)) + (write-region (point-min) (point-max) + wisent-log-file t))) + (error + (message "*** %s" (error-message-string err)))))) + +;;;; ----------------------------------- +;;;; Representation of the grammar rules +;;;; ----------------------------------- + +;; ntokens is the number of tokens, and nvars is the number of +;; variables (nonterminals). nsyms is the total number, ntokens + +;; nvars. + +;; Each symbol (either token or variable) receives a symbol number. +;; Numbers 0 to ntokens-1 are for tokens, and ntokens to nsyms-1 are +;; for variables. Symbol number zero is the end-of-input token. This +;; token is counted in ntokens. + +;; The rules receive rule numbers 1 to nrules in the order they are +;; written. Actions and guards are accessed via the rule number. + +;; The rules themselves are described by three arrays: rrhs, rlhs and +;; ritem. rlhs[R] is the symbol number of the left hand side of rule +;; R. The right hand side is stored as symbol numbers in a portion of +;; ritem. rrhs[R] contains the index in ritem of the beginning of the +;; portion for rule R. + +;; The length of the portion is one greater than the number of symbols +;; in the rule's right hand side. The last element in the portion +;; contains minus R, which identifies it as the end of a portion and +;; says which rule it is for. + +;; The portions of ritem come in order of increasing rule number and +;; are followed by an element which is nil to mark the end. nitems is +;; the total length of ritem, not counting the final nil. Each +;; element of ritem is called an "item" and its index in ritem is an +;; item number. + +;; Item numbers are used in the finite state machine to represent +;; places that parsing can get to. + +;; The vector rprec contains for each rule, the item number of the +;; symbol giving its precedence level to this rule. The precedence +;; level and associativity of each symbol is recorded in respectively +;; the properties 'wisent--prec and 'wisent--assoc. + +;; Precedence levels are assigned in increasing order starting with 1 +;; so that numerically higher precedence values mean tighter binding +;; as they ought to. nil as a symbol or rule's precedence means none +;; is assigned. + +(defcustom wisent-state-table-size 1009 + "The size of the state table." + :type 'integer + :group 'wisent) + +;; These variables only exist locally in the function +;; `wisent-compile-grammar' and are shared by all other nested +;; callees. +(wisent-defcontext compile-grammar + F LA LAruleno accessing-symbol conflicts consistent default-prec + derives err-table fderives final-state first-reduction first-shift + first-state firsts from-state goto-map includes itemset nitemset + kernel-base kernel-end kernel-items last-reduction last-shift + last-state lookaheads lookaheadset lookback maxrhs ngotos nitems + nrules nshifts nstates nsyms ntokens nullable nvars rassoc redset + reduction-table ritem rlhs rprec rrc-count rrc-total rrhs ruseful + rcode ruleset rulesetsize shift-symbol shift-table shiftset + src-count src-total start-table state-table tags this-state to-state + tokensetsize ;; nb of words req. to hold a bit for each rule + varsetsize ;; nb of words req. to hold a bit for each variable + error-token-number start-symbol token-list var-list + N P V V1 nuseless-nonterminals nuseless-productions + ptable ;; symbols & characters properties + ) + +(defmacro wisent-ISTOKEN (s) + "Return non-nil if item number S defines a token (terminal). +That is if S < `ntokens'." + `(< ,s ntokens)) + +(defmacro wisent-ISVAR(s) + "Return non-nil if item number S defines a nonterminal. +That is if S >= `ntokens'." + `(>= ,s ntokens)) + +(defsubst wisent-tag (s) + "Return printable form of item number S." + (wisent-item-to-string (aref tags s))) + +;; Symbol and character properties + +(defsubst wisent-put (object propname value) + "Store OBJECT's PROPNAME property with value VALUE. +Use `eq' to locate OBJECT." + (let ((entry (assq object ptable))) + (or entry (setq entry (list object) ptable (cons entry ptable))) + (setcdr entry (plist-put (cdr entry) propname value)))) + +(defsubst wisent-get (object propname) + "Return the value of OBJECT's PROPNAME property. +Use `eq' to locate OBJECT." + (plist-get (cdr (assq object ptable)) propname)) + +(defsubst wisent-item-number (x) + "Return the item number of symbol X." + (wisent-get x 'wisent--item-no)) + +(defsubst wisent-set-item-number (x n) + "Set the item number of symbol X to N." + (wisent-put x 'wisent--item-no n)) + +(defsubst wisent-assoc (x) + "Return the associativity of symbol X." + (wisent-get x 'wisent--assoc)) + +(defsubst wisent-set-assoc (x a) + "Set the associativity of symbol X to A." + (wisent-put x 'wisent--assoc a)) + +(defsubst wisent-prec (x) + "Return the precedence level of symbol X." + (wisent-get x 'wisent--prec)) + +(defsubst wisent-set-prec (x p) + "Set the precedence level of symbol X to P." + (wisent-put x 'wisent--prec p)) + +;;;; ---------------------------------------------------------- +;;;; Type definitions for nondeterministic finite state machine +;;;; ---------------------------------------------------------- + +;; These type definitions are used to represent a nondeterministic +;; finite state machine that parses the specified grammar. This +;; information is generated by the function `wisent-generate-states'. + +;; Each state of the machine is described by a set of items -- +;; particular positions in particular rules -- that are the possible +;; places where parsing could continue when the machine is in this +;; state. These symbols at these items are the allowable inputs that +;; can follow now. + +;; A core represents one state. States are numbered in the number +;; field. When `wisent-generate-states' is finished, the starting +;; state is state 0 and `nstates' is the number of states. (A +;; transition to a state whose state number is `nstates' indicates +;; termination.) All the cores are chained together and `first-state' +;; points to the first one (state 0). + +;; For each state there is a particular symbol which must have been +;; the last thing accepted to reach that state. It is the +;; accessing-symbol of the core. + +;; Each core contains a vector of `nitems' items which are the indices +;; in the `ritems' vector of the items that are selected in this +;; state. + +;; The link field is used for chaining buckets that hash states by +;; their itemsets. This is for recognizing equivalent states and +;; combining them when the states are generated. + +;; The two types of transitions are shifts (push the lookahead token +;; and read another) and reductions (combine the last n things on the +;; stack via a rule, replace them with the symbol that the rule +;; derives, and leave the lookahead token alone). When the states are +;; generated, these transitions are represented in two other lists. + +;; Each shifts structure describes the possible shift transitions out +;; of one state, the state whose number is in the number field. The +;; shifts structures are linked through next and first-shift points to +;; them. Each contains a vector of numbers of the states that shift +;; transitions can go to. The accessing-symbol fields of those +;; states' cores say what kind of input leads to them. + +;; A shift to state zero should be ignored. Conflict resolution +;; deletes shifts by changing them to zero. + +;; Each reductions structure describes the possible reductions at the +;; state whose number is in the number field. The data is a list of +;; nreds rules, represented by their rule numbers. `first-reduction' +;; points to the list of these structures. + +;; Conflict resolution can decide that certain tokens in certain +;; states should explicitly be errors (for implementing %nonassoc). +;; For each state, the tokens that are errors for this reason are +;; recorded in an errs structure, which has the state number in its +;; number field. The rest of the errs structure is full of token +;; numbers. + +;; There is at least one shift transition present in state zero. It +;; leads to a next-to-final state whose accessing-symbol is the +;; grammar's start symbol. The next-to-final state has one shift to +;; the final state, whose accessing-symbol is zero (end of input). +;; The final state has one shift, which goes to the termination state +;; (whose number is `nstates'-1). +;; The reason for the extra state at the end is to placate the +;; parser's strategy of making all decisions one token ahead of its +;; actions. + +(wisent-struct core + next ; -> core + link ; -> core + (number 0) + (accessing-symbol 0) + (nitems 0) + (items [0])) + +(wisent-struct shifts + next ; -> shifts + (number 0) + (nshifts 0) + (shifts [0])) + +(wisent-struct reductions + next ; -> reductions + (number 0) + (nreds 0) + (rules [0])) + +(wisent-struct errs + (nerrs 0) + (errs [0])) + +;;;; -------------------------------------------------------- +;;;; Find unreachable terminals, nonterminals and productions +;;;; -------------------------------------------------------- + +(defun wisent-bits-equal (L R n) + "Visit L and R and return non-nil if their first N elements are `='. +L and R must be vectors of integers." + (let* ((i (1- n)) + (iseq t)) + (while (and iseq (natnump i)) + (setq iseq (= (aref L i) (aref R i)) + i (1- i))) + iseq)) + +(defun wisent-nbits (i) + "Return number of bits set in integer I." + (let ((count 0)) + (while (not (zerop i)) + ;; i ^= (i & ((unsigned) (-(int) i))) + (setq i (logxor i (logand i (- i))) + count (1+ count))) + count)) + +(defun wisent-bits-size (S n) + "In vector S count the total of bits set in first N elements. +S must be a vector of integers." + (let* ((i (1- n)) + (count 0)) + (while (natnump i) + (setq count (+ count (wisent-nbits (aref S i))) + i (1- i))) + count)) + +(defun wisent-useful-production (i N0) + "Return non-nil if production I is in useful set N0." + (let* ((useful t) + (r (aref rrhs i)) + n) + (while (and useful (> (setq n (aref ritem r)) 0)) + (if (wisent-ISVAR n) + (setq useful (wisent-BITISSET N0 (- n ntokens)))) + (setq r (1+ r))) + useful)) + +(defun wisent-useless-nonterminals () + "Find out which nonterminals are used." + (let (Np Ns i n break) + ;; N is set as built. Np is set being built this iteration. P is + ;; set of all productions which have a RHS all in N. + (setq n (wisent-WORDSIZE nvars) + Np (make-vector n 0)) + + ;; The set being computed is a set of nonterminals which can + ;; derive the empty string or strings consisting of all + ;; terminals. At each iteration a nonterminal is added to the set + ;; if there is a production with that nonterminal as its LHS for + ;; which all the nonterminals in its RHS are already in the set. + ;; Iterate until the set being computed remains unchanged. Any + ;; nonterminals not in the set at that point are useless in that + ;; they will never be used in deriving a sentence of the language. + + ;; This iteration doesn't use any special traversal over the + ;; productions. A set is kept of all productions for which all + ;; the nonterminals in the RHS are in useful. Only productions + ;; not in this set are scanned on each iteration. At the end, + ;; this set is saved to be used when finding useful productions: + ;; only productions in this set will appear in the final grammar. + + (while (not break) + (setq i (1- n)) + (while (natnump i) + ;; Np[i] = N[i] + (aset Np i (aref N i)) + (setq i (1- i))) + + (setq i 1) + (while (<= i nrules) + (if (not (wisent-BITISSET P i)) + (when (wisent-useful-production i N) + (wisent-SETBIT Np (- (aref rlhs i) ntokens)) + (wisent-SETBIT P i))) + (setq i (1+ i))) + (if (wisent-bits-equal N Np n) + (setq break t) + (setq Ns Np + Np N + N Ns))) + (setq N Np))) + +(defun wisent-inaccessable-symbols () + "Find out which productions are reachable and which symbols are used." + ;; Starting with an empty set of productions and a set of symbols + ;; which only has the start symbol in it, iterate over all + ;; productions until the set of productions remains unchanged for an + ;; iteration. For each production which has a LHS in the set of + ;; reachable symbols, add the production to the set of reachable + ;; productions, and add all of the nonterminals in the RHS of the + ;; production to the set of reachable symbols. + + ;; Consider only the (partially) reduced grammar which has only + ;; nonterminals in N and productions in P. + + ;; The result is the set P of productions in the reduced grammar, + ;; and the set V of symbols in the reduced grammar. + + ;; Although this algorithm also computes the set of terminals which + ;; are reachable, no terminal will be deleted from the grammar. Some + ;; terminals might not be in the grammar but might be generated by + ;; semantic routines, and so the user might want them available with + ;; specified numbers. (Is this true?) However, the non reachable + ;; terminals are printed (if running in verbose mode) so that the + ;; user can know. + (let (Vp Vs Pp i tt r n m break) + (setq n (wisent-WORDSIZE nsyms) + m (wisent-WORDSIZE (1+ nrules)) + Vp (make-vector n 0) + Pp (make-vector m 0)) + + ;; If the start symbol isn't useful, then nothing will be useful. + (when (wisent-BITISSET N (- start-symbol ntokens)) + (wisent-SETBIT V start-symbol) + (while (not break) + (setq i (1- n)) + (while (natnump i) + (aset Vp i (aref V i)) + (setq i (1- i))) + (setq i 1) + (while (<= i nrules) + (when (and (not (wisent-BITISSET Pp i)) + (wisent-BITISSET P i) + (wisent-BITISSET V (aref rlhs i))) + (setq r (aref rrhs i)) + (while (natnump (setq tt (aref ritem r))) + (if (or (wisent-ISTOKEN tt) + (wisent-BITISSET N (- tt ntokens))) + (wisent-SETBIT Vp tt)) + (setq r (1+ r))) + (wisent-SETBIT Pp i)) + (setq i (1+ i))) + (if (wisent-bits-equal V Vp n) + (setq break t) + (setq Vs Vp + Vp V + V Vs)))) + (setq V Vp) + + ;; Tokens 0, 1 are internal to Wisent. Consider them useful. + (wisent-SETBIT V 0) ;; end-of-input token + (wisent-SETBIT V 1) ;; error token + (setq P Pp) + + (setq nuseless-productions (- nrules (wisent-bits-size P m)) + nuseless-nonterminals nvars + i ntokens) + (while (< i nsyms) + (if (wisent-BITISSET V i) + (setq nuseless-nonterminals (1- nuseless-nonterminals))) + (setq i (1+ i))) + + ;; A token that was used in %prec should not be warned about. + (setq i 1) + (while (<= i nrules) + (if (aref rprec i) + (wisent-SETBIT V1 (aref rprec i))) + (setq i (1+ i))) + )) + +(defun wisent-reduce-grammar-tables () + "Disable useless productions." + (if (> nuseless-productions 0) + (let ((pn 1)) + (while (<= pn nrules) + (aset ruseful pn (wisent-BITISSET P pn)) + (setq pn (1+ pn)))))) + +(defun wisent-nonterminals-reduce () + "Remove useless nonterminals." + (let (i n r item nontermmap tags-sorted) + ;; Map the nonterminals to their new index: useful first, useless + ;; afterwards. Kept for later report. + (setq nontermmap (make-vector nvars 0) + n ntokens + i ntokens) + (while (< i nsyms) + (when (wisent-BITISSET V i) + (aset nontermmap (- i ntokens) n) + (setq n (1+ n))) + (setq i (1+ i))) + (setq i ntokens) + (while (< i nsyms) + (unless (wisent-BITISSET V i) + (aset nontermmap (- i ntokens) n) + (setq n (1+ n))) + (setq i (1+ i))) + ;; Shuffle elements of tables indexed by symbol number + (setq tags-sorted (make-vector nvars nil) + i ntokens) + (while (< i nsyms) + (setq n (aref nontermmap (- i ntokens))) + (aset tags-sorted (- n ntokens) (aref tags i)) + (setq i (1+ i))) + (setq i ntokens) + (while (< i nsyms) + (aset tags i (aref tags-sorted (- i ntokens))) + (setq i (1+ i))) + ;; Replace all symbol numbers in valid data structures. + (setq i 1) + (while (<= i nrules) + (aset rlhs i (aref nontermmap (- (aref rlhs i) ntokens))) + (setq i (1+ i))) + (setq r 0) + (while (setq item (aref ritem r)) + (if (wisent-ISVAR item) + (aset ritem r (aref nontermmap (- item ntokens)))) + (setq r (1+ r))) + (setq start-symbol (aref nontermmap (- start-symbol ntokens)) + nsyms (- nsyms nuseless-nonterminals) + nvars (- nvars nuseless-nonterminals)) + )) + +(defun wisent-total-useless () + "Report number of useless nonterminals and productions." + (let* ((src (wisent-source)) + (src (if src (concat " in " src) "")) + (msg (format "Grammar%s contains" src))) + (if (> nuseless-nonterminals 0) + (setq msg (format "%s %d useless nonterminal%s" + msg nuseless-nonterminals + (if (> nuseless-nonterminals 0) "s" "")))) + (if (and (> nuseless-nonterminals 0) (> nuseless-productions 0)) + (setq msg (format "%s and" msg))) + (if (> nuseless-productions 0) + (setq msg (format "%s %d useless rule%s" + msg nuseless-productions + (if (> nuseless-productions 0) "s" "")))) + (message msg))) + +(defun wisent-reduce-grammar () + "Find unreachable terminals, nonterminals and productions." + ;; Allocate the global sets used to compute the reduced grammar + (setq N (make-vector (wisent-WORDSIZE nvars) 0) + P (make-vector (wisent-WORDSIZE (1+ nrules)) 0) + V (make-vector (wisent-WORDSIZE nsyms) 0) + V1 (make-vector (wisent-WORDSIZE nsyms) 0) + nuseless-nonterminals 0 + nuseless-productions 0) + + (wisent-useless-nonterminals) + (wisent-inaccessable-symbols) + + (when (> (+ nuseless-nonterminals nuseless-productions) 0) + (wisent-total-useless) + (or (wisent-BITISSET N (- start-symbol ntokens)) + (error "Start symbol `%s' does not derive any sentence" + (wisent-tag start-symbol))) + (wisent-reduce-grammar-tables) + (if (> nuseless-nonterminals 0) + (wisent-nonterminals-reduce)))) + +(defun wisent-print-useless () + "Output the detailed results of the reductions." + (let (i b r) + (when (> nuseless-nonterminals 0) + ;; Useless nonterminals have been moved after useful ones. + (wisent-log "\n\nUseless nonterminals:\n\n") + (setq i 0) + (while (< i nuseless-nonterminals) + (wisent-log " %s\n" (wisent-tag (+ nsyms i))) + (setq i (1+ i)))) + (setq b nil + i 0) + (while (< i ntokens) + (unless (or (wisent-BITISSET V i) (wisent-BITISSET V1 i)) + (or b + (wisent-log "\n\nTerminals which are not used:\n\n")) + (setq b t) + (wisent-log " %s\n" (wisent-tag i))) + (setq i (1+ i))) + (when (> nuseless-productions 0) + (wisent-log "\n\nUseless rules:\n\n") + (setq i 1) + (while (<= i nrules) + (unless (aref ruseful i) + (wisent-log "#%s " (wisent-pad-string (format "%d" i) 4)) + (wisent-log "%s:" (wisent-tag (aref rlhs i))) + (setq r (aref rrhs i)) + (while (natnump (aref ritem r)) + (wisent-log " %s" (wisent-tag (aref ritem r))) + (setq r (1+ r))) + (wisent-log ";\n")) + (setq i (1+ i)))) + (if (or b (> nuseless-nonterminals 0) (> nuseless-productions 0)) + (wisent-log "\n\n")) + )) + +;;;; ----------------------------- +;;;; Match rules with nonterminals +;;;; ----------------------------- + +(defun wisent-set-derives () + "Find, for each variable (nonterminal), which rules can derive it. +It sets up the value of DERIVES so that DERIVES[i - NTOKENS] points to +a list of rule numbers, terminated with -1." + (let (i lhs p q dset delts) + (setq dset (make-vector nvars nil) + delts (make-vector (1+ nrules) 0)) + (setq p 0 ;; p = delts + i nrules) + (while (> i 0) + (when (aref ruseful i) + (setq lhs (aref rlhs i)) + ;; p->next = dset[lhs]; + ;; p->value = i; + (aset delts p (cons i (aref dset (- lhs ntokens)))) ;; (value . next) + (aset dset (- lhs ntokens) p) ;; dset[lhs] = p + (setq p (1+ p)) ;; p++ + ) + (setq i (1- i))) + + (setq derives (make-vector nvars nil) + i ntokens) + + (while (< i nsyms) + (setq q nil + p (aref dset (- i ntokens))) ;; p = dset[i] + + (while p + (setq p (aref delts p) + q (cons (car p) q) ;;q++ = p->value + p (cdr p))) ;; p = p->next + (setq q (nreverse (cons -1 q))) ;; *q++ = -1 + (aset derives (- i ntokens) q) ;; derives[i] = q + (setq i (1+ i))) + )) + +;;;; -------------------------------------------------------- +;;;; Find which nonterminals can expand into the null string. +;;;; -------------------------------------------------------- + +(defun wisent-print-nullable () + "Print NULLABLE." + (let (i) + (wisent-log "NULLABLE\n") + (setq i ntokens) + (while (< i nsyms) + (wisent-log "\t%s: %s\n" (wisent-tag i) + (if (aref nullable (- i ntokens)) + "yes" : "no")) + (setq i (1+ i))) + (wisent-log "\n\n"))) + +(defun wisent-set-nullable () + "Set up NULLABLE. +A vector saying which nonterminals can expand into the null string. +NULLABLE[i - NTOKENS] is nil if symbol I can do so." + (let (ruleno s1 s2 p r squeue rcount rsets relts item any-tokens) + (setq squeue (make-vector nvars 0) + rcount (make-vector (1+ nrules) 0) + rsets (make-vector nvars nil) ;; - ntokens + relts (make-vector (+ nitems nvars 1) nil) + nullable (make-vector nvars nil)) ;; - ntokens + (setq s1 0 s2 0 ;; s1 = s2 = squeue + p 0 ;; p = relts + ruleno 1) + (while (<= ruleno nrules) + (when (aref ruseful ruleno) + (if (> (aref ritem (aref rrhs ruleno)) 0) + (progn + ;; This rule has a non empty RHS. + (setq any-tokens nil + r (aref rrhs ruleno)) + (while (> (aref ritem r) 0) + (if (wisent-ISTOKEN (aref ritem r)) + (setq any-tokens t)) + (setq r (1+ r))) + + ;; This rule has only nonterminals: schedule it for the + ;; second pass. + (unless any-tokens + (setq r (aref rrhs ruleno)) + (while (> (setq item (aref ritem r)) 0) + (aset rcount ruleno (1+ (aref rcount ruleno))) + ;; p->next = rsets[item]; + ;; p->value = ruleno; + (aset relts p (cons ruleno (aref rsets (- item ntokens)))) + ;; rsets[item] = p; + (aset rsets (- item ntokens) p) + (setq p (1+ p) + r (1+ r))))) + ;; This rule has an empty RHS. + ;; assert (ritem[rrhs[ruleno]] == -ruleno) + (when (and (aref ruseful ruleno) + (setq item (aref rlhs ruleno)) + (not (aref nullable (- item ntokens)))) + (aset nullable (- item ntokens) t) + (aset squeue s2 item) + (setq s2 (1+ s2))) + ) + ) + (setq ruleno (1+ ruleno))) + + (while (< s1 s2) + ;; p = rsets[*s1++] + (setq p (aref rsets (- (aref squeue s1) ntokens)) + s1 (1+ s1)) + (while p + (setq p (aref relts p) + ruleno (car p) + p (cdr p)) ;; p = p->next + ;; if (--rcount[ruleno] == 0) + (when (zerop (aset rcount ruleno (1- (aref rcount ruleno)))) + (setq item (aref rlhs ruleno)) + (aset nullable (- item ntokens) t) + (aset squeue s2 item) + (setq s2 (1+ s2))))) + + (if wisent-debug-flag + (wisent-print-nullable)) + )) + +;;;; ----------- +;;;; Subroutines +;;;; ----------- + +(defun wisent-print-fderives () + "Print FDERIVES." + (let (i j rp) + (wisent-log "\n\n\nFDERIVES\n") + (setq i ntokens) + (while (< i nsyms) + (wisent-log "\n\n%s derives\n\n" (wisent-tag i)) + (setq rp (aref fderives (- i ntokens)) + j 0) + (while (<= j nrules) + (if (wisent-BITISSET rp j) + (wisent-log " %d\n" j)) + (setq j (1+ j))) + (setq i (1+ i))))) + +(defun wisent-set-fderives () + "Set up FDERIVES. +An NVARS by NRULES matrix of bits indicating which rules can help +derive the beginning of the data for each nonterminal. For example, +if symbol 5 can be derived as the sequence of symbols 8 3 20, and one +of the rules for deriving symbol 8 is rule 4, then the +\[5 - NTOKENS, 4] bit in FDERIVES is set." + (let (i j k) + (setq fderives (make-vector nvars nil)) + (setq i 0) + (while (< i nvars) + (aset fderives i (make-vector rulesetsize 0)) + (setq i (1+ i))) + + (wisent-set-firsts) + + (setq i ntokens) + (while (< i nsyms) + (setq j ntokens) + (while (< j nsyms) + ;; if (BITISSET (FIRSTS (i), j - ntokens)) + (when (wisent-BITISSET (aref firsts (- i ntokens)) (- j ntokens)) + (setq k (aref derives (- j ntokens))) + (while (> (car k) 0) ;; derives[j][k] > 0 + ;; SETBIT (FDERIVES (i), derives[j][k]); + (wisent-SETBIT (aref fderives (- i ntokens)) (car k)) + (setq k (cdr k)))) + (setq j (1+ j))) + (setq i (1+ i))) + + (if wisent-debug-flag + (wisent-print-fderives)) + )) + +(defun wisent-print-firsts () + "Print FIRSTS." + (let (i j v) + (wisent-log "\n\n\nFIRSTS\n\n") + (setq i ntokens) + (while (< i nsyms) + (wisent-log "\n\n%s firsts\n\n" (wisent-tag i)) + (setq v (aref firsts (- i ntokens)) + j 0) + (while (< j nvars) + (if (wisent-BITISSET v j) + (wisent-log "\t\t%d (%s)\n" + (+ j ntokens) (wisent-tag (+ j ntokens)))) + (setq j (1+ j))) + (setq i (1+ i))))) + +(defun wisent-TC (R n) + "Transitive closure. +Given R an N by N matrix of bits, modify its contents to be the +transitive closure of what was given." + (let (i j k) + ;; R (J, I) && R (I, K) => R (J, K). + ;; I *must* be the outer loop. + (setq i 0) + (while (< i n) + (setq j 0) + (while (< j n) + (when (wisent-BITISSET (aref R j) i) + (setq k 0) + (while (< k n) + (if (wisent-BITISSET (aref R i) k) + (wisent-SETBIT (aref R j) k)) + (setq k (1+ k)))) + (setq j (1+ j))) + (setq i (1+ i))))) + +(defun wisent-RTC (R n) + "Reflexive Transitive Closure. +Same as `wisent-TC' and then set all the bits on the diagonal of R, an +N by N matrix of bits." + (let (i) + (wisent-TC R n) + (setq i 0) + (while (< i n) + (wisent-SETBIT (aref R i) i) + (setq i (1+ i))))) + +(defun wisent-set-firsts () + "Set up FIRSTS. +An NVARS by NVARS bit matrix indicating which items can represent the +beginning of the input corresponding to which other items. For +example, if some rule expands symbol 5 into the sequence of symbols 8 +3 20, the symbol 8 can be the beginning of the data for symbol 5, so +the bit [8 - NTOKENS, 5 - NTOKENS] in FIRSTS is set." + (let (row symbol sp rowsize i) + (setq rowsize (wisent-WORDSIZE nvars) + varsetsize rowsize + firsts (make-vector nvars nil) + i 0) + (while (< i nvars) + (aset firsts i (make-vector rowsize 0)) + (setq i (1+ i))) + + (setq row 0 ;; row = firsts + i ntokens) + (while (< i nsyms) + (setq sp (aref derives (- i ntokens))) + (while (>= (car sp) 0) + (setq symbol (aref ritem (aref rrhs (car sp))) + sp (cdr sp)) + (when (wisent-ISVAR symbol) + (setq symbol (- symbol ntokens)) + (wisent-SETBIT (aref firsts row) symbol) + )) + (setq row (1+ row) + i (1+ i))) + + (wisent-RTC firsts nvars) + + (if wisent-debug-flag + (wisent-print-firsts)) + )) + +(defun wisent-initialize-closure (n) + "Allocate the ITEMSET and RULESET vectors. +And precompute useful data so that `wisent-closure' can be called. +N is the number of elements to allocate for ITEMSET." + (setq itemset (make-vector n 0) + rulesetsize (wisent-WORDSIZE (1+ nrules)) + ruleset (make-vector rulesetsize 0)) + + (wisent-set-fderives)) + +(defun wisent-print-closure () + "Print ITEMSET." + (let (i) + (wisent-log "\n\nclosure n = %d\n\n" nitemset) + (setq i 0) ;; isp = itemset + (while (< i nitemset) + (wisent-log " %d\n" (aref itemset i)) + (setq i (1+ i))))) + +(defun wisent-closure (core n) + "Set up RULESET and ITEMSET for the transitions out of CORE state. +Given a vector of item numbers items, of length N, set up RULESET and +ITEMSET to indicate what rules could be run and which items could be +accepted when those items are the active ones. + +RULESET contains a bit for each rule. `wisent-closure' sets the bits +for all rules which could potentially describe the next input to be +read. + +ITEMSET is a vector of item numbers; NITEMSET is the number of items +in ITEMSET. `wisent-closure' places there the indices of all items +which represent units of input that could arrive next." + (let (c r v symbol ruleno itemno) + (if (zerop n) + (progn + (setq r 0 + v (aref fderives (- start-symbol ntokens))) + (while (< r rulesetsize) + ;; ruleset[r] = FDERIVES (start-symbol)[r]; + (aset ruleset r (aref v r)) + (setq r (1+ r))) + ) + (fillarray ruleset 0) + (setq c 0) + (while (< c n) + (setq symbol (aref ritem (aref core c))) + (when (wisent-ISVAR symbol) + (setq r 0 + v (aref fderives (- symbol ntokens))) + (while (< r rulesetsize) + ;; ruleset[r] |= FDERIVES (ritem[core[c]])[r]; + (aset ruleset r (logior (aref ruleset r) (aref v r))) + (setq r (1+ r)))) + (setq c (1+ c))) + ) + (setq nitemset 0 + c 0 + ruleno 0 + r (* rulesetsize wisent-BITS-PER-WORD)) + (while (< ruleno r) + (when (wisent-BITISSET ruleset ruleno) + (setq itemno (aref rrhs ruleno)) + (while (and (< c n) (< (aref core c) itemno)) + (aset itemset nitemset (aref core c)) + (setq nitemset (1+ nitemset) + c (1+ c))) + (aset itemset nitemset itemno) + (setq nitemset (1+ nitemset))) + (setq ruleno (1+ ruleno))) + + (while (< c n) + (aset itemset nitemset (aref core c)) + (setq nitemset (1+ nitemset) + c (1+ c))) + + (if wisent-debug-flag + (wisent-print-closure)) + )) + +;;;; -------------------------------------------------- +;;;; Generate the nondeterministic finite state machine +;;;; -------------------------------------------------- + +(defun wisent-allocate-itemsets () + "Allocate storage for itemsets." + (let (symbol i count symbol-count) + ;; Count the number of occurrences of all the symbols in RITEMS. + ;; Note that useless productions (hence useless nonterminals) are + ;; browsed too, hence we need to allocate room for _all_ the + ;; symbols. + (setq count 0 + symbol-count (make-vector (+ nsyms nuseless-nonterminals) 0) + i 0) + (while (setq symbol (aref ritem i)) + (when (> symbol 0) + (setq count (1+ count)) + (aset symbol-count symbol (1+ (aref symbol-count symbol)))) + (setq i (1+ i))) + ;; See comments before `wisent-new-itemsets'. All the vectors of + ;; items live inside kernel-items. The number of active items + ;; after some symbol cannot be more than the number of times that + ;; symbol appears as an item, which is symbol-count[symbol]. We + ;; allocate that much space for each symbol. + (setq kernel-base (make-vector nsyms nil) + kernel-items (make-vector count 0) + count 0 + i 0) + (while (< i nsyms) + (aset kernel-base i count) + (setq count (+ count (aref symbol-count i)) + i (1+ i))) + (setq shift-symbol symbol-count + kernel-end (make-vector nsyms nil)) + )) + +(defun wisent-allocate-storage () + "Allocate storage for the state machine." + (wisent-allocate-itemsets) + (setq shiftset (make-vector nsyms 0) + redset (make-vector (1+ nrules) 0) + state-table (make-vector wisent-state-table-size nil))) + +(defun wisent-new-itemsets () + "Find which symbols can be shifted in the current state. +And for each one record which items would be active after that shift. +Uses the contents of ITEMSET. SHIFT-SYMBOL is set to a vector of the +symbols that can be shifted. For each symbol in the grammar, +KERNEL-BASE[symbol] points to a vector of item numbers activated if +that symbol is shifted, and KERNEL-END[symbol] points after the end of +that vector." + (let (i shiftcount isp ksp symbol) + (fillarray kernel-end nil) + (setq shiftcount 0 + isp 0) + (while (< isp nitemset) + (setq i (aref itemset isp) + isp (1+ isp) + symbol (aref ritem i)) + (when (> symbol 0) + (setq ksp (aref kernel-end symbol)) + (when (not ksp) + ;; shift-symbol[shiftcount++] = symbol; + (aset shift-symbol shiftcount symbol) + (setq shiftcount (1+ shiftcount) + ksp (aref kernel-base symbol))) + ;; *ksp++ = i + 1; + (aset kernel-items ksp (1+ i)) + (setq ksp (1+ ksp)) + (aset kernel-end symbol ksp))) + (setq nshifts shiftcount))) + +(defun wisent-new-state (symbol) + "Create a new state for those items, if necessary. +SYMBOL is the core accessing-symbol. +Subroutine of `wisent-get-state'." + (let (n p isp1 isp2 iend items) + (setq isp1 (aref kernel-base symbol) + iend (aref kernel-end symbol) + n (- iend isp1) + p (make-core) + items (make-vector n 0)) + (set-core-accessing-symbol p symbol) + (set-core-number p nstates) + (set-core-nitems p n) + (set-core-items p items) + (setq isp2 0) ;; isp2 = p->items + (while (< isp1 iend) + ;; *isp2++ = *isp1++; + (aset items isp2 (aref kernel-items isp1)) + (setq isp1 (1+ isp1) + isp2 (1+ isp2))) + (set-core-next last-state p) + (setq last-state p + nstates (1+ nstates)) + p)) + +(defun wisent-get-state (symbol) + "Find the state we would get to by shifting SYMBOL. +Return the state number for the state we would get to (from the +current state) by shifting SYMBOL. Create a new state if no +equivalent one exists already. Used by `wisent-append-states'." + (let (key isp1 isp2 iend sp sp2 found n) + (setq isp1 (aref kernel-base symbol) + iend (aref kernel-end symbol) + n (- iend isp1) + key 0) + ;; Add up the target state's active item numbers to get a hash key + (while (< isp1 iend) + (setq key (+ key (aref kernel-items isp1)) + isp1 (1+ isp1))) + (setq key (% key wisent-state-table-size) + sp (aref state-table key)) + (if sp + (progn + (setq found nil) + (while (not found) + (when (= (core-nitems sp) n) + (setq found t + isp1 (aref kernel-base symbol) + ;; isp2 = sp->items; + sp2 (core-items sp) + isp2 0) + + (while (and found (< isp1 iend)) + ;; if (*isp1++ != *isp2++) + (if (not (= (aref kernel-items isp1) + (aref sp2 isp2))) + (setq found nil)) + (setq isp1 (1+ isp1) + isp2 (1+ isp2)))) + (if (not found) + (if (core-link sp) + (setq sp (core-link sp)) + ;; sp = sp->link = new-state(symbol) + (setq sp (set-core-link sp (wisent-new-state symbol)) + found t))))) + ;; bucket is empty + ;; state-table[key] = sp = new-state(symbol) + (setq sp (wisent-new-state symbol)) + (aset state-table key sp)) + ;; return (sp->number); + (core-number sp))) + +(defun wisent-append-states () + "Find or create the core structures for states. +Use the information computed by `wisent-new-itemsets' to find the +state numbers reached by each shift transition from the current state. +SHIFTSET is set up as a vector of state numbers of those states." + (let (i j symbol) + ;; First sort shift-symbol into increasing order + (setq i 1) + (while (< i nshifts) + (setq symbol (aref shift-symbol i) + j i) + (while (and (> j 0) (> (aref shift-symbol (1- j)) symbol)) + (aset shift-symbol j (aref shift-symbol (1- j))) + (setq j (1- j))) + (aset shift-symbol j symbol) + (setq i (1+ i))) + (setq i 0) + (while (< i nshifts) + (setq symbol (aref shift-symbol i)) + (aset shiftset i (wisent-get-state symbol)) + (setq i (1+ i))) + )) + +(defun wisent-initialize-states () + "Initialize states." + (let ((p (make-core))) + (setq first-state p + last-state p + this-state p + nstates 1))) + +(defun wisent-save-shifts () + "Save the NSHIFTS of SHIFTSET into the current linked list." + (let (p i shifts) + (setq p (make-shifts) + shifts (make-vector nshifts 0) + i 0) + (set-shifts-number p (core-number this-state)) + (set-shifts-nshifts p nshifts) + (set-shifts-shifts p shifts) + (while (< i nshifts) + ;; (p->shifts)[i] = shiftset[i]; + (aset shifts i (aref shiftset i)) + (setq i (1+ i))) + + (if last-shift + (set-shifts-next last-shift p) + (setq first-shift p)) + (setq last-shift p))) + +(defun wisent-insert-start-shift () + "Create the next-to-final state. +That is the state to which a shift has already been made in the +initial state. Subroutine of `wisent-augment-automaton'." + (let (statep sp) + (setq statep (make-core)) + (set-core-number statep nstates) + (set-core-accessing-symbol statep start-symbol) + (set-core-next last-state statep) + (setq last-state statep) + ;; Make a shift from this state to (what will be) the final state. + (setq sp (make-shifts)) + (set-shifts-number sp nstates) + (setq nstates (1+ nstates)) + (set-shifts-nshifts sp 1) + (set-shifts-shifts sp (vector nstates)) + (set-shifts-next last-shift sp) + (setq last-shift sp))) + +(defun wisent-augment-automaton () + "Set up initial and final states as parser wants them. +Make sure that the initial state has a shift that accepts the +grammar's start symbol and goes to the next-to-final state, which has +a shift going to the final state, which has a shift to the termination +state. Create such states and shifts if they don't happen to exist +already." + (let (i k statep sp sp2 sp1 shifts) + (setq sp first-shift) + (if sp + (progn + (if (zerop (shifts-number sp)) + (progn + (setq k (shifts-nshifts sp) + statep (core-next first-state)) + ;; The states reached by shifts from first-state are + ;; numbered 1...K. Look for one reached by + ;; START-SYMBOL. + (while (and (< (core-accessing-symbol statep) start-symbol) + (< (core-number statep) k)) + (setq statep (core-next statep))) + (if (= (core-accessing-symbol statep) start-symbol) + (progn + ;; We already have a next-to-final state. Make + ;; sure it has a shift to what will be the final + ;; state. + (setq k (core-number statep)) + (while (and sp (< (shifts-number sp) k)) + (setq sp1 sp + sp (shifts-next sp))) + (if (and sp (= (shifts-number sp) k)) + (progn + (setq i (shifts-nshifts sp) + sp2 (make-shifts) + shifts (make-vector (1+ i) 0)) + (set-shifts-number sp2 k) + (set-shifts-nshifts sp2 (1+ i)) + (set-shifts-shifts sp2 shifts) + (aset shifts 0 nstates) + (while (> i 0) + ;; sp2->shifts[i] = sp->shifts[i - 1]; + (aset shifts i (aref (shifts-shifts sp) (1- i))) + (setq i (1- i))) + ;; Patch sp2 into the chain of shifts in + ;; place of sp, following sp1. + (set-shifts-next sp2 (shifts-next sp)) + (set-shifts-next sp1 sp2) + (if (eq sp last-shift) + (setq last-shift sp2)) + ) + (setq sp2 (make-shifts)) + (set-shifts-number sp2 k) + (set-shifts-nshifts sp2 1) + (set-shifts-shifts sp2 (vector nstates)) + ;; Patch sp2 into the chain of shifts between + ;; sp1 and sp. + (set-shifts-next sp2 sp) + (set-shifts-next sp1 sp2) + (if (not sp) + (setq last-shift sp2)) + ) + ) + ;; There is no next-to-final state as yet. + ;; Add one more shift in FIRST-SHIFT, going to the + ;; next-to-final state (yet to be made). + (setq sp first-shift + sp2 (make-shifts) + i (shifts-nshifts sp) + shifts (make-vector (1+ i) 0)) + (set-shifts-nshifts sp2 (1+ i)) + (set-shifts-shifts sp2 shifts) + ;; Stick this shift into the vector at the proper place. + (setq statep (core-next first-state) + k 0 + i 0) + (while (< i (shifts-nshifts sp)) + (when (and (> (core-accessing-symbol statep) start-symbol) + (= i k)) + (aset shifts k nstates) + (setq k (1+ k))) + (aset shifts k (aref (shifts-shifts sp) i)) + (setq statep (core-next statep)) + (setq i (1+ i) + k (1+ k))) + (when (= i k) + (aset shifts k nstates) + (setq k (1+ k))) + ;; Patch sp2 into the chain of shifts in place of + ;; sp, at the beginning. + (set-shifts-next sp2 (shifts-next sp)) + (setq first-shift sp2) + (if (eq last-shift sp) + (setq last-shift sp2)) + ;; Create the next-to-final state, with shift to + ;; what will be the final state. + (wisent-insert-start-shift))) + ;; The initial state didn't even have any shifts. Give it + ;; one shift, to the next-to-final state. + (setq sp (make-shifts)) + (set-shifts-nshifts sp 1) + (set-shifts-shifts sp (vector nstates)) + ;; Patch sp into the chain of shifts at the beginning. + (set-shifts-next sp first-shift) + (setq first-shift sp) + ;; Create the next-to-final state, with shift to what will + ;; be the final state. + (wisent-insert-start-shift))) + ;; There are no shifts for any state. Make one shift, from the + ;; initial state to the next-to-final state. + (setq sp (make-shifts)) + (set-shifts-nshifts sp 1) + (set-shifts-shifts sp (vector nstates)) + ;; Initialize the chain of shifts with sp. + (setq first-shift sp + last-shift sp) + ;; Create the next-to-final state, with shift to what will be + ;; the final state. + (wisent-insert-start-shift)) + ;; Make the final state--the one that follows a shift from the + ;; next-to-final state. The symbol for that shift is 0 + ;; (end-of-file). + (setq statep (make-core)) + (set-core-number statep nstates) + (set-core-next last-state statep) + (setq last-state statep) + ;; Make the shift from the final state to the termination state. + (setq sp (make-shifts)) + (set-shifts-number sp nstates) + (setq nstates (1+ nstates)) + (set-shifts-nshifts sp 1) + (set-shifts-shifts sp (vector nstates)) + (set-shifts-next last-shift sp) + (setq last-shift sp) + ;; Note that the variable FINAL-STATE refers to what we sometimes + ;; call the termination state. + (setq final-state nstates) + ;; Make the termination state. + (setq statep (make-core)) + (set-core-number statep nstates) + (setq nstates (1+ nstates)) + (set-core-next last-state statep) + (setq last-state statep))) + +(defun wisent-save-reductions () + "Make a reductions structure. +Find which rules can be used for reduction transitions from the +current state and make a reductions structure for the state to record +their rule numbers." + (let (i item count p rules) + ;; Find and count the active items that represent ends of rules. + (setq count 0 + i 0) + (while (< i nitemset) + (setq item (aref ritem (aref itemset i))) + (when (< item 0) + (aset redset count (- item)) + (setq count (1+ count))) + (setq i (1+ i))) + ;; Make a reductions structure and copy the data into it. + (when (> count 0) + (setq p (make-reductions) + rules (make-vector count 0)) + (set-reductions-number p (core-number this-state)) + (set-reductions-nreds p count) + (set-reductions-rules p rules) + (setq i 0) + (while (< i count) + ;; (p->rules)[i] = redset[i] + (aset rules i (aref redset i)) + (setq i (1+ i))) + (if last-reduction + (set-reductions-next last-reduction p) + (setq first-reduction p)) + (setq last-reduction p)))) + +(defun wisent-generate-states () + "Compute the nondeterministic finite state machine from the grammar." + (wisent-allocate-storage) + (wisent-initialize-closure nitems) + (wisent-initialize-states) + (while this-state + ;; Set up RULESET and ITEMSET for the transitions out of this + ;; state. RULESET gets a 1 bit for each rule that could reduce + ;; now. ITEMSET gets a vector of all the items that could be + ;; accepted next. + (wisent-closure (core-items this-state) (core-nitems this-state)) + ;; Record the reductions allowed out of this state. + (wisent-save-reductions) + ;; Find the itemsets of the states that shifts can reach. + (wisent-new-itemsets) + ;; Find or create the core structures for those states. + (wisent-append-states) + ;; Create the shifts structures for the shifts to those states, + ;; now that the state numbers transitioning to are known. + (if (> nshifts 0) + (wisent-save-shifts)) + ;; States are queued when they are created; process them all. + (setq this-state (core-next this-state))) + ;; Set up initial and final states as parser wants them. + (wisent-augment-automaton)) + +;;;; --------------------------- +;;;; Compute look-ahead criteria +;;;; --------------------------- + +;; Compute how to make the finite state machine deterministic; find +;; which rules need lookahead in each state, and which lookahead +;; tokens they accept. + +;; `wisent-lalr', the entry point, builds these data structures: + +;; GOTO-MAP, FROM-STATE and TO-STATE record each shift transition +;; which accepts a variable (a nonterminal). NGOTOS is the number of +;; such transitions. +;; FROM-STATE[t] is the state number which a transition leads from and +;; TO-STATE[t] is the state number it leads to. +;; All the transitions that accept a particular variable are grouped +;; together and GOTO-MAP[i - NTOKENS] is the index in FROM-STATE and +;; TO-STATE of the first of them. + +;; CONSISTENT[s] is non-nil if no lookahead is needed to decide what +;; to do in state s. + +;; LARULENO is a vector which records the rules that need lookahead in +;; various states. The elements of LARULENO that apply to state s are +;; those from LOOKAHEADS[s] through LOOKAHEADS[s+1]-1. Each element +;; of LARULENO is a rule number. + +;; If LR is the length of LARULENO, then a number from 0 to LR-1 can +;; specify both a rule and a state where the rule might be applied. +;; LA is a LR by NTOKENS matrix of bits. +;; LA[l, i] is 1 if the rule LARULENO[l] is applicable in the +;; appropriate state when the next token is symbol i. +;; If LA[l, i] and LA[l, j] are both 1 for i != j, it is a conflict. + +(wisent-defcontext digraph + INDEX R VERTICES + infinity top) + +(defun wisent-traverse (i) + "Traverse I." + (let (j k height Ri Fi break) + (setq top (1+ top) + height top) + (aset VERTICES top i) ;; VERTICES[++top] = i + (aset INDEX i top) ;; INDEX[i] = height = top + + (setq Ri (aref R i)) + (when Ri + (setq j 0) + (while (>= (aref Ri j) 0) + (if (zerop (aref INDEX (aref Ri j))) + (wisent-traverse (aref Ri j))) + ;; if (INDEX[i] > INDEX[R[i][j]]) + (if (> (aref INDEX i) (aref INDEX (aref Ri j))) + ;; INDEX[i] = INDEX[R[i][j]]; + (aset INDEX i (aref INDEX (aref Ri j)))) + (setq Fi (aref F i) + k 0) + (while (< k tokensetsize) + ;; F (i)[k] |= F (R[i][j])[k]; + (aset Fi k (logior (aref Fi k) + (aref (aref F (aref Ri j)) k))) + (setq k (1+ k))) + (setq j (1+ j)))) + + (when (= (aref INDEX i) height) + (setq break nil) + (while (not break) + (setq j (aref VERTICES top) ;; j = VERTICES[top--] + top (1- top)) + (aset INDEX j infinity) + (if (= i j) + (setq break t) + (setq k 0) + (while (< k tokensetsize) + ;; F (j)[k] = F (i)[k]; + (aset (aref F j) k (aref (aref F i) k)) + (setq k (1+ k)))))) + )) + +(defun wisent-digraph (relation) + "Digraph RELATION." + (wisent-with-context digraph + (setq infinity (+ ngotos 2) + INDEX (make-vector (1+ ngotos) 0) + VERTICES (make-vector (1+ ngotos) 0) + top 0 + R relation) + (let ((i 0)) + (while (< i ngotos) + (if (and (= (aref INDEX i) 0) (aref R i)) + (wisent-traverse i)) + (setq i (1+ i)))))) + +(defun wisent-set-state-table () + "Build state table." + (let (sp) + (setq state-table (make-vector nstates nil) + sp first-state) + (while sp + (aset state-table (core-number sp) sp) + (setq sp (core-next sp))))) + +(defun wisent-set-accessing-symbol () + "Build accessing symbol table." + (let (sp) + (setq accessing-symbol (make-vector nstates 0) + sp first-state) + (while sp + (aset accessing-symbol (core-number sp) (core-accessing-symbol sp)) + (setq sp (core-next sp))))) + +(defun wisent-set-shift-table () + "Build shift table." + (let (sp) + (setq shift-table (make-vector nstates nil) + sp first-shift) + (while sp + (aset shift-table (shifts-number sp) sp) + (setq sp (shifts-next sp))))) + +(defun wisent-set-reduction-table () + "Build reduction table." + (let (rp) + (setq reduction-table (make-vector nstates nil) + rp first-reduction) + (while rp + (aset reduction-table (reductions-number rp) rp) + (setq rp (reductions-next rp))))) + +(defun wisent-set-maxrhs () + "Setup MAXRHS length." + (let (i len max) + (setq len 0 + max 0 + i 0) + (while (aref ritem i) + (if (> (aref ritem i) 0) + (setq len (1+ len)) + (if (> len max) + (setq max len)) + (setq len 0)) + (setq i (1+ i))) + (setq maxrhs max))) + +(defun wisent-initialize-LA () + "Set up LA." + (let (i j k count rp sp np v) + (setq consistent (make-vector nstates nil) + lookaheads (make-vector (1+ nstates) 0) + count 0 + i 0) + (while (< i nstates) + (aset lookaheads i count) + (setq rp (aref reduction-table i) + sp (aref shift-table i)) + ;; if (rp && + ;; (rp->nreds > 1 + ;; || (sp && ! ISVAR(accessing-symbol[sp->shifts[0]])))) + (if (and rp + (or (> (reductions-nreds rp) 1) + (and sp + (not (wisent-ISVAR + (aref accessing-symbol + (aref (shifts-shifts sp) 0))))))) + (setq count (+ count (reductions-nreds rp))) + (aset consistent i t)) + + (when sp + (setq k 0 + j (shifts-nshifts sp) + v (shifts-shifts sp)) + (while (< k j) + (when (= (aref accessing-symbol (aref v k)) + error-token-number) + (aset consistent i nil) + (setq k j)) ;; break + (setq k (1+ k)))) + (setq i (1+ i))) + + (aset lookaheads nstates count) + + (if (zerop count) + (progn + (setq LA (make-vector 1 nil) + LAruleno (make-vector 1 0) + lookback (make-vector 1 nil))) + (setq LA (make-vector count nil) + LAruleno (make-vector count 0) + lookback (make-vector count nil))) + (setq i 0 j (length LA)) + (while (< i j) + (aset LA i (make-vector tokensetsize 0)) + (setq i (1+ i))) + + (setq np 0 + i 0) + (while (< i nstates) + (when (not (aref consistent i)) + (setq rp (aref reduction-table i)) + (when rp + (setq j 0 + k (reductions-nreds rp) + v (reductions-rules rp)) + (while (< j k) + (aset LAruleno np (aref v j)) + (setq np (1+ np) + j (1+ j))))) + (setq i (1+ i))))) + +(defun wisent-set-goto-map () + "Set up GOTO-MAP." + (let (sp i j symbol k temp-map state1 state2 v) + (setq goto-map (make-vector (1+ nvars) 0) + temp-map (make-vector (1+ nvars) 0)) + + (setq ngotos 0 + sp first-shift) + (while sp + (setq i (1- (shifts-nshifts sp)) + v (shifts-shifts sp)) + (while (>= i 0) + (setq symbol (aref accessing-symbol (aref v i))) + (if (wisent-ISTOKEN symbol) + (setq i 0) ;; break + (setq ngotos (1+ ngotos)) + ;; goto-map[symbol]++; + (aset goto-map (- symbol ntokens) + (1+ (aref goto-map (- symbol ntokens))))) + (setq i (1- i))) + (setq sp (shifts-next sp))) + + (setq k 0 + i ntokens + j 0) + (while (< i nsyms) + (aset temp-map j k) + (setq k (+ k (aref goto-map j)) + i (1+ i) + j (1+ j))) + (setq i ntokens + j 0) + (while (< i nsyms) + (aset goto-map j (aref temp-map j)) + (setq i (1+ i) + j (1+ j))) + ;; goto-map[nsyms] = ngotos; + ;; temp-map[nsyms] = ngotos; + (aset goto-map j ngotos) + (aset temp-map j ngotos) + + (setq from-state (make-vector ngotos 0) + to-state (make-vector ngotos 0) + sp first-shift) + (while sp + (setq state1 (shifts-number sp) + v (shifts-shifts sp) + i (1- (shifts-nshifts sp))) + (while (>= i 0) + (setq state2 (aref v i) + symbol (aref accessing-symbol state2)) + (if (wisent-ISTOKEN symbol) + (setq i 0) ;; break + ;; k = temp-map[symbol]++; + (setq k (aref temp-map (- symbol ntokens))) + (aset temp-map (- symbol ntokens) (1+ k)) + (aset from-state k state1) + (aset to-state k state2)) + (setq i (1- i))) + (setq sp (shifts-next sp))) + )) + +(defun wisent-map-goto (state symbol) + "Map a STATE/SYMBOL pair into its numeric representation." + (let (high low middle s result) + ;; low = goto-map[symbol]; + ;; high = goto-map[symbol + 1] - 1; + (setq low (aref goto-map (- symbol ntokens)) + high (1- (aref goto-map (- (1+ symbol) ntokens)))) + (while (and (not result) (<= low high)) + (setq middle (/ (+ low high) 2) + s (aref from-state middle)) + (cond + ((= s state) + (setq result middle)) + ((< s state) + (setq low (1+ middle))) + (t + (setq high (1- middle))))) + (or result + (error "Internal error in `wisent-map-goto'")) + )) + +(defun wisent-initialize-F () + "Set up F." + (let (i j k sp edge rowp rp reads nedges stateno symbol v break) + (setq F (make-vector ngotos nil) + i 0) + (while (< i ngotos) + (aset F i (make-vector tokensetsize 0)) + (setq i (1+ i))) + + (setq reads (make-vector ngotos nil) + edge (make-vector (1+ ngotos) 0) + nedges 0 + rowp 0 ;; rowp = F + i 0) + (while (< i ngotos) + (setq stateno (aref to-state i) + sp (aref shift-table stateno)) + (when sp + (setq k (shifts-nshifts sp) + v (shifts-shifts sp) + j 0 + break nil) + (while (and (not break) (< j k)) + ;; symbol = accessing-symbol[sp->shifts[j]]; + (setq symbol (aref accessing-symbol (aref v j))) + (if (wisent-ISVAR symbol) + (setq break t) ;; break + (wisent-SETBIT (aref F rowp) symbol) + (setq j (1+ j)))) + + (while (< j k) + ;; symbol = accessing-symbol[sp->shifts[j]]; + (setq symbol (aref accessing-symbol (aref v j))) + (when (aref nullable (- symbol ntokens)) + (aset edge nedges (wisent-map-goto stateno symbol)) + (setq nedges (1+ nedges))) + (setq j (1+ j))) + + (when (> nedges 0) + ;; reads[i] = rp = NEW2(nedges + 1, short); + (setq rp (make-vector (1+ nedges) 0) + j 0) + (aset reads i rp) + (while (< j nedges) + ;; rp[j] = edge[j]; + (aset rp j (aref edge j)) + (setq j (1+ j))) + (aset rp nedges -1) + (setq nedges 0))) + (setq rowp (1+ rowp)) + (setq i (1+ i))) + (wisent-digraph reads) + )) + +(defun wisent-add-lookback-edge (stateno ruleno gotono) + "Add a lookback edge. +STATENO, RULENO, GOTONO are self-explanatory." + (let (i k found) + (setq i (aref lookaheads stateno) + k (aref lookaheads (1+ stateno)) + found nil) + (while (and (not found) (< i k)) + (if (= (aref LAruleno i) ruleno) + (setq found t) + (setq i (1+ i)))) + + (or found + (error "Internal error in `wisent-add-lookback-edge'")) + + ;; value . next + ;; lookback[i] = (gotono . lookback[i]) + (aset lookback i (cons gotono (aref lookback i))))) + +(defun wisent-transpose (R-arg n) + "Return the transpose of R-ARG, of size N. +Destroy R-ARG, as it is replaced with the result. R-ARG[I] is nil or +a -1 terminated list of numbers. RESULT[NUM] is nil or the -1 +terminated list of the I such as NUM is in R-ARG[I]." + (let (i j new-R end-R nedges v sp) + (setq new-R (make-vector n nil) + end-R (make-vector n nil) + nedges (make-vector n 0)) + + ;; Count. + (setq i 0) + (while (< i n) + (setq v (aref R-arg i)) + (when v + (setq j 0) + (while (>= (aref v j) 0) + (aset nedges (aref v j) (1+ (aref nedges (aref v j)))) + (setq j (1+ j)))) + (setq i (1+ i))) + + ;; Allocate. + (setq i 0) + (while (< i n) + (when (> (aref nedges i) 0) + (setq sp (make-vector (1+ (aref nedges i)) 0)) + (aset sp (aref nedges i) -1) + (aset new-R i sp) + (aset end-R i 0)) + (setq i (1+ i))) + + ;; Store. + (setq i 0) + (while (< i n) + (setq v (aref R-arg i)) + (when v + (setq j 0) + (while (>= (aref v j) 0) + (aset (aref new-R (aref v j)) (aref end-R (aref v j)) i) + (aset end-R (aref v j) (1+ (aref end-R (aref v j)))) + (setq j (1+ j)))) + (setq i (1+ i))) + + new-R)) + +(defun wisent-build-relations () + "Build relations." + (let (i j k rulep rp sp length nedges done state1 stateno + symbol1 symbol2 edge states v) + (setq includes (make-vector ngotos nil) + edge (make-vector (1+ ngotos) 0) + states (make-vector (1+ maxrhs) 0) + i 0) + + (while (< i ngotos) + (setq nedges 0 + state1 (aref from-state i) + symbol1 (aref accessing-symbol (aref to-state i)) + rulep (aref derives (- symbol1 ntokens))) + + (while (> (car rulep) 0) + (aset states 0 state1) + (setq length 1 + stateno state1 + rp (aref rrhs (car rulep))) ;; rp = ritem + rrhs[*rulep] + (while (> (aref ritem rp) 0) ;; *rp > 0 + (setq symbol2 (aref ritem rp) + sp (aref shift-table stateno) + k (shifts-nshifts sp) + v (shifts-shifts sp) + j 0) + (while (< j k) + (setq stateno (aref v j)) + (if (= (aref accessing-symbol stateno) symbol2) + (setq j k) ;; break + (setq j (1+ j)))) + ;; states[length++] = stateno; + (aset states length stateno) + (setq length (1+ length)) + (setq rp (1+ rp))) + + (if (not (aref consistent stateno)) + (wisent-add-lookback-edge stateno (car rulep) i)) + + (setq length (1- length) + done nil) + (while (not done) + (setq done t + rp (1- rp)) + (when (and (>= rp 0) (wisent-ISVAR (aref ritem rp))) + ;; stateno = states[--length]; + (setq length (1- length) + stateno (aref states length)) + (aset edge nedges (wisent-map-goto stateno (aref ritem rp))) + (setq nedges (1+ nedges)) + (if (aref nullable (- (aref ritem rp) ntokens)) + (setq done nil)))) + (setq rulep (cdr rulep))) + + (when (> nedges 0) + (setq v (make-vector (1+ nedges) 0) + j 0) + (aset includes i v) + (while (< j nedges) + (aset v j (aref edge j)) + (setq j (1+ j))) + (aset v nedges -1)) + (setq i (1+ i))) + + (setq includes (wisent-transpose includes ngotos)) + )) + +(defun wisent-compute-FOLLOWS () + "Compute follows." + (wisent-digraph includes)) + +(defun wisent-compute-lookaheads () + "Compute lookaheads." + (let (i j n v1 v2 sp) + (setq n (aref lookaheads nstates) + i 0) + (while (< i n) + (setq sp (aref lookback i)) + (while sp + (setq v1 (aref LA i) + v2 (aref F (car sp)) + j 0) + (while (< j tokensetsize) + ;; LA (i)[j] |= F (sp->value)[j] + (aset v1 j (logior (aref v1 j) (aref v2 j))) + (setq j (1+ j))) + (setq sp (cdr sp))) + (setq i (1+ i))))) + +(defun wisent-lalr () + "Make the nondeterministic finite state machine deterministic." + (setq tokensetsize (wisent-WORDSIZE ntokens)) + (wisent-set-state-table) + (wisent-set-accessing-symbol) + (wisent-set-shift-table) + (wisent-set-reduction-table) + (wisent-set-maxrhs) + (wisent-initialize-LA) + (wisent-set-goto-map) + (wisent-initialize-F) + (wisent-build-relations) + (wisent-compute-FOLLOWS) + (wisent-compute-lookaheads)) + +;;;; ----------------------------------------------- +;;;; Find and resolve or report look-ahead conflicts +;;;; ----------------------------------------------- + +(defsubst wisent-log-resolution (state LAno token resolution) + "Log a shift-reduce conflict resolution. +In specified STATE between rule pointed by lookahead number LANO and +TOKEN, resolved as RESOLUTION." + (if (or wisent-verbose-flag wisent-debug-flag) + (wisent-log + "Conflict in state %d between rule %d and token %s resolved as %s.\n" + state (aref LAruleno LAno) (wisent-tag token) resolution))) + +(defun wisent-flush-shift (state token) + "Turn off the shift recorded in the specified STATE for TOKEN. +Used when we resolve a shift-reduce conflict in favor of the reduction." + (let (shiftp i k v) + (when (setq shiftp (aref shift-table state)) + (setq k (shifts-nshifts shiftp) + v (shifts-shifts shiftp) + i 0) + (while (< i k) + (if (and (not (zerop (aref v i))) + (= token (aref accessing-symbol (aref v i)))) + (aset v i 0)) + (setq i (1+ i)))))) + +(defun wisent-resolve-sr-conflict (state lookaheadnum) + "Attempt to resolve shift-reduce conflict for one rule. +Resolve by means of precedence declarations. The conflict occurred in +specified STATE for the rule pointed by the lookahead symbol +LOOKAHEADNUM. It has already been checked that the rule has a +precedence. A conflict is resolved by modifying the shift or reduce +tables so that there is no longer a conflict." + (let (i redprec errp errs nerrs token sprec sassoc) + ;; Find the rule to reduce by to get precedence of reduction + (setq token (aref tags (aref rprec (aref LAruleno lookaheadnum))) + redprec (wisent-prec token) + errp (make-errs) + errs (make-vector ntokens 0) + nerrs 0 + i 0) + (set-errs-errs errp errs) + (while (< i ntokens) + (setq token (aref tags i)) + (when (and (wisent-BITISSET (aref LA lookaheadnum) i) + (wisent-BITISSET lookaheadset i) + (setq sprec (wisent-prec token))) + ;; Shift-reduce conflict occurs for token number I and it has + ;; a precedence. The precedence of shifting is that of token + ;; I. + (cond + ((< sprec redprec) + (wisent-log-resolution state lookaheadnum i "reduce") + ;; Flush the shift for this token + (wisent-RESETBIT lookaheadset i) + (wisent-flush-shift state i) + ) + ((> sprec redprec) + (wisent-log-resolution state lookaheadnum i "shift") + ;; Flush the reduce for this token + (wisent-RESETBIT (aref LA lookaheadnum) i) + ) + (t + ;; Matching precedence levels. + ;; For left association, keep only the reduction. + ;; For right association, keep only the shift. + ;; For nonassociation, keep neither. + (setq sassoc (wisent-assoc token)) + (cond + ((eq sassoc 'right) + (wisent-log-resolution state lookaheadnum i "shift")) + ((eq sassoc 'left) + (wisent-log-resolution state lookaheadnum i "reduce")) + ((eq sassoc 'nonassoc) + (wisent-log-resolution state lookaheadnum i "an error")) + ) + (when (not (eq sassoc 'right)) + ;; Flush the shift for this token + (wisent-RESETBIT lookaheadset i) + (wisent-flush-shift state i)) + (when (not (eq sassoc 'left)) + ;; Flush the reduce for this token + (wisent-RESETBIT (aref LA lookaheadnum) i)) + (when (eq sassoc 'nonassoc) + ;; Record an explicit error for this token + (aset errs nerrs i) + (setq nerrs (1+ nerrs))) + ))) + (setq i (1+ i))) + (when (> nerrs 0) + (set-errs-nerrs errp nerrs) + (aset err-table state errp)) + )) + +(defun wisent-set-conflicts (state) + "Find and attempt to resolve conflicts in specified STATE." + (let (i j k v shiftp symbol) + (unless (aref consistent state) + (fillarray lookaheadset 0) + + (when (setq shiftp (aref shift-table state)) + (setq k (shifts-nshifts shiftp) + v (shifts-shifts shiftp) + i 0) + (while (and (< i k) + (wisent-ISTOKEN + (setq symbol (aref accessing-symbol (aref v i))))) + (or (zerop (aref v i)) + (wisent-SETBIT lookaheadset symbol)) + (setq i (1+ i)))) + + ;; Loop over all rules which require lookahead in this state + ;; first check for shift-reduce conflict, and try to resolve + ;; using precedence + (setq i (aref lookaheads state) + k (aref lookaheads (1+ state))) + (while (< i k) + (when (aref rprec (aref LAruleno i)) + (setq v (aref LA i) + j 0) + (while (< j tokensetsize) + (if (zerop (logand (aref v j) (aref lookaheadset j))) + (setq j (1+ j)) + ;; if (LA (i)[j] & lookaheadset[j]) + (wisent-resolve-sr-conflict state i) + (setq j tokensetsize)))) ;; break + (setq i (1+ i))) + + ;; Loop over all rules which require lookahead in this state + ;; Check for conflicts not resolved above. + (setq i (aref lookaheads state)) + (while (< i k) + (setq v (aref LA i) + j 0) + (while (< j tokensetsize) + ;; if (LA (i)[j] & lookaheadset[j]) + (if (not (zerop (logand (aref v j) (aref lookaheadset j)))) + (aset conflicts state t)) + (setq j (1+ j))) + (setq j 0) + (while (< j tokensetsize) + ;; lookaheadset[j] |= LA (i)[j]; + (aset lookaheadset j (logior (aref lookaheadset j) + (aref v j))) + (setq j (1+ j))) + (setq i (1+ i))) + ))) + +(defun wisent-resolve-conflicts () + "Find and resolve conflicts." + (let (i) + (setq conflicts (make-vector nstates nil) + shiftset (make-vector tokensetsize 0) + lookaheadset (make-vector tokensetsize 0) + err-table (make-vector nstates nil) + i 0) + (while (< i nstates) + (wisent-set-conflicts i) + (setq i (1+ i))))) + +(defun wisent-count-sr-conflicts (state) + "Count the number of shift/reduce conflicts in specified STATE." + (let (i j k shiftp symbol v) + (setq src-count 0 + shiftp (aref shift-table state)) + (when shiftp + (fillarray shiftset 0) + (fillarray lookaheadset 0) + (setq k (shifts-nshifts shiftp) + v (shifts-shifts shiftp) + i 0) + (while (< i k) + (when (not (zerop (aref v i))) + (setq symbol (aref accessing-symbol (aref v i))) + (if (wisent-ISVAR symbol) + (setq i k) ;; break + (wisent-SETBIT shiftset symbol))) + (setq i (1+ i))) + + (setq k (aref lookaheads (1+ state)) + i (aref lookaheads state)) + (while (< i k) + (setq v (aref LA i) + j 0) + (while (< j tokensetsize) + ;; lookaheadset[j] |= LA (i)[j] + (aset lookaheadset j (logior (aref lookaheadset j) + (aref v j))) + (setq j (1+ j))) + (setq i (1+ i))) + + (setq k 0) + (while (< k tokensetsize) + ;; lookaheadset[k] &= shiftset[k]; + (aset lookaheadset k (logand (aref lookaheadset k) + (aref shiftset k))) + (setq k (1+ k))) + + (setq i 0) + (while (< i ntokens) + (if (wisent-BITISSET lookaheadset i) + (setq src-count (1+ src-count))) + (setq i (1+ i)))) + src-count)) + +(defun wisent-count-rr-conflicts (state) + "Count the number of reduce/reduce conflicts in specified STATE." + (let (i j count n m) + (setq rrc-count 0 + m (aref lookaheads state) + n (aref lookaheads (1+ state))) + (when (>= (- n m) 2) + (setq i 0) + (while (< i ntokens) + (setq count 0 + j m) + (while (< j n) + (if (wisent-BITISSET (aref LA j) i) + (setq count (1+ count))) + (setq j (1+ j))) + + (if (>= count 2) + (setq rrc-count (1+ rrc-count))) + (setq i (1+ i)))) + rrc-count)) + +(defvar wisent-expected-conflicts nil + "*If non-nil suppress the warning about shift/reduce conflicts. +It is a decimal integer N that says there should be no warning if +there are N shift/reduce conflicts and no reduce/reduce conflicts. A +warning is given if there are either more or fewer conflicts, or if +there are any reduce/reduce conflicts.") + +(defun wisent-total-conflicts () + "Report the total number of conflicts." + (unless (and (zerop rrc-total) + (or (zerop src-total) + (= src-total (or wisent-expected-conflicts 0)))) + (let* ((src (wisent-source)) + (src (if src (concat " in " src) "")) + (msg (format "Grammar%s contains" src))) + (if (> src-total 0) + (setq msg (format "%s %d shift/reduce conflict%s" + msg src-total (if (> src-total 1) + "s" "")))) + (if (and (> src-total 0) (> rrc-total 0)) + (setq msg (format "%s and" msg))) + (if (> rrc-total 0) + (setq msg (format "%s %d reduce/reduce conflict%s" + msg rrc-total (if (> rrc-total 1) + "s" "")))) + (message msg)))) + +(defun wisent-print-conflicts () + "Report conflicts." + (let (i) + (setq src-total 0 + rrc-total 0 + i 0) + (while (< i nstates) + (when (aref conflicts i) + (wisent-count-sr-conflicts i) + (wisent-count-rr-conflicts i) + (setq src-total (+ src-total src-count) + rrc-total (+ rrc-total rrc-count)) + (when (or wisent-verbose-flag wisent-debug-flag) + (wisent-log "State %d contains" i) + (if (> src-count 0) + (wisent-log " %d shift/reduce conflict%s" + src-count (if (> src-count 1) "s" ""))) + + (if (and (> src-count 0) (> rrc-count 0)) + (wisent-log " and")) + + (if (> rrc-count 0) + (wisent-log " %d reduce/reduce conflict%s" + rrc-count (if (> rrc-count 1) "s" ""))) + + (wisent-log ".\n"))) + (setq i (1+ i))) + (wisent-total-conflicts))) + +;;;; -------------------------------------- +;;;; Report information on generated parser +;;;; -------------------------------------- +(defun wisent-print-grammar () + "Print grammar." + (let (i j r break left-count right-count) + + (wisent-log "\n\nGrammar\n\n Number, Rule\n") + (setq i 1) + (while (<= i nrules) + ;; Don't print rules disabled in `wisent-reduce-grammar-tables'. + (when (aref ruseful i) + (wisent-log " %s %s ->" + (wisent-pad-string (number-to-string i) 6) + (wisent-tag (aref rlhs i))) + (setq r (aref rrhs i)) + (if (> (aref ritem r) 0) + (while (> (aref ritem r) 0) + (wisent-log " %s" (wisent-tag (aref ritem r))) + (setq r (1+ r))) + (wisent-log " /* empty */")) + (wisent-log "\n")) + (setq i (1+ i))) + + (wisent-log "\n\nTerminals, with rules where they appear\n\n") + (wisent-log "%s (-1)\n" (wisent-tag 0)) + (setq i 1) + (while (< i ntokens) + (wisent-log "%s (%d)" (wisent-tag i) i) + (setq j 1) + (while (<= j nrules) + (setq r (aref rrhs j) + break nil) + (while (and (not break) (> (aref ritem r) 0)) + (if (setq break (= (aref ritem r) i)) + (wisent-log " %d" j) + (setq r (1+ r)))) + (setq j (1+ j))) + (wisent-log "\n") + (setq i (1+ i))) + + (wisent-log "\n\nNonterminals, with rules where they appear\n\n") + (setq i ntokens) + (while (< i nsyms) + (setq left-count 0 + right-count 0 + j 1) + (while (<= j nrules) + (if (= (aref rlhs j) i) + (setq left-count (1+ left-count))) + (setq r (aref rrhs j) + break nil) + (while (and (not break) (> (aref ritem r) 0)) + (if (= (aref ritem r) i) + (setq right-count (1+ right-count) + break t) + (setq r (1+ r)))) + (setq j (1+ j))) + (wisent-log "%s (%d)\n " (wisent-tag i) i) + (when (> left-count 0) + (wisent-log " on left:") + (setq j 1) + (while (<= j nrules) + (if (= (aref rlhs j) i) + (wisent-log " %d" j)) + (setq j (1+ j)))) + (when (> right-count 0) + (if (> left-count 0) + (wisent-log ",")) + (wisent-log " on right:") + (setq j 1) + (while (<= j nrules) + (setq r (aref rrhs j) + break nil) + (while (and (not break) (> (aref ritem r) 0)) + (if (setq break (= (aref ritem r) i)) + (wisent-log " %d" j) + (setq r (1+ r)))) + (setq j (1+ j)))) + (wisent-log "\n") + (setq i (1+ i))) + )) + +(defun wisent-print-reductions (state) + "Print reductions on STATE." + (let (i j k v symbol m n defaulted + default-LA default-rule cmax count shiftp errp nodefault) + (setq nodefault nil + i 0) + (fillarray shiftset 0) + + (setq shiftp (aref shift-table state)) + (when shiftp + (setq k (shifts-nshifts shiftp) + v (shifts-shifts shiftp) + i 0) + (while (< i k) + (when (not (zerop (aref v i))) + (setq symbol (aref accessing-symbol (aref v i))) + (if (wisent-ISVAR symbol) + (setq i k) ;; break + ;; If this state has a shift for the error token, don't + ;; use a default rule. + (if (= symbol error-token-number) + (setq nodefault t)) + (wisent-SETBIT shiftset symbol))) + (setq i (1+ i)))) + + (setq errp (aref err-table state)) + (when errp + (setq k (errs-nerrs errp) + v (errs-errs errp) + i 0) + (while (< i k) + (if (not (zerop (setq symbol (aref v i)))) + (wisent-SETBIT shiftset symbol)) + (setq i (1+ i)))) + + (setq m (aref lookaheads state) + n (aref lookaheads (1+ state))) + + (cond + ((and (= (- n m) 1) (not nodefault)) + (setq default-rule (aref LAruleno m) + v (aref LA m) + k 0) + (while (< k tokensetsize) + (aset lookaheadset k (logand (aref v k) + (aref shiftset k))) + (setq k (1+ k))) + + (setq i 0) + (while (< i ntokens) + (if (wisent-BITISSET lookaheadset i) + (wisent-log " %s\t[reduce using rule %d (%s)]\n" + (wisent-tag i) default-rule + (wisent-tag (aref rlhs default-rule)))) + (setq i (1+ i))) + (wisent-log " $default\treduce using rule %d (%s)\n\n" + default-rule + (wisent-tag (aref rlhs default-rule))) + ) + ((>= (- n m) 1) + (setq cmax 0 + default-LA -1 + default-rule 0) + (when (not nodefault) + (setq i m) + (while (< i n) + (setq v (aref LA i) + count 0 + k 0) + (while (< k tokensetsize) + ;; lookaheadset[k] = LA (i)[k] & ~shiftset[k] + (aset lookaheadset k + (logand (aref v k) + (lognot (aref shiftset k)))) + (setq k (1+ k))) + (setq j 0) + (while (< j ntokens) + (if (wisent-BITISSET lookaheadset j) + (setq count (1+ count))) + (setq j (1+ j))) + (if (> count cmax) + (setq cmax count + default-LA i + default-rule (aref LAruleno i))) + (setq k 0) + (while (< k tokensetsize) + (aset shiftset k (logior (aref shiftset k) + (aref lookaheadset k))) + (setq k (1+ k))) + (setq i (1+ i)))) + + (fillarray shiftset 0) + + (when shiftp + (setq k (shifts-nshifts shiftp) + v (shifts-shifts shiftp) + i 0) + (while (< i k) + (when (not (zerop (aref v i))) + (setq symbol (aref accessing-symbol (aref v i))) + (if (wisent-ISVAR symbol) + (setq i k) ;; break + (wisent-SETBIT shiftset symbol))) + (setq i (1+ i)))) + + (setq i 0) + (while (< i ntokens) + (setq defaulted nil + count (if (wisent-BITISSET shiftset i) 1 0) + j m) + (while (< j n) + (when (wisent-BITISSET (aref LA j) i) + (if (zerop count) + (progn + (if (not (= j default-LA)) + (wisent-log + " %s\treduce using rule %d (%s)\n" + (wisent-tag i) (aref LAruleno j) + (wisent-tag (aref rlhs (aref LAruleno j)))) + (setq defaulted t)) + (setq count (1+ count))) + (if defaulted + (wisent-log + " %s\treduce using rule %d (%s)\n" + (wisent-tag i) (aref LAruleno default-LA) + (wisent-tag (aref rlhs (aref LAruleno default-LA))))) + (setq defaulted nil) + (wisent-log + " %s\t[reduce using rule %d (%s)]\n" + (wisent-tag i) (aref LAruleno j) + (wisent-tag (aref rlhs (aref LAruleno j)))))) + (setq j (1+ j))) + (setq i (1+ i))) + + (if (>= default-LA 0) + (wisent-log + " $default\treduce using rule %d (%s)\n" + default-rule + (wisent-tag (aref rlhs default-rule)))) + )))) + +(defun wisent-print-actions (state) + "Print actions on STATE." + (let (i j k v state1 symbol shiftp errp redp rule nerrs break) + (setq shiftp (aref shift-table state) + redp (aref reduction-table state) + errp (aref err-table state)) + (if (and (not shiftp) (not redp)) + (if (= final-state state) + (wisent-log " $default\taccept\n") + (wisent-log " NO ACTIONS\n")) + (if (not shiftp) + (setq i 0 + k 0) + (setq k (shifts-nshifts shiftp) + v (shifts-shifts shiftp) + i 0 + break nil) + (while (and (not break) (< i k)) + (if (zerop (setq state1 (aref v i))) + (setq i (1+ i)) + (setq symbol (aref accessing-symbol state1)) + ;; The following line used to be turned off. + (if (wisent-ISVAR symbol) + (setq break t) ;; break + (wisent-log " %s\tshift, and go to state %d\n" + (wisent-tag symbol) state1) + (setq i (1+ i))))) + (if (> i 0) + (wisent-log "\n"))) + + (when errp + (setq nerrs (errs-nerrs errp) + v (errs-errs errp) + j 0) + (while (< j nerrs) + (if (aref v j) + (wisent-log " %s\terror (nonassociative)\n" + (wisent-tag (aref v j)))) + (setq j (1+ j))) + (if (> j 0) + (wisent-log "\n"))) + + (cond + ((and (aref consistent state) redp) + (setq rule (aref (reductions-rules redp) 0) + symbol (aref rlhs rule)) + (wisent-log " $default\treduce using rule %d (%s)\n\n" + rule (wisent-tag symbol)) + ) + (redp + (wisent-print-reductions state) + )) + + (when (< i k) + (setq v (shifts-shifts shiftp)) + (while (< i k) + (when (setq state1 (aref v i)) + (setq symbol (aref accessing-symbol state1)) + (wisent-log " %s\tgo to state %d\n" + (wisent-tag symbol) state1)) + (setq i (1+ i))) + (wisent-log "\n")) + ))) + +(defun wisent-print-core (state) + "Print STATE core." + (let (i k rule statep sp sp1) + (setq statep (aref state-table state) + k (core-nitems statep)) + (when (> k 0) + (setq i 0) + (while (< i k) + ;; sp1 = sp = ritem + statep->items[i]; + (setq sp1 (aref (core-items statep) i) + sp sp1) + (while (> (aref ritem sp) 0) + (setq sp (1+ sp))) + + (setq rule (- (aref ritem sp))) + (wisent-log " %s -> " (wisent-tag (aref rlhs rule))) + + (setq sp (aref rrhs rule)) + (while (< sp sp1) + (wisent-log "%s " (wisent-tag (aref ritem sp))) + (setq sp (1+ sp))) + (wisent-log ".") + (while (> (aref ritem sp) 0) + (wisent-log " %s" (wisent-tag (aref ritem sp))) + (setq sp (1+ sp))) + (wisent-log " (rule %d)\n" rule) + (setq i (1+ i))) + (wisent-log "\n")))) + +(defun wisent-print-state (state) + "Print information on STATE." + (wisent-log "\n\nstate %d\n\n" state) + (wisent-print-core state) + (wisent-print-actions state)) + +(defun wisent-print-states () + "Print information on states." + (let ((i 0)) + (while (< i nstates) + (wisent-print-state i) + (setq i (1+ i))))) + +(defun wisent-print-results () + "Print information on generated parser. +Report detailed informations if `wisent-verbose-flag' or +`wisent-debug-flag' are non-nil." + (when (or wisent-verbose-flag wisent-debug-flag) + (wisent-print-useless)) + (wisent-print-conflicts) + (when (or wisent-verbose-flag wisent-debug-flag) + (wisent-print-grammar) + (wisent-print-states)) + ;; Append output to log file when running in batch mode + (when (wisent-noninteractive) + (wisent-append-to-log-file) + (wisent-clear-log))) + +;;;; --------------------------------- +;;;; Build the generated parser tables +;;;; --------------------------------- + +(defun wisent-action-row (state actrow) + "Figure out the actions for the specified STATE. +Decide what to do for each type of token if seen as the lookahead +token in specified state. The value returned is used as the default +action for the state. In addition, ACTROW is filled with what to do +for each kind of token, index by symbol number, with nil meaning do +the default action. The value 'error, means this situation is an +error. The parser recognizes this value specially. + +This is where conflicts are resolved. The loop over lookahead rules +considered lower-numbered rules last, and the last rule considered +that likes a token gets to handle it." + (let (i j k m n v default-rule nreds rule max count + shift-state symbol redp shiftp errp nodefault) + + (fillarray actrow nil) + + (setq default-rule 0 + nodefault nil ;; nil inhibit having any default reduction + nreds 0 + m 0 + n 0 + redp (aref reduction-table state)) + + (when redp + (setq nreds (reductions-nreds redp)) + (when (>= nreds 1) + ;; loop over all the rules available here which require + ;; lookahead + (setq m (aref lookaheads state) + n (aref lookaheads (1+ state)) + i (1- n)) + (while (>= i m) + ;; and find each token which the rule finds acceptable to + ;; come next + (setq j 0) + (while (< j ntokens) + ;; and record this rule as the rule to use if that token + ;; follows. + (if (wisent-BITISSET (aref LA i) j) + (aset actrow j (- (aref LAruleno i))) + ) + (setq j (1+ j))) + (setq i (1- i))))) + + ;; Now see which tokens are allowed for shifts in this state. For + ;; them, record the shift as the thing to do. So shift is + ;; preferred to reduce. + (setq shiftp (aref shift-table state)) + (when shiftp + (setq k (shifts-nshifts shiftp) + v (shifts-shifts shiftp) + i 0) + (while (< i k) + (setq shift-state (aref v i)) + (if (zerop shift-state) + nil ;; continue + (setq symbol (aref accessing-symbol shift-state)) + (if (wisent-ISVAR symbol) + (setq i k) ;; break + (aset actrow symbol shift-state) + ;; Do not use any default reduction if there is a shift + ;; for error + (if (= symbol error-token-number) + (setq nodefault t)))) + (setq i (1+ i)))) + + ;; See which tokens are an explicit error in this state (due to + ;; %nonassoc). For them, record error as the action. + (setq errp (aref err-table state)) + (when errp + (setq k (errs-nerrs errp) + v (errs-errs errp) + i 0) + (while (< i k) + (aset actrow (aref v i) wisent-error-tag) + (setq i (1+ i)))) + + ;; Now find the most common reduction and make it the default + ;; action for this state. + (when (and (>= nreds 1) (not nodefault)) + (if (aref consistent state) + (setq default-rule (- (aref (reductions-rules redp) 0))) + (setq max 0 + i m) + (while (< i n) + (setq count 0 + rule (- (aref LAruleno i)) + j 0) + (while (< j ntokens) + (if (and (numberp (aref actrow j)) + (= (aref actrow j) rule)) + (setq count (1+ count))) + (setq j (1+ j))) + (if (> count max) + (setq max count + default-rule rule)) + (setq i (1+ i))) + ;; actions which match the default are replaced with zero, + ;; which means "use the default" + (when (> max 0) + (setq j 0) + (while (< j ntokens) + (if (and (numberp (aref actrow j)) + (= (aref actrow j) default-rule)) + (aset actrow j nil)) + (setq j (1+ j))) + ))) + + ;; If have no default rule, if this is the final state the default + ;; is accept else it is an error. So replace any action which + ;; says "error" with "use default". + (when (zerop default-rule) + (if (= final-state state) + (setq default-rule wisent-accept-tag) + (setq j 0) + (while (< j ntokens) + (if (eq (aref actrow j) wisent-error-tag) + (aset actrow j nil)) + (setq j (1+ j))) + (setq default-rule wisent-error-tag))) + default-rule)) + +(defconst wisent-default-tag 'default + "Tag used in an action table to indicate a default action.") + +;; These variables only exist locally in the function +;; `wisent-state-actions' and are shared by all other nested callees. +(wisent-defcontext semantic-actions + ;; Uninterned symbols used in code generation. + stack sp gotos state + ;; Name of the current semantic action + NAME) + +(defun wisent-state-actions () + "Figure out the actions for every state. +Return the action table." + ;; Store the semantic action obarray in (unused) RCODE[0]. + (aset rcode 0 (make-vector 13 0)) + (let (i j action-table actrow action) + (setq action-table (make-vector nstates nil) + actrow (make-vector ntokens nil) + i 0) + (wisent-with-context semantic-actions + (setq stack (make-symbol "stack") + sp (make-symbol "sp") + gotos (make-symbol "gotos") + state (make-symbol "state")) + (while (< i nstates) + (setq action (wisent-action-row i actrow)) + ;; Translate a reduction into semantic action + (and (integerp action) (< action 0) + (setq action (wisent-semantic-action (- action)))) + (aset action-table i (list (cons wisent-default-tag action))) + (setq j 0) + (while (< j ntokens) + (when (setq action (aref actrow j)) + ;; Translate a reduction into semantic action + (and (integerp action) (< action 0) + (setq action (wisent-semantic-action (- action)))) + (aset action-table i (cons (cons (aref tags j) action) + (aref action-table i))) + ) + (setq j (1+ j))) + (aset action-table i (nreverse (aref action-table i))) + (setq i (1+ i))) + action-table))) + +(defun wisent-goto-actions () + "Figure out what to do after reducing with each rule. +Depending on the saved state from before the beginning of parsing the +data that matched this rule. Return the goto table." + (let (i j m n symbol state goto-table) + (setq goto-table (make-vector nstates nil) + i ntokens) + (while (< i nsyms) + (setq symbol (- i ntokens) + m (aref goto-map symbol) + n (aref goto-map (1+ symbol)) + j m) + (while (< j n) + (setq state (aref from-state j)) + (aset goto-table state + (cons (cons (aref tags i) (aref to-state j)) + (aref goto-table state))) + (setq j (1+ j))) + (setq i (1+ i))) + goto-table)) + +(defsubst wisent-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 wisent-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))) + +(defun wisent-check-$N (x m) + "Return non-nil if X is a valid $N or $regionN symbol. +That is if X is a $N or $regionN symbol with N >= 1 and N <= M. +Also warn if X is a $N or $regionN symbol with N < 1 or N > M." + (when (symbolp x) + (let* ((n (symbol-name x)) + (i (and (string-match "\\`\\$\\(region\\)?\\([0-9]+\\)\\'" n) + (string-to-number (match-string 2 n))))) + (when i + (if (and (>= i 1) (<= i m)) + t + (message + "*** In %s, %s might be a free variable (rule has %s)" + NAME x (format (cond ((< m 1) "no component") + ((= m 1) "%d component") + ("%d components")) + m)) + nil))))) + +(defun wisent-semantic-action-expand-body (body n &optional found) + "Parse BODY of semantic action. +N is the maximum number of $N variables that can be referenced in +BODY. Warn on references out of permitted range. +Optional argument FOUND is the accumulated list of '$N' references +encountered so far. +Return a cons (FOUND . XBODY), where FOUND is the list of $N +references found in BODY, and XBODY is BODY expression with +`backquote' forms expanded." + (if (not (listp body)) + ;; BODY is an atom, no expansion needed + (progn + (if (wisent-check-$N body n) + ;; Accumulate $i symbol + (add-to-list 'found body)) + (cons found body)) + ;; BODY is a list, expand inside it + (let (xbody sexpr) + ;; If backquote expand it first + (if (wisent-backquote-p (car body)) + (setq body (macroexpand body))) + (while body + (setq sexpr (car body) + body (cdr body)) + (cond + ;; Function call excepted quote expression + ((and (consp sexpr) + (not (wisent-quote-p (car sexpr)))) + (setq sexpr (wisent-semantic-action-expand-body sexpr n found) + found (car sexpr) + sexpr (cdr sexpr))) + ;; $i symbol + ((wisent-check-$N sexpr n) + ;; Accumulate $i symbol + (add-to-list 'found sexpr)) + ) + ;; Accumulate expanded forms + (setq xbody (nconc xbody (list sexpr)))) + (cons found xbody)))) + +(defun wisent-semantic-action (r) + "Set up the Elisp function for semantic action at rule R. +On entry RCODE[R] contains a vector [BODY N (NTERM I)] where BODY is the +body of the semantic action, N is the maximum number of values +available in the parser's stack, NTERM is the nonterminal the semantic +action belongs to, and I is the index of the semantic action inside +NTERM definition. Return the semantic action symbol. +The semantic action function accepts three arguments: + +- the state/value stack +- the top-of-stack index +- the goto table + +And returns the updated top-of-stack index." + (if (not (aref ruseful r)) + (aset rcode r nil) + (let* ((actn (aref rcode r)) + (n (aref actn 1)) ; nb of val avail. in stack + (NAME (apply 'format "%s:%d" (aref actn 2))) + (form (wisent-semantic-action-expand-body (aref actn 0) n)) + ($l (car form)) ; list of $vars used in body + (form (cdr form)) ; expanded form of body + (nt (aref rlhs r)) ; nonterminal item no. + (bl nil) ; `let*' binding list + $v i j) + + ;; Compute $N and $regionN bindings + (setq i n) + (while (> i 0) + (setq j (1+ (* 2 (- n i)))) + ;; Only bind $regionI if used in action + (setq $v (intern (format "$region%d" i))) + (if (memq $v $l) + (setq bl (cons `(,$v (cdr (aref ,stack (- ,sp ,j)))) bl))) + ;; Only bind $I if used in action + (setq $v (intern (format "$%d" i))) + (if (memq $v $l) + (setq bl (cons `(,$v (car (aref ,stack (- ,sp ,j)))) bl))) + (setq i (1- i))) + + ;; Compute J, the length of rule's RHS. It will give the + ;; current parser state at STACK[SP - 2*J], and where to push + ;; the new semantic value and the next state, respectively at: + ;; STACK[SP - 2*J + 1] and STACK[SP - 2*J + 2]. Generally N, + ;; the maximum number of values available in the stack, is equal + ;; to J. But, for mid-rule actions, N is the number of rule + ;; elements before the action and J is always 0 (empty rule). + (setq i (aref rrhs r) + j 0) + (while (> (aref ritem i) 0) + (setq j (1+ j) + i (1+ i))) + + ;; Create the semantic action symbol. + (setq actn (intern NAME (aref rcode 0))) + + ;; Store source code in function cell of the semantic action + ;; symbol. It will be byte-compiled at automaton's compilation + ;; time. Using a byte-compiled automaton can significantly + ;; speed up parsing! + (fset actn + `(lambda (,stack ,sp ,gotos) + (let* (,@bl + ($region + ,(cond + ((= n 1) + (if (assq '$region1 bl) + '$region1 + `(cdr (aref ,stack (1- ,sp))))) + ((> n 1) + `(wisent-production-bounds + ,stack (- ,sp ,(1- (* 2 n))) (1- ,sp))))) + ($action ,NAME) + ($nterm ',(aref tags nt)) + ,@(and (> j 0) `((,sp (- ,sp ,(* j 2))))) + (,state (cdr (assq $nterm + (aref ,gotos + (aref ,stack ,sp)))))) + (setq ,sp (+ ,sp 2)) + ;; push semantic value + (aset ,stack (1- ,sp) (cons ,form $region)) + ;; push next state + (aset ,stack ,sp ,state) + ;; return new top of stack + ,sp))) + + ;; Return the semantic action symbol + actn))) + +;;;; ---------------------------- +;;;; Build parser LALR automaton. +;;;; ---------------------------- + +(defun wisent-parser-automaton () + "Compute and return LALR(1) automaton from GRAMMAR. +GRAMMAR is in internal format. GRAM/ACTS are grammar rules +in internal format. STARTS defines the start symbols." + ;; Check for useless stuff + (wisent-reduce-grammar) + + (wisent-set-derives) + (wisent-set-nullable) + ;; convert to nondeterministic finite state machine. + (wisent-generate-states) + ;; make it deterministic. + (wisent-lalr) + ;; Find and record any conflicts: places where one token of + ;; lookahead is not enough to disambiguate the parsing. Also + ;; resolve s/r conflicts based on precedence declarations. + (wisent-resolve-conflicts) + (wisent-print-results) + + (vector (wisent-state-actions) ; action table + (wisent-goto-actions) ; goto table + start-table ; start symbols + (aref rcode 0) ; sem. action symbol obarray + ) + ) + +;;;; ------------------- +;;;; Parse input grammar +;;;; ------------------- + +(defconst wisent-reserved-symbols (list wisent-error-term) + "The list of reserved symbols. +Also all symbols starting with a character defined in +`wisent-reserved-capitals' are reserved for internal use.") + +(defconst wisent-reserved-capitals '(?\$ ?\@) + "The list of reserved capital letters. +All symbol starting with one of these letters are reserved for +internal use.") + +(defconst wisent-starts-nonterm '$STARTS + "Main start symbol. +It gives the rules for start symbols.") + +(defvar wisent-single-start-flag nil + "Non-nil means allows only one start symbol like in Bison. +That is don't add extra start rules to the grammar. This is +useful to compare the Wisent's generated automaton with the Bison's +one.") + +(defsubst wisent-ISVALID-VAR (x) + "Return non-nil if X is a character or an allowed symbol." + (and x (symbolp x) + (not (memq (aref (symbol-name x) 0) wisent-reserved-capitals)) + (not (memq x wisent-reserved-symbols)))) + +(defsubst wisent-ISVALID-TOKEN (x) + "Return non-nil if X is a character or an allowed symbol." + (or (wisent-char-p x) + (wisent-ISVALID-VAR x))) + +(defun wisent-push-token (symbol &optional nocheck) + "Push a new SYMBOL in the list of tokens. +Bypass checking if NOCHECK is non-nil." + ;; Check + (or nocheck (wisent-ISVALID-TOKEN symbol) + (error "Invalid terminal symbol: %S" symbol)) + (if (memq symbol token-list) + (message "*** duplicate terminal `%s' ignored" symbol) + ;; Set up properties + (wisent-set-prec symbol nil) + (wisent-set-assoc symbol nil) + (wisent-set-item-number symbol ntokens) + ;; Add + (setq ntokens (1+ ntokens) + token-list (cons symbol token-list)))) + +(defun wisent-push-var (symbol &optional nocheck) + "Push a new SYMBOL in the list of nonterminals. +Bypass checking if NOCHECK is non-nil." + ;; Check + (unless nocheck + (or (wisent-ISVALID-VAR symbol) + (error "Invalid nonterminal symbol: %S" symbol)) + (if (memq symbol var-list) + (error "Nonterminal `%s' already defined" symbol))) + ;; Set up properties + (wisent-set-item-number symbol nvars) + ;; Add + (setq nvars (1+ nvars) + var-list (cons symbol var-list))) + +(defun wisent-parse-nonterminals (defs) + "Parse nonterminal definitions in DEFS. +Fill in each element of the global arrays RPREC, RCODE, RUSEFUL with +respectively rule precedence level, semantic action code and +usefulness flag. Return a list of rules of the form (LHS . RHS) where +LHS and RHS are respectively the Left Hand Side and Right Hand Side of +the rule." + (setq rprec nil + rcode nil + nitems 0 + nrules 0) + (let (def nonterm rlist rule rules rhs rest item items + rhl plevel semact @n @count iactn) + (setq @count 0) + (while defs + (setq def (car defs) + defs (cdr defs) + nonterm (car def) + rlist (cdr def) + iactn 0) + (or (consp rlist) + (error "Invalid nonterminal definition syntax: %S" def)) + (while rlist + (setq rule (car rlist) + rlist (cdr rlist) + items (car rule) + rest (cdr rule) + rhl 0 + rhs nil) + + ;; Check & count items + (setq nitems (1+ nitems)) ;; LHS item + (while items + (setq item (car items) + items (cdr items) + nitems (1+ nitems)) ;; RHS items + (if (listp item) + ;; Mid-rule action + (progn + (setq @count (1+ @count) + @n (intern (format "@%d" @count))) + (wisent-push-var @n t) + ;; Push a new empty rule with the mid-rule action + (setq semact (vector item rhl (list nonterm iactn)) + iactn (1+ iactn) + plevel nil + rcode (cons semact rcode) + rprec (cons plevel rprec) + item @n ;; Replace action by @N nonterminal + rules (cons (list item) rules) + nitems (1+ nitems) + nrules (1+ nrules))) + ;; Check terminal or nonterminal symbol + (cond + ((or (memq item token-list) (memq item var-list))) + ;; Create new literal character token + ((wisent-char-p item) (wisent-push-token item t)) + ((error "Symbol `%s' is used, but is not defined as a token and has no rules" + item)))) + (setq rhl (1+ rhl) + rhs (cons item rhs))) + + ;; Check & collect rule precedence level + (setq plevel (when (vectorp (car rest)) + (setq item (car rest) + rest (cdr rest)) + (if (and (= (length item) 1) + (memq (aref item 0) token-list) + (wisent-prec (aref item 0))) + (wisent-item-number (aref item 0)) + (error "Invalid rule precedence level syntax: %S" item))) + rprec (cons plevel rprec)) + + ;; Check & collect semantic action body + (setq semact (vector + (if rest + (if (cdr rest) + (error "Invalid semantic action syntax: %S" rest) + (car rest)) + ;; Give a default semantic action body: nil + ;; for an empty rule or $1, the value of the + ;; first symbol in the rule, otherwise. + (if (> rhl 0) '$1 '())) + rhl + (list nonterm iactn)) + iactn (1+ iactn) + rcode (cons semact rcode)) + (setq rules (cons (cons nonterm (nreverse rhs)) rules) + nrules (1+ nrules)))) + + (setq ruseful (make-vector (1+ nrules) t) + rprec (vconcat (cons nil (nreverse rprec))) + rcode (vconcat (cons nil (nreverse rcode)))) + (nreverse rules) + )) + +(defun wisent-parse-grammar (grammar &optional start-list) + "Parse GRAMMAR and build a suitable internal representation. +Optional argument START-LIST defines the start symbols. +GRAMMAR is a list of form: (TOKENS ASSOCS . NONTERMS) + +TOKENS is a list of terminal symbols (tokens). + +ASSOCS is nil or an alist of (ASSOC-TYPE . ASSOC-VALUE) elements +describing the associativity of TOKENS. ASSOC-TYPE must be one of the +`default-prec' `nonassoc', `left' or `right' symbols. When ASSOC-TYPE +is `default-prec', ASSOC-VALUE must be nil or t (the default). +Otherwise it is a list of tokens which must have been previously +declared in TOKENS. + +NONTERMS is the list of non terminal definitions (see function +`wisent-parse-nonterminals')." + (or (and (consp grammar) (> (length grammar) 2)) + (error "Bad input grammar")) + + (let (i r rhs pre dpre lst start-var assoc rules item + token var def tokens defs ep-token ep-var ep-def) + + ;; Built-in tokens + (setq ntokens 0 nvars 0) + (wisent-push-token wisent-eoi-term t) + (wisent-push-token wisent-error-term t) + + ;; Check/collect terminals + (setq lst (car grammar)) + (while lst + (wisent-push-token (car lst)) + (setq lst (cdr lst))) + + ;; Check/Set up tokens precedence & associativity + (setq lst (nth 1 grammar) + pre 0 + defs nil + dpre nil + default-prec t) + (while lst + (setq def (car lst) + assoc (car def) + tokens (cdr def) + lst (cdr lst)) + (if (eq assoc 'default-prec) + (progn + (or (null (cdr tokens)) + (memq (car tokens) '(t nil)) + (error "Invalid default-prec value: %S" tokens)) + (setq default-prec (car tokens)) + (if dpre + (message "*** redefining default-prec to %s" + default-prec)) + (setq dpre t)) + (or (memq assoc '(left right nonassoc)) + (error "Invalid associativity syntax: %S" assoc)) + (setq pre (1+ pre)) + (while tokens + (setq token (car tokens) + tokens (cdr tokens)) + (if (memq token defs) + (message "*** redefining precedence of `%s'" token)) + (or (memq token token-list) + ;; Define token not previously declared. + (wisent-push-token token)) + (setq defs (cons token defs)) + ;; Record the precedence and associativity of the terminal. + (wisent-set-prec token pre) + (wisent-set-assoc token assoc)))) + + ;; Check/Collect nonterminals + (setq lst (nthcdr 2 grammar) + defs nil) + (while lst + (setq def (car lst) + lst (cdr lst)) + (or (consp def) + (error "Invalid nonterminal definition: %S" def)) + (if (memq (car def) token-list) + (error "Nonterminal `%s' already defined as token" (car def))) + (wisent-push-var (car def)) + (setq defs (cons def defs))) + (or defs + (error "No input grammar")) + (setq defs (nreverse defs)) + + ;; Set up the start symbol. + (setq start-table nil) + (cond + + ;; 1. START-LIST is nil, the start symbol is the first + ;; nonterminal defined in the grammar (Bison like). + ((null start-list) + (setq start-var (caar defs))) + + ;; 2. START-LIST contains only one element, it is the start + ;; symbol (Bison like). + ((or wisent-single-start-flag (null (cdr start-list))) + (setq start-var (car start-list)) + (or (assq start-var defs) + (error "Start symbol `%s' has no rule" start-var))) + + ;; 3. START-LIST contains more than one element. All defines + ;; potential start symbols. One of them (the first one by + ;; default) will be given at parse time to be the parser goal. + ;; If `wisent-single-start-flag' is non-nil that feature is + ;; disabled and the first nonterminal in START-LIST defines + ;; the start symbol, like in case 2 above. + ((not wisent-single-start-flag) + + ;; START-LIST is a list of nonterminals '(nt0 ... ntN). + ;; Build and push ad hoc start rules in the grammar: + + ;; ($STARTS ((nt0) $1) ((nt1) $1) ... ((ntN) $1)) + ;; ($nt1 (($$nt1 nt1) $2)) + ;; ... + ;; ($ntN (($$ntN ntN) $2)) + + ;; Where internal symbols $ntI and $$ntI are respectively + ;; nonterminals and terminals. + + ;; The internal start symbol $STARTS is used to build the + ;; LALR(1) automaton. The true default start symbol used by the + ;; parser is the first nonterminal in START-LIST (nt0). + (setq start-var wisent-starts-nonterm + lst (nreverse start-list)) + (while lst + (setq var (car lst) + lst (cdr lst)) + (or (memq var var-list) + (error "Start symbol `%s' has no rule" var)) + (unless (assq var start-table) ;; Ignore duplicates + ;; For each nt start symbol + (setq ep-var (intern (format "$%s" var)) + ep-token (intern (format "$$%s" var))) + (wisent-push-token ep-token t) + (wisent-push-var ep-var t) + (setq + ;; Add entry (nt . $$nt) to start-table + start-table (cons (cons var ep-token) start-table) + ;; Add rule ($nt (($$nt nt) $2)) + defs (cons (list ep-var (list (list ep-token var) '$2)) defs) + ;; Add start rule (($nt) $1) + ep-def (cons (list (list ep-var) '$1) ep-def)) + )) + (wisent-push-var start-var t) + (setq defs (cons (cons start-var ep-def) defs)))) + + ;; Set up rules main data structure & RPREC, RCODE, RUSEFUL + (setq rules (wisent-parse-nonterminals defs)) + + ;; Set up the terminal & nonterminal lists. + (setq nsyms (+ ntokens nvars) + token-list (nreverse token-list) + lst var-list + var-list nil) + (while lst + (setq var (car lst) + lst (cdr lst) + var-list (cons var var-list)) + (wisent-set-item-number ;; adjust nonterminal item number to + var (+ ntokens (wisent-item-number var)))) ;; I += NTOKENS + + ;; Store special item numbers + (setq error-token-number (wisent-item-number wisent-error-term) + start-symbol (wisent-item-number start-var)) + + ;; Keep symbols in the TAGS vector so that TAGS[I] is the symbol + ;; associated to item number I. + (setq tags (vconcat token-list var-list)) + ;; Set up RLHS RRHS & RITEM data structures from list of rules + ;; (LHS . RHS) received from `wisent-parse-nonterminals'. + (setq rlhs (make-vector (1+ nrules) nil) + rrhs (make-vector (1+ nrules) nil) + ritem (make-vector (1+ nitems) nil) + i 0 + r 1) + (while rules + (aset rlhs r (wisent-item-number (caar rules))) + (aset rrhs r i) + (setq rhs (cdar rules) + pre nil) + (while rhs + (setq item (wisent-item-number (car rhs))) + ;; Get default precedence level of rule, that is the + ;; precedence of the last terminal in it. + (and (wisent-ISTOKEN item) + default-prec + (setq pre item)) + + (aset ritem i item) + (setq i (1+ i) + rhs (cdr rhs))) + ;; Setup the precedence level of the rule, that is the one + ;; specified by %prec or the default one. + (and (not (aref rprec r)) ;; Already set by %prec + pre + (wisent-prec (aref tags pre)) + (aset rprec r pre)) + (aset ritem i (- r)) + (setq i (1+ i) + r (1+ r)) + (setq rules (cdr rules))) + )) + +;;;; --------------------- +;;;; Compile input grammar +;;;; --------------------- + +(defun wisent-compile-grammar (grammar &optional start-list) + "Compile the LALR(1) GRAMMAR. + +GRAMMAR is a list (TOKENS ASSOCS . NONTERMS) where: + +- TOKENS is a list of terminal symbols (tokens). + +- ASSOCS is nil, or an alist of (ASSOC-TYPE . ASSOC-VALUE) elements + describing the associativity of TOKENS. ASSOC-TYPE must be one of + the `default-prec' `nonassoc', `left' or `right' symbols. When + ASSOC-TYPE is `default-prec', ASSOC-VALUE must be nil or t (the + default). Otherwise it is a list of tokens which must have been + previously declared in TOKENS. + +- NONTERMS is a list of nonterminal definitions. + +Optional argument START-LIST specify the possible grammar start +symbols. This is a list of nonterminals which must have been +previously declared in GRAMMAR's NONTERMS form. By default, the start +symbol is the first nonterminal defined. When START-LIST contains +only one element, it is the start symbol. Otherwise, all elements are +possible start symbols, unless `wisent-single-start-flag' is non-nil. +In that case, the first element is the start symbol, and others are +ignored. + +Return an automaton as a vector: [ACTIONS GOTOS STARTS FUNCTIONS] +where: + +- ACTIONS is a state/token matrix telling the parser what to do at + every state based on the current lookahead token. That is shift, + reduce, accept or error. + +- GOTOS is a state/nonterminal matrix telling the parser the next + state to go to after reducing with each rule. + +- STARTS is an alist which maps the allowed start nonterminal symbols + to tokens that will be first shifted into the parser stack. + +- FUNCTIONS is an obarray of semantic action symbols. Each symbol's + function definition is the semantic action lambda expression." + (if (wisent-automaton-p grammar) + grammar ;; Grammar already compiled just return it + (wisent-with-context compile-grammar + (let* ((gc-cons-threshold 1000000) + automaton) + (garbage-collect) + (setq wisent-new-log-flag t) + ;; Parse input grammar + (wisent-parse-grammar grammar start-list) + ;; Generate the LALR(1) automaton + (setq automaton (wisent-parser-automaton)) + automaton)))) + +;;;; -------------------------- +;;;; Byte compile input grammar +;;;; -------------------------- + +(require 'bytecomp) + +(defun wisent-byte-compile-grammar (form) + "Byte compile the `wisent-compile-grammar' FORM. +Automatically called by the Emacs Lisp byte compiler as a +`byte-compile' handler." + ;; Eval the `wisent-compile-grammar' form to obtain an LALR + ;; automaton internal data structure. Then, because the internal + ;; data structure contains an obarray, convert it to a lisp form so + ;; it can be byte-compiled. + (byte-compile-form (wisent-automaton-lisp-form (eval form)))) + +(put 'wisent-compile-grammar 'byte-compile 'wisent-byte-compile-grammar) + +(defun wisent-automaton-lisp-form (automaton) + "Return a Lisp form that produces AUTOMATON. +See also `wisent-compile-grammar' for more details on AUTOMATON." + (or (wisent-automaton-p automaton) + (signal 'wrong-type-argument + (list 'wisent-automaton-p automaton))) + (let ((obn (make-symbol "ob")) ; Generated obarray name + (obv (aref automaton 3)) ; Semantic actions obarray + ) + `(let ((,obn (make-vector 13 0))) + ;; Generate code to initialize the semantic actions obarray, + ;; in local variable OBN. + ,@(let (obcode) + (mapatoms + #'(lambda (s) + (setq obcode + (cons `(fset (intern ,(symbol-name s) ,obn) + #',(symbol-function s)) + obcode))) + obv) + obcode) + ;; Generate code to create the automaton. + (vector + ;; In code generated to initialize the action table, take + ;; care of symbols that are interned in the semantic actions + ;; obarray. + (vector + ,@(mapcar + #'(lambda (state) ;; for each state + `(list + ,@(mapcar + #'(lambda (tr) ;; for each transition + (let ((k (car tr)) ; token + (a (cdr tr))) ; action + (if (and (symbolp a) + (intern-soft (symbol-name a) obv)) + `(cons ,(if (symbolp k) `(quote ,k) k) + (intern-soft ,(symbol-name a) ,obn)) + `(quote ,tr)))) + state))) + (aref automaton 0))) + ;; The code of the goto table is unchanged. + ,(aref automaton 1) + ;; The code of the alist of start symbols is unchanged. + ',(aref automaton 2) + ;; The semantic actions obarray is in the local variable OBN. + ,obn)))) + +(provide 'semantic/wisent/comp) + +;;; semantic/wisent/comp.el ends here diff --git a/lisp/cedet/semantic/wisent/java-tags.el b/lisp/cedet/semantic/wisent/java-tags.el new file mode 100644 index 00000000000..5a9d8c398b4 --- /dev/null +++ b/lisp/cedet/semantic/wisent/java-tags.el @@ -0,0 +1,122 @@ +;;; semantic/wisent/java-tags.el --- Java LALR parser for Emacs + +;;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009 +;;; Free Software Foundation, Inc. + +;; Author: David Ponce <david@dponce.com> +;; Maintainer: David Ponce <david@dponce.com> +;; Created: 15 Dec 2001 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; + +;;; History: +;; + +;;; Code: + +(require 'semantic/wisent) +(require 'semantic/wisent/javat-wy) +(require 'semantic/java) + +;;;; +;;;; Simple parser error reporting function +;;;; + +(defun wisent-java-parse-error (msg) + "Error reporting function called when a parse error occurs. +MSG is the message string to report." +;; (let ((error-start (nth 2 wisent-input))) +;; (if (number-or-marker-p error-start) +;; (goto-char error-start))) + (message msg) + ;;(debug) + ) + +;;;; +;;;; Local context +;;;; + +(define-mode-local-override semantic-get-local-variables + java-mode () + "Get local values from a specific context. +Parse the current context for `field_declaration' nonterminals to +collect tags, such as local variables or prototypes. +This function override `get-local-variables'." + (let ((vars nil) + ;; We want nothing to do with funny syntaxing while doing this. + (semantic-unmatched-syntax-hook nil)) + (while (not (semantic-up-context (point) 'function)) + (save-excursion + (forward-char 1) + (setq vars + (append (semantic-parse-region + (point) + (save-excursion (semantic-end-of-context) (point)) + 'field_declaration + 0 t) + vars)))) + vars)) + +;;;; +;;;; Semantic integration of the Java LALR parser +;;;; + +;;;###autoload +(defun wisent-java-default-setup () + "Hook run to setup Semantic in `java-mode'. +Use the alternate LALR(1) parser." + (wisent-java-tags-wy--install-parser) + (setq + ;; Lexical analysis + semantic-lex-number-expression semantic-java-number-regexp + semantic-lex-analyzer 'wisent-java-tags-lexer + ;; Parsing + semantic-tag-expand-function 'semantic-java-expand-tag + ;; Environment + semantic-imenu-summary-function 'semantic-format-tag-prototype + imenu-create-index-function 'semantic-create-imenu-index + semantic-type-relation-separator-character '(".") + semantic-command-separation-character ";" + ;; speedbar and imenu buckets name + semantic-symbol->name-assoc-list-for-type-parts + ;; in type parts + '((type . "Classes") + (variable . "Variables") + (function . "Methods")) + semantic-symbol->name-assoc-list + ;; everywhere + (append semantic-symbol->name-assoc-list-for-type-parts + '((include . "Imports") + (package . "Package"))) + ;; navigation inside 'type children + senator-step-at-tag-classes '(function variable) + ) + ;; Setup javadoc stuff + (semantic-java-doc-setup)) + +(provide 'semantic/wisent/java-tags) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/wisent/java-tags" +;; End: + +;;; semantic/wisent/java-tags.el ends here diff --git a/lisp/cedet/semantic/wisent/javascript.el b/lisp/cedet/semantic/wisent/javascript.el new file mode 100644 index 00000000000..892f76be4f0 --- /dev/null +++ b/lisp/cedet/semantic/wisent/javascript.el @@ -0,0 +1,103 @@ +;;; semantic/wisent/javascript.el --- javascript parser support + +;;; Copyright (C) 2005 Free Software Foundation, Inc. + +;; Author: Eric Ludlam <zappo@gnu.org> +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Parser support for javascript language. + + +;;; Code: +(require 'semantic/java) +(require 'semantic/wisent) +(require 'semantic/wisent/js-wy) + +(defun wisent-javascript-jv-expand-tag (tag) + "Expand TAG into a list of equivalent tags, or nil. +Expand multiple variable declarations in the same statement, that is +tags of class `variable' whose name is equal to a list of elements of +the form (NAME VALUE START . END). NAME is a variable name. VALUE is +an initializer START and END are the bounds in the declaration, related +to this variable NAME." + (let (elts elt value clone start end xpand) + (when (and (eq 'variable (semantic-tag-class tag)) + (consp (setq elts (semantic-tag-name tag)))) + ;; There are multiple names in the same variable declaration. + (while elts + ;; For each name element, clone the initial tag and give it + ;; the name of the element. + (setq elt (car elts) + elts (cdr elts) + clone (semantic-tag-clone tag (car elt)) + value (car (cdr elt)) + start (if elts (caddr elt) (semantic-tag-start tag)) + end (if xpand (cdddr elt) (semantic-tag-end tag)) + xpand (cons clone xpand)) + ;; Set the definition of the cloned tag + (semantic-tag-put-attribute clone :default-value value) + ;; Set the bounds of the cloned tag with those of the name + ;; element. + (semantic-tag-set-bounds clone start end)) + xpand))) + +;;; Override Methods +;; +;; These methods override aspects of how semantic-tools can access +;; the tags created by the javascript parser. +;; Local context +(define-mode-overload-implementation semantic-get-local-variables + javascript-mode () + "Get local values from a specific context. +This function overrides `get-local-variables'." + ;; Does javascript have identifiable local variables? + nil) + + +;;; Setup Function +;; +;; This sets up the javascript parser + +;;;###autoload +(defun wisent-javascript-setup-parser () + "Setup buffer for parse." + (wisent-javascript-jv-wy--install-parser) + (setq + ;; Lexical Analysis + semantic-lex-analyzer 'javascript-lexer-jv + semantic-lex-number-expression semantic-java-number-regexp + ;; semantic-lex-depth nil ;; Full lexical analysis + ;; Parsing + semantic-tag-expand-function 'wisent-javascript-jv-expand-tag + ;; Environment + semantic-imenu-summary-function 'semantic-format-tag-name + imenu-create-index-function 'semantic-create-imenu-index + semantic-command-separation-character ";" + )) + +(provide 'semantic/wisent/javascript-jv) + +;; Local variables: +;; generated-autoload-file: "../loaddefs.el" +;; generated-autoload-feature: semantic/loaddefs +;; generated-autoload-load-name: "semantic/wisent/javascript" +;; End: + +;;; semantic/wisent/javascript-jv.el ends here diff --git a/lisp/cedet/semantic/wisent/javat-wy.el b/lisp/cedet/semantic/wisent/javat-wy.el Binary files differnew file mode 100644 index 00000000000..0cbee2c086b --- /dev/null +++ b/lisp/cedet/semantic/wisent/javat-wy.el diff --git a/lisp/cedet/semantic/wisent/js-wy.el b/lisp/cedet/semantic/wisent/js-wy.el new file mode 100644 index 00000000000..8d25b726605 --- /dev/null +++ b/lisp/cedet/semantic/wisent/js-wy.el @@ -0,0 +1,491 @@ +;;; semantic/wisent/js-wy.el --- Generated parser support file + +;; Copyright (C) 2005 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This file was generated from the grammar file +;; semantic/wisent/wisent-javascript-jv.wy in the CEDET repository. + +;;; Code: +(require 'semantic/lex) + +;;; Prologue +;; + +;;; Declarations +;; +(defconst wisent-javascript-jv-wy--keyword-table + (semantic-lex-make-keyword-table + '(("if" . IF) + ("break" . BREAK) + ("continue" . CONTINUE) + ("else" . ELSE) + ("for" . FOR) + ("function" . FUNCTION) + ("this" . THIS) + ("return" . RETURN) + ("while" . WHILE) + ("void" . VOID_SYMBOL) + ("new" . NEW) + ("delete" . DELETE) + ("var" . VAR) + ("with" . WITH) + ("typeof" . TYPEOF) + ("in" . IN)) + '(("in" summary "in something") + ("typeof" summary "typeof ") + ("with" summary "with ") + ("var" summary "var <variablename> [= value];") + ("delete" summary "delete(<objectreference>) - Deletes the object.") + ("new" summary "new <objecttype> - Creates a new object.") + ("void" summary "Method return type: void <name> ...") + ("while" summary "while (<expr>) <stmt> | do <stmt> while (<expr>);") + ("return" summary "return [<expr>] ;") + ("this" summary "this") + ("function" summary "function declaration blah blah") + ("for" summary "for ([<init-expr>]; [<expr>]; [<update-expr>]) <stmt>") + ("else" summary "if (<expr>) <stmt> else <stmt>") + ("continue" summary "continue [<label>] ;") + ("break" summary "break [<label>] ;") + ("if" summary "if (<expr>) <stmt> [else <stmt>] (jv)"))) + "Table of language keywords.") + +(defconst wisent-javascript-jv-wy--token-table + (semantic-lex-make-type-table + '(("<no-type>" + (NULL_TOKEN) + (QUERY) + (TRUE) + (FALSE)) + ("number" + (NUMBER)) + ("string" + (STRING)) + ("symbol" + (VARIABLE)) + ("close-paren" + (CLOSE_SQ_BRACKETS . "]") + (END_BLOCK . "}") + (CLOSE_PARENTHESIS . ")")) + ("open-paren" + (OPEN_SQ_BRACKETS . "[") + (START_BLOCK . "{") + (OPEN_PARENTHESIS . "(")) + ("block" + (BRACK_BLOCK . "(OPEN_SQ_BRACKETS CLOSE_SQ_BRACKETS)") + (BRACE_BLOCK . "(START_BLOCK END_BLOCK)") + (PAREN_BLOCK . "(OPEN_PARENTHESIS CLOSE_PARENTHESIS)")) + ("punctuation" + (ONES_COMPLIMENT . "~") + (SEMICOLON . ";") + (LINE_TERMINATOR . "\n") + (LESS_THAN . "<") + (DOT . ".") + (COMMA . ",") + (COLON . ":") + (DIV . "/") + (DECREMENT . "--") + (INCREMENT . "++") + (PLUS_EQUALS . "+=") + (PLUS . "+") + (MULTIPLY_EQUALS . "*=") + (MULTIPLY . "*") + (MOD_EQUALS . "%=") + (MOD . "%") + (MINUS_EQUALS . "-=") + (MINUS . "-") + (LS_EQUAL . "<=") + (LOGICAL_NOT . "!!") + (LOGICAL_OR . "||") + (LOGICAL_AND . "&&") + (GT_EQUAL . ">=") + (GREATER_THAN . ">") + (EQUALS . "==") + (DIV_EQUALS . "/=") + (NOT_EQUAL . "!=") + (BITWISE_SHIFT_RIGHT_ZERO_FILL_EQUALS . ">>>=") + (BITWISE_SHIFT_RIGHT_ZERO_FILL . ">>>") + (BITWISE_SHIFT_RIGHT_EQUALS . ">>=") + (BITWISE_SHIFT_RIGHT . ">>") + (BITWISE_SHIFT_LEFT_EQUALS . "<<=") + (BITWISE_SHIFT_LEFT . "<<") + (BITWISE_OR_EQUALS . "|=") + (BITWISE_OR . "|") + (BITWISE_EXCLUSIVE_OR_EQUALS . "^=") + (BITWISE_EXCLUSIVE_OR . "^") + (BITWISE_AND_EQUALS . "&=") + (BITWISE_AND . "&") + (ASSIGN_SYMBOL . "="))) + '(("number" :declared t) + ("string" :declared t) + ("symbol" :declared t) + ("keyword" :declared t) + ("block" :declared t) + ("punctuation" :declared t))) + "Table of lexical tokens.") + +(defconst wisent-javascript-jv-wy--parse-table + (progn + (eval-when-compile + (require 'semantic/wisent/comp)) + (wisent-compile-grammar + '((ASSIGN_SYMBOL BITWISE_AND BITWISE_AND_EQUALS BITWISE_EXCLUSIVE_OR BITWISE_EXCLUSIVE_OR_EQUALS BITWISE_OR BITWISE_OR_EQUALS BITWISE_SHIFT_LEFT BITWISE_SHIFT_LEFT_EQUALS BITWISE_SHIFT_RIGHT BITWISE_SHIFT_RIGHT_EQUALS BITWISE_SHIFT_RIGHT_ZERO_FILL BITWISE_SHIFT_RIGHT_ZERO_FILL_EQUALS NOT_EQUAL DIV_EQUALS EQUALS GREATER_THAN GT_EQUAL LOGICAL_AND LOGICAL_OR LOGICAL_NOT LS_EQUAL MINUS MINUS_EQUALS MOD MOD_EQUALS MULTIPLY MULTIPLY_EQUALS PLUS PLUS_EQUALS INCREMENT DECREMENT DIV COLON COMMA DOT LESS_THAN LINE_TERMINATOR SEMICOLON ONES_COMPLIMENT PAREN_BLOCK BRACE_BLOCK BRACK_BLOCK OPEN_PARENTHESIS CLOSE_PARENTHESIS START_BLOCK END_BLOCK OPEN_SQ_BRACKETS CLOSE_SQ_BRACKETS IF BREAK CONTINUE ELSE FOR FUNCTION THIS RETURN WHILE VOID_SYMBOL NEW DELETE VAR WITH TYPEOF IN VARIABLE STRING NUMBER FALSE TRUE QUERY NULL_TOKEN) + ((left PLUS MINUS) + (left MULTIPLY DIV MOD) + (nonassoc FALSE) + (nonassoc HIGHER_THAN_FALSE) + (nonassoc ELSE) + (nonassoc LOWER_THAN_CLOSE_PARENTHESIS) + (nonassoc CLOSE_PARENTHESIS)) + (Program + ((SourceElement))) + (SourceElement + ((Statement)) + ((FunctionDeclaration))) + (Statement + ((Block)) + ((VariableStatement)) + ((EmptyStatement)) + ((ExpressionStatement)) + ((IfStatement)) + ((IterationExpression)) + ((ContinueStatement)) + ((BreakStatement)) + ((ReturnStatement)) + ((WithStatement))) + (FunctionDeclaration + ((FUNCTION VARIABLE FormalParameterListBlock Block) + (wisent-raw-tag + (semantic-tag-new-function $2 nil $3)))) + (FormalParameterListBlock + ((PAREN_BLOCK) + (semantic-parse-region + (car $region1) + (cdr $region1) + 'FormalParameterList 1))) + (FormalParameterList + ((OPEN_PARENTHESIS) + nil) + ((VARIABLE) + (wisent-raw-tag + (semantic-tag-new-variable $1 nil nil))) + ((CLOSE_PARENTHESIS) + nil) + ((COMMA) + nil)) + (StatementList + ((Statement)) + ((StatementList Statement))) + (Block + ((BRACE_BLOCK))) + (BlockExpand + ((START_BLOCK StatementList END_BLOCK)) + ((START_BLOCK END_BLOCK))) + (VariableStatement + ((VAR VariableDeclarationList SEMICOLON) + (wisent-raw-tag + (semantic-tag-new-variable $2 nil nil)))) + (VariableDeclarationList + ((VariableDeclaration) + (list $1)) + ((VariableDeclarationList COMMA VariableDeclaration) + (append $1 + (list $3)))) + (VariableDeclaration + ((VARIABLE) + (append + (list $1 nil) + $region)) + ((VARIABLE Initializer) + (append + (cons $1 $2) + $region))) + (Initializer + ((ASSIGN_SYMBOL AssignmentExpression) + (list $2))) + (EmptyStatement + ((SEMICOLON))) + (ExpressionStatement + ((Expression SEMICOLON))) + (IfStatement + ((IF OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement) + [HIGHER_THAN_FALSE]) + ((IF OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement ELSE Statement)) + ((IF OPEN_PARENTHESIS FALSE CLOSE_PARENTHESIS Statement)) + ((IF OPEN_PARENTHESIS LeftHandSideExpression AssignmentOperator AssignmentExpression CLOSE_PARENTHESIS Statement))) + (IterationExpression + ((WHILE OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement) + [HIGHER_THAN_FALSE]) + ((WHILE OPEN_PARENTHESIS FALSE CLOSE_PARENTHESIS Statement)) + ((WHILE OPEN_PARENTHESIS LeftHandSideExpression AssignmentOperator AssignmentExpression CLOSE_PARENTHESIS Statement)) + ((FOR OPEN_PARENTHESIS OptionalExpression SEMICOLON OptionalExpression SEMICOLON OptionalExpression CLOSE_PARENTHESIS Statement)) + ((FOR OPEN_PARENTHESIS VAR VariableDeclarationList SEMICOLON OptionalExpression SEMICOLON OptionalExpression CLOSE_PARENTHESIS Statement)) + ((FOR OPEN_PARENTHESIS LeftHandSideExpression IN Expression CLOSE_PARENTHESIS Statement)) + ((FOR OPEN_PARENTHESIS VAR VARIABLE OptionalInitializer IN Expression CLOSE_PARENTHESIS Statement))) + (ContinueStatement + ((CONTINUE SEMICOLON))) + (BreakStatement + ((BREAK SEMICOLON))) + (ReturnStatement + ((RETURN Expression SEMICOLON)) + ((RETURN SEMICOLON))) + (WithStatement + ((WITH OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS Statement))) + (OptionalInitializer + ((Initializer)) + (nil)) + (PrimaryExpression + ((THIS)) + ((VARIABLE)) + ((NUMBER)) + ((STRING)) + ((NULL_TOKEN)) + ((TRUE)) + ((FALSE)) + ((OPEN_PARENTHESIS Expression CLOSE_PARENTHESIS))) + (MemberExpression + ((PrimaryExpression)) + ((MemberExpression OPEN_SQ_BRACKETS Expression CLOSE_SQ_BRACKETS)) + ((MemberExpression DOT VARIABLE)) + ((NEW MemberExpression Arguments))) + (NewExpression + ((MemberExpression)) + ((NEW NewExpression))) + (CallExpression + ((MemberExpression Arguments)) + ((CallExpression Arguments)) + ((CallExpression OPEN_SQ_BRACKETS Expression CLOSE_SQ_BRACKETS)) + ((CallExpression DOT VARIABLE))) + (Arguments + ((OPEN_PARENTHESIS CLOSE_PARENTHESIS)) + ((OPEN_PARENTHESIS ArgumentList CLOSE_PARENTHESIS))) + (ArgumentList + ((AssignmentExpression)) + ((ArgumentList COMMA AssignmentExpression))) + (LeftHandSideExpression + ((NewExpression)) + ((CallExpression))) + (PostfixExpression + ((LeftHandSideExpression)) + ((LeftHandSideExpression INCREMENT)) + ((LeftHandSideExpression DECREMENT))) + (UnaryExpression + ((PostfixExpression)) + ((DELETE UnaryExpression)) + ((VOID_SYMBOL UnaryExpression)) + ((TYPEOF UnaryExpression)) + ((INCREMENT UnaryExpression)) + ((DECREMENT UnaryExpression)) + ((PLUS UnaryExpression)) + ((MINUS UnaryExpression)) + ((ONES_COMPLIMENT UnaryExpression)) + ((LOGICAL_NOT UnaryExpression))) + (MultiplicativeExpression + ((UnaryExpression)) + ((MultiplicativeExpression MULTIPLY UnaryExpression)) + ((MultiplicativeExpression DIV UnaryExpression)) + ((MultiplicativeExpression MOD UnaryExpression))) + (AdditiveExpression + ((MultiplicativeExpression)) + ((AdditiveExpression PLUS MultiplicativeExpression)) + ((AdditiveExpression MINUS MultiplicativeExpression))) + (ShiftExpression + ((AdditiveExpression)) + ((ShiftExpression BITWISE_SHIFT_LEFT AdditiveExpression)) + ((ShiftExpression BITWISE_SHIFT_RIGHT AdditiveExpression)) + ((ShiftExpression BITWISE_SHIFT_RIGHT_ZERO_FILL AdditiveExpression))) + (RelationalExpression + ((ShiftExpression)) + ((RelationalExpression LESS_THAN ShiftExpression)) + ((RelationalExpression GREATER_THAN ShiftExpression)) + ((RelationalExpression LS_EQUAL ShiftExpression)) + ((RelationalExpression GT_EQUAL ShiftExpression))) + (EqualityExpression + ((RelationalExpression)) + ((EqualityExpression EQUALS RelationalExpression)) + ((EqualityExpression NOT_EQUAL RelationalExpression))) + (BitwiseANDExpression + ((EqualityExpression)) + ((BitwiseANDExpression BITWISE_AND EqualityExpression))) + (BitwiseXORExpression + ((BitwiseANDExpression)) + ((BitwiseXORExpression BITWISE_EXCLUSIVE_OR BitwiseANDExpression))) + (BitwiseORExpression + ((BitwiseXORExpression)) + ((BitwiseORExpression BITWISE_OR BitwiseXORExpression))) + (LogicalANDExpression + ((BitwiseORExpression)) + ((LogicalANDExpression LOGICAL_AND BitwiseORExpression))) + (LogicalORExpression + ((LogicalANDExpression)) + ((LogicalORExpression LOGICAL_OR LogicalANDExpression))) + (ConditionalExpression + ((LogicalORExpression)) + ((LogicalORExpression QUERY AssignmentExpression COLON AssignmentExpression))) + (AssignmentExpression + ((ConditionalExpression)) + ((LeftHandSideExpression AssignmentOperator AssignmentExpression) + [LOWER_THAN_CLOSE_PARENTHESIS])) + (AssignmentOperator + ((ASSIGN_SYMBOL)) + ((MULTIPLY_EQUALS)) + ((DIV_EQUALS)) + ((MOD_EQUALS)) + ((PLUS_EQUALS)) + ((MINUS_EQUALS)) + ((BITWISE_SHIFT_LEFT_EQUALS)) + ((BITWISE_SHIFT_RIGHT_EQUALS)) + ((BITWISE_SHIFT_RIGHT_ZERO_FILL_EQUALS)) + ((BITWISE_AND_EQUALS)) + ((BITWISE_EXCLUSIVE_OR_EQUALS)) + ((BITWISE_OR_EQUALS))) + (Expression + ((AssignmentExpression)) + ((Expression COMMA AssignmentExpression))) + (OptionalExpression + ((Expression)) + (nil))) + '(Program FormalParameterList))) + "Parser table.") + +(defun wisent-javascript-jv-wy--install-parser () + "Setup the Semantic Parser." + (semantic-install-function-overrides + '((parse-stream . wisent-parse-stream))) + (setq semantic-parser-name "LALR" + semantic--parse-table wisent-javascript-jv-wy--parse-table + semantic-debug-parser-source "wisent-javascript-jv.wy" + semantic-flex-keywords-obarray wisent-javascript-jv-wy--keyword-table + semantic-lex-types-obarray wisent-javascript-jv-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-keyword-type-analyzer wisent-javascript-jv-wy--<keyword>-keyword-analyzer + "keyword analyzer for <keyword> tokens." + "\\(\\sw\\|\\s_\\)+") + +(define-lex-block-type-analyzer wisent-javascript-jv-wy--<block>-block-analyzer + "block analyzer for <block> tokens." + "\\s(\\|\\s)" + '((("(" OPEN_PARENTHESIS PAREN_BLOCK) + ("{" START_BLOCK BRACE_BLOCK) + ("[" OPEN_SQ_BRACKETS BRACK_BLOCK)) + (")" CLOSE_PARENTHESIS) + ("}" END_BLOCK) + ("]" CLOSE_SQ_BRACKETS)) + ) + +(define-lex-regex-type-analyzer wisent-javascript-jv-wy--<symbol>-regexp-analyzer + "regexp analyzer for <symbol> tokens." + "\\(\\sw\\|\\s_\\)+" + nil + 'VARIABLE) + +(define-lex-sexp-type-analyzer wisent-javascript-jv-wy--<string>-sexp-analyzer + "sexp analyzer for <string> tokens." + "\\s\"" + 'STRING) + +(define-lex-regex-type-analyzer wisent-javascript-jv-wy--<number>-regexp-analyzer + "regexp analyzer for <number> tokens." + semantic-lex-number-expression + nil + 'NUMBER) + +(define-lex-string-type-analyzer wisent-javascript-jv-wy--<punctuation>-string-analyzer + "string analyzer for <punctuation> tokens." + "\\(\\s.\\|\\s$\\|\\s'\\)+" + '((ONES_COMPLIMENT . "~") + (SEMICOLON . ";") + (LINE_TERMINATOR . "\n") + (LESS_THAN . "<") + (DOT . ".") + (COMMA . ",") + (COLON . ":") + (DIV . "/") + (DECREMENT . "--") + (INCREMENT . "++") + (PLUS_EQUALS . "+=") + (PLUS . "+") + (MULTIPLY_EQUALS . "*=") + (MULTIPLY . "*") + (MOD_EQUALS . "%=") + (MOD . "%") + (MINUS_EQUALS . "-=") + (MINUS . "-") + (LS_EQUAL . "<=") + (LOGICAL_NOT . "!!") + (LOGICAL_OR . "||") + (LOGICAL_AND . "&&") + (GT_EQUAL . ">=") + (GREATER_THAN . ">") + (EQUALS . "==") + (DIV_EQUALS . "/=") + (NOT_EQUAL . "!=") + (BITWISE_SHIFT_RIGHT_ZERO_FILL_EQUALS . ">>>=") + (BITWISE_SHIFT_RIGHT_ZERO_FILL . ">>>") + (BITWISE_SHIFT_RIGHT_EQUALS . ">>=") + (BITWISE_SHIFT_RIGHT . ">>") + (BITWISE_SHIFT_LEFT_EQUALS . "<<=") + (BITWISE_SHIFT_LEFT . "<<") + (BITWISE_OR_EQUALS . "|=") + (BITWISE_OR . "|") + (BITWISE_EXCLUSIVE_OR_EQUALS . "^=") + (BITWISE_EXCLUSIVE_OR . "^") + (BITWISE_AND_EQUALS . "&=") + (BITWISE_AND . "&") + (ASSIGN_SYMBOL . "=")) + 'punctuation) + + +;;; Epilogue +;; +;;here something like: +;;(define-lex wisent-java-tags-lexer +;; should go +(define-lex javascript-lexer-jv +"javascript thingy" +;;std stuff + semantic-lex-ignore-whitespace + semantic-lex-ignore-newline + semantic-lex-ignore-comments + + ;;stuff generated from the wy file(one for each "type" declaration) + wisent-javascript-jv-wy--<number>-regexp-analyzer + wisent-javascript-jv-wy--<string>-sexp-analyzer + + wisent-javascript-jv-wy--<keyword>-keyword-analyzer + + wisent-javascript-jv-wy--<symbol>-regexp-analyzer + wisent-javascript-jv-wy--<punctuation>-string-analyzer + wisent-javascript-jv-wy--<block>-block-analyzer + + + ;;;;more std stuff + semantic-lex-default-action + ) + +(provide 'semantic/wisent/js-wy) + +;;; semantic/wisent/js-wy.el ends here diff --git a/lisp/cedet/semantic/wisent/wisent.el b/lisp/cedet/semantic/wisent/wisent.el new file mode 100644 index 00000000000..e3614d8b591 --- /dev/null +++ b/lisp/cedet/semantic/wisent/wisent.el @@ -0,0 +1,479 @@ +;;; semantic/wisent/wisent.el --- GNU Bison for Emacs - Runtime + +;;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2009 +;;; Free Software Foundation, Inc. + +;; Author: David Ponce <david@dponce.com> +;; Maintainer: David Ponce <david@dponce.com> +;; Created: 30 January 2002 +;; Keywords: syntax + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Parser engine and runtime of Wisent. +;; +;; Wisent (the European Bison ;-) is an Elisp implementation of the +;; GNU Compiler Compiler Bison. The Elisp code is a port of the C +;; code of GNU Bison 1.28 & 1.31. +;; +;; For more details on the basic concepts for understanding Wisent, +;; read the Bison manual ;) +;; +;; For more details on Wisent itself read the Wisent manual. + +;;; History: +;; + +;;; Code: + +(defgroup wisent nil + " + /\\_.-^^^-._/\\ The GNU + \\_ _/ + ( `o ` (European ;-) Bison + \\ ` / + ( D ,¨ for Emacs! + ` ~ ,¨ + `\"\"" + :group 'semantic) + + +;;;; ------------- +;;;; Runtime stuff +;;;; ------------- + +;;; Compatibility +(eval-and-compile + (if (fboundp 'char-valid-p) + (defalias 'wisent-char-p 'char-valid-p) + (defalias 'wisent-char-p 'char-or-char-int-p))) + +;;; Printed representation of terminals and nonterminals +(defconst wisent-escape-sequence-strings + '( + (?\a . "'\\a'") ; C-g + (?\b . "'\\b'") ; backspace, BS, C-h + (?\t . "'\\t'") ; tab, TAB, C-i + (?\n . "'\\n'") ; newline, C-j + (?\v . "'\\v'") ; vertical tab, C-k + (?\f . "'\\f'") ; formfeed character, C-l + (?\r . "'\\r'") ; carriage return, RET, C-m + (?\e . "'\\e'") ; escape character, ESC, C-[ + (?\\ . "'\\'") ; backslash character, \ + (?\d . "'\\d'") ; delete character, DEL + ) + "Printed representation of usual escape sequences.") + +(defsubst wisent-item-to-string (item) + "Return a printed representation of ITEM. +ITEM can be a nonterminal or terminal symbol, or a character literal." + (if (wisent-char-p item) + (or (cdr (assq item wisent-escape-sequence-strings)) + (format "'%c'" item)) + (symbol-name item))) + +(defsubst wisent-token-to-string (token) + "Return a printed representation of lexical token TOKEN." + (format "%s%s(%S)" (wisent-item-to-string (car token)) + (if (nth 2 token) (format "@%s" (nth 2 token)) "") + (nth 1 token))) + +;;; Special symbols +(defconst wisent-eoi-term '$EOI + "End Of Input token.") + +(defconst wisent-error-term 'error + "Error recovery token.") + +(defconst wisent-accept-tag 'accept + "Accept result after input successfully parsed.") + +(defconst wisent-error-tag 'error + "Process a syntax error.") + +;;; Special functions +(defun wisent-automaton-p (obj) + "Return non-nil if OBJ is a LALR automaton. +If OBJ is a symbol check its value." + (and obj (symbolp obj) (boundp obj) + (setq obj (symbol-value obj))) + (and (vectorp obj) (= 4 (length obj)) + (vectorp (aref obj 0)) (vectorp (aref obj 1)) + (= (length (aref obj 0)) (length (aref obj 1))) + (listp (aref obj 2)) (vectorp (aref obj 3)))) + +(defsubst wisent-region (&rest positions) + "Return the start/end positions of the region including POSITIONS. +Each element of POSITIONS is a pair (START-POS . END-POS) or nil. The +returned value is the pair (MIN-START-POS . MAX-END-POS) or nil if no +POSITIONS are available." + (let ((pl (delq nil positions))) + (if pl + (cons (apply #'min (mapcar #'car pl)) + (apply #'max (mapcar #'cdr pl)))))) + +;;; Reporting +(defvar wisent-parse-verbose-flag nil + "*Non-nil means to issue more messages while parsing.") + +(defun wisent-parse-toggle-verbose-flag () + "Toggle whether to issue more messages while parsing." + (interactive) + (setq wisent-parse-verbose-flag (not wisent-parse-verbose-flag)) + (when (interactive-p) + (message "More messages while parsing %sabled" + (if wisent-parse-verbose-flag "en" "dis")))) + +(defsubst wisent-message (string &rest args) + "Print a one-line message if `wisent-parse-verbose-flag' is set. +Pass STRING and ARGS arguments to `message'." + (and wisent-parse-verbose-flag + (apply 'message string args))) + +;;;; -------------------- +;;;; The LR parser engine +;;;; -------------------- + +(defcustom wisent-parse-max-stack-size 500 + "The parser stack size." + :type 'integer + :group 'wisent) + +(defcustom wisent-parse-max-recover 3 + "Number of tokens to shift before turning off error status." + :type 'integer + :group 'wisent) + +(defvar wisent-discarding-token-functions nil + "List of functions to be called when discarding a lexical token. +These functions receive the lexical token discarded. +When the parser encounters unexpected tokens, it can discards them, +based on what directed by error recovery rules. Either when the +parser reads tokens until one is found that can be shifted, or when an +semantic action calls the function `wisent-skip-token' or +`wisent-skip-block'. +For language specific hooks, make sure you define this as a local +hook.") + +(defvar wisent-pre-parse-hook nil + "Normal hook run just before entering the LR parser engine.") + +(defvar wisent-post-parse-hook nil + "Normal hook run just after the LR parser engine terminated.") + +(defvar wisent-loop nil + "The current parser action. +Stop parsing when set to nil. +This variable only has meaning in the scope of `wisent-parse'.") + +(defvar wisent-nerrs nil + "The number of parse errors encountered so far.") + +(defvar wisent-lookahead nil + "The lookahead lexical token. +This value is non-nil if the parser terminated because of an +unrecoverable error.") + +;; Variables and macros that are useful in semantic actions. +(defvar wisent-parse-lexer-function nil + "The user supplied lexer function. +This function don't have arguments. +This variable only has meaning in the scope of `wisent-parse'.") + +(defvar wisent-parse-error-function nil + "The user supplied error function. +This function must accept one argument, a message string. +This variable only has meaning in the scope of `wisent-parse'.") + +(defvar wisent-input nil + "The last token read. +This variable only has meaning in the scope of `wisent-parse'.") + +(defvar wisent-recovering nil + "Non-nil means that the parser is recovering. +This variable only has meaning in the scope of `wisent-parse'.") + +;; Variables that only have meaning in the scope of a semantic action. +;; These global definitions avoid byte-compiler warnings. +(defvar $region nil) +(defvar $nterm nil) +(defvar $action nil) + +(defmacro wisent-lexer () + "Obtain the next terminal in input." + '(funcall wisent-parse-lexer-function)) + +(defmacro wisent-error (msg) + "Call the user supplied error reporting function with message MSG." + `(funcall wisent-parse-error-function ,msg)) + +(defmacro wisent-errok () + "Resume generating error messages immediately for subsequent syntax errors. +This is useful primarily in error recovery semantic actions." + '(setq wisent-recovering nil)) + +(defmacro wisent-clearin () + "Discard the current lookahead token. +This will cause a new lexical token to be read. +This is useful primarily in error recovery semantic actions." + '(setq wisent-input nil)) + +(defmacro wisent-abort () + "Abort parsing and save the lookahead token. +This is useful primarily in error recovery semantic actions." + '(setq wisent-lookahead wisent-input + wisent-loop nil)) + +(defmacro wisent-set-region (start end) + "Change the region of text matched by the current nonterminal. +START and END are respectively the beginning and end positions of the +region. If START or END values are not a valid positions the region +is set to nil." + `(setq $region (and (number-or-marker-p ,start) + (number-or-marker-p ,end) + (cons ,start ,end)))) + +(defun wisent-skip-token () + "Skip the lookahead token in order to resume parsing. +Return nil. +Must be used in error recovery semantic actions." + (if (eq (car wisent-input) wisent-eoi-term) + ;; Does nothing at EOI to avoid infinite recovery loop. + nil + (wisent-message "%s: skip %s" $action + (wisent-token-to-string wisent-input)) + (run-hook-with-args + 'wisent-discarding-token-functions wisent-input) + (wisent-clearin) + (wisent-errok))) + +(defun wisent-skip-block (&optional bounds) + "Safely skip a parenthesized block in order to resume parsing. +Return nil. +Must be used in error recovery semantic actions. +Optional argument BOUNDS is a pair (START . END) which indicates where +the parenthesized block starts. Typically the value of a `$regionN' +variable, where `N' is the the Nth element of the current rule +components that match the block beginning. It defaults to the value +of the `$region' variable." + (let ((start (car (or bounds $region))) + end input) + (if (not (number-or-marker-p start)) + ;; No nonterminal region available, skip the lookahead token. + (wisent-skip-token) + ;; Try to skip a block. + (if (not (setq end (save-excursion + (goto-char start) + (and (looking-at "\\s(") + (condition-case nil + (1- (scan-lists (point) 1 0)) + (error nil)))))) + ;; Not actually a block, skip the lookahead token. + (wisent-skip-token) + ;; OK to safely skip the block, so read input until a matching + ;; close paren or EOI is encountered. + (setq input wisent-input) + (while (and (not (eq (car input) wisent-eoi-term)) + (< (nth 2 input) end)) + (run-hook-with-args + 'wisent-discarding-token-functions input) + (setq input (wisent-lexer))) + (wisent-message "%s: in enclosing block, skip from %s to %s" + $action + (wisent-token-to-string wisent-input) + (wisent-token-to-string input)) + (if (eq (car wisent-input) wisent-eoi-term) + ;; Does nothing at EOI to avoid infinite recovery loop. + nil + (wisent-clearin) + (wisent-errok)) + ;; Set end of $region to end of block. + (wisent-set-region (car $region) (1+ end)) + nil)))) + +;;; Core parser engine +(defsubst wisent-production-bounds (stack i j) + "Determine the start and end locations of a production value. +Return a pair (START . END), where START is the first available start +location, and END the last available end location, in components +values of the rule currently reduced. +Return nil when no component location is available. +STACK is the parser stack. +I and J are the indices in STACK of respectively the value of the +first and last components of the current rule. +This function is for internal use by semantic actions' generated +lambda-expression." + (let ((f (cadr (aref stack i))) + (l (cddr (aref stack j)))) + (while (/= i j) + (cond + ((not f) (setq f (cadr (aref stack (setq i (+ i 2)))))) + ((not l) (setq l (cddr (aref stack (setq j (- j 2)))))) + ((setq i j)))) + (and f l (cons f l)))) + +(defmacro wisent-parse-action (i al) + "Return the next parser action. +I is a token item number and AL is the list of (item . action) +available at current state. The first element of AL contains the +default action for this state." + `(cdr (or (assq ,i ,al) (car ,al)))) + +(defsubst wisent-parse-start (start starts) + "Return the first lexical token to shift for START symbol. +STARTS is the table of allowed start symbols or nil if the LALR +automaton has only one entry point." + (if (null starts) + ;; Only one entry point, return the first lexical token + ;; available in input. + (wisent-lexer) + ;; Multiple start symbols defined, return the internal lexical + ;; token associated to START. By default START is the first + ;; nonterminal defined in STARTS. + (let ((token (cdr (if start (assq start starts) (car starts))))) + (if token + (list token (symbol-name token)) + (error "Invalid start symbol %s" start))))) + +(defun wisent-parse (automaton lexer &optional error start) + "Parse input using the automaton specified in AUTOMATON. + +- AUTOMATON is an LALR(1) automaton generated by + `wisent-compile-grammar'. + +- LEXER is a function with no argument called by the parser to obtain + the next terminal (token) in input. + +- ERROR is an optional reporting function called when a parse error + occurs. It receives a message string to report. It defaults to the + function `wisent-message'. + +- START specify the start symbol (nonterminal) used by the parser as + its goal. It defaults to the start symbol defined in the grammar + \(see also `wisent-compile-grammar')." + (run-hooks 'wisent-pre-parse-hook) + (let* ((actions (aref automaton 0)) + (gotos (aref automaton 1)) + (starts (aref automaton 2)) + (stack (make-vector wisent-parse-max-stack-size nil)) + (sp 0) + (wisent-loop t) + (wisent-parse-error-function (or error 'wisent-message)) + (wisent-parse-lexer-function lexer) + (wisent-recovering nil) + (wisent-input (wisent-parse-start start starts)) + state tokid choices choice) + (setq wisent-nerrs 0 ;; Reset parse error counter + wisent-lookahead nil) ;; and lookahead token + (aset stack 0 0) ;; Initial state + (while wisent-loop + (setq state (aref stack sp) + tokid (car wisent-input) + wisent-loop (wisent-parse-action tokid (aref actions state))) + (cond + + ;; Input successfully parsed + ;; ------------------------- + ((eq wisent-loop wisent-accept-tag) + (setq wisent-loop nil)) + + ;; Syntax error in input + ;; --------------------- + ((eq wisent-loop wisent-error-tag) + ;; Report this error if not already recovering from an error. + (setq choices (aref actions state)) + (or wisent-recovering + (wisent-error + (format "Syntax error, unexpected %s, expecting %s" + (wisent-token-to-string wisent-input) + (mapconcat 'wisent-item-to-string + (delq wisent-error-term + (mapcar 'car (cdr choices))) + ", ")))) + ;; Increment the error counter + (setq wisent-nerrs (1+ wisent-nerrs)) + ;; If just tried and failed to reuse lookahead token after an + ;; error, discard it. + (if (eq wisent-recovering wisent-parse-max-recover) + (if (eq tokid wisent-eoi-term) + (wisent-abort) ;; Terminate if at end of input. + (wisent-message "Error recovery: skip %s" + (wisent-token-to-string wisent-input)) + (run-hook-with-args + 'wisent-discarding-token-functions wisent-input) + (setq wisent-input (wisent-lexer))) + + ;; Else will try to reuse lookahead token after shifting the + ;; error token. + + ;; Each real token shifted decrements this. + (setq wisent-recovering wisent-parse-max-recover) + ;; Pop the value/state stack to see if an action associated + ;; to special terminal symbol 'error exists. + (while (and (>= sp 0) + (not (and (setq state (aref stack sp) + choices (aref actions state) + choice (assq wisent-error-term choices)) + (natnump (cdr choice))))) + (setq sp (- sp 2))) + + (if (not choice) + ;; No 'error terminal was found. Just terminate. + (wisent-abort) + ;; Try to recover and continue parsing. + ;; Shift the error terminal. + (setq state (cdr choice) ; new state + sp (+ sp 2)) + (aset stack (1- sp) nil) ; push value + (aset stack sp state) ; push new state + ;; Adjust input to error recovery state. Unless 'error + ;; triggers a reduction, eat the input stream until an + ;; expected terminal symbol is found, or EOI is reached. + (if (cdr (setq choices (aref actions state))) + (while (not (or (eq (car wisent-input) wisent-eoi-term) + (assq (car wisent-input) choices))) + (wisent-message "Error recovery: skip %s" + (wisent-token-to-string wisent-input)) + (run-hook-with-args + 'wisent-discarding-token-functions wisent-input) + (setq wisent-input (wisent-lexer))))))) + + ;; Shift current token on top of the stack + ;; --------------------------------------- + ((natnump wisent-loop) + ;; Count tokens shifted since error; after + ;; `wisent-parse-max-recover', turn off error status. + (setq wisent-recovering (and (natnump wisent-recovering) + (> wisent-recovering 1) + (1- wisent-recovering))) + (setq sp (+ sp 2)) + (aset stack (1- sp) (cdr wisent-input)) + (aset stack sp wisent-loop) + (setq wisent-input (wisent-lexer))) + + ;; Reduce by rule (call semantic action) + ;; ------------------------------------- + (t + (setq sp (funcall wisent-loop stack sp gotos)) + (or wisent-input (setq wisent-input (wisent-lexer)))))) + (run-hooks 'wisent-post-parse-hook) + (car (aref stack 1)))) + +(provide 'semantic/wisent/wisent) + +;;; semantic/wisent/wisent.el ends here diff --git a/lisp/cedet/srecode.el b/lisp/cedet/srecode.el new file mode 100644 index 00000000000..bb87865cc90 --- /dev/null +++ b/lisp/cedet/srecode.el @@ -0,0 +1,53 @@ +;;; srecode.el --- Semantic buffer evaluator. + +;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: codegeneration + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic does the job of converting source code into useful tag +;; information. The set of `semantic-format-tag' functions has one +;; function that will create a prototype of a tag, which has severe +;; issues of complexity (in the format tag file itself) and inaccuracy +;; (for the purpose of C++ code.) +;; +;; Contemplation of the simplistic problem within the scope of +;; semantic showed that the solution was more complex than could +;; possibly be handled in semantic-format.el. Semantic Recode, or +;; srecode is a rich API for generating code out of semantic tags, or +;; recoding the tags. +;; +;; See the srecode manual for specific details. + +(require 'eieio) +(require 'mode-local) +(require 'srecode/loaddefs) + +(defvar srecode-version "1.0pre7" + "Current version of the Semantic Recoder.") + +;;; Code: +(defgroup srecode nil + "Semantic Recoder." + :group 'tools) + +(provide 'srecode) + +;;; srecode.el ends here diff --git a/lisp/cedet/srecode/args.el b/lisp/cedet/srecode/args.el new file mode 100644 index 00000000000..0d45831e9fc --- /dev/null +++ b/lisp/cedet/srecode/args.el @@ -0,0 +1,188 @@ +;;; srecode/args.el --- Provide some simple template arguments + +;;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Srecode templates can accept arguments. These arguments represent +;; sets of dictionary words that need to be derived. This file contains +;; a set of simple arguments for srecode templates. + +(require 'srecode/insert) + +;;; Code: + +;;; :blank +;; +;; Using :blank means that the template should force blank lines +;; before and after the template, reguardless of where the insertion +;; is occuring. +(defun srecode-semantic-handle-:blank (dict) + "Add macros into the dictionary DICT specifying blank line spacing. +The wrapgap means make sure the first and last lines of the macro +do not contain any text from preceeding or following text." + ;; This won't actually get used, but it might be nice + ;; to know about it. + (srecode-dictionary-set-value dict "BLANK" t) + ) + +;;; :indent ARGUMENT HANDLING +;; +;; When a :indent argument is required, the default is to indent +;; for the current major mode. +(defun srecode-semantic-handle-:indent (dict) + "Add macros into the dictionary DICT for indentation." + (srecode-dictionary-set-value dict "INDENT" t) + ) + +;;; :region ARGUMENT HANDLING +;; +;; When a :region argument is required, provide macros that +;; deal with that active region. +;; +;; Regions allow a macro to wrap the region text within the +;; template bounds. +;; +(defvar srecode-handle-region-when-non-active-flag nil + "Non-nil means do region handling w/out the region being active.") + +(defun srecode-semantic-handle-:region (dict) + "Add macros into the dictionary DICT based on the current :region." + ;; Only enable the region section if we can clearly show that + ;; the user is intending to do something with the region. + (when (or srecode-handle-region-when-non-active-flag + (eq last-command 'mouse-drag-region) + (and transient-mark-mode mark-active)) + ;; Show the region section + (srecode-dictionary-show-section dict "REGION") + (srecode-dictionary-set-value + dict "REGIONTEXT" (buffer-substring-no-properties (point) (mark))) + ;; Only whack the region if our template output + ;; is also destined for the current buffer. + (when (eq standard-output (current-buffer)) + (kill-region (point) (mark)))) + ) + +;;; :user ARGUMENT HANDLING +;; +;; When a :user argument is required, fill the dictionary with +;; information about the current Emacs user. +(defun srecode-semantic-handle-:user (dict) + "Add macros into the dictionary DICT based on the current :user." + (srecode-dictionary-set-value dict "AUTHOR" (user-full-name)) + (srecode-dictionary-set-value dict "LOGIN" (user-login-name)) + (srecode-dictionary-set-value dict "EMAIL" user-mail-address) + (srecode-dictionary-set-value dict "EMACSINITFILE" user-init-file) + (srecode-dictionary-set-value dict "UID" (user-uid)) + ) + +;;; :time ARGUMENT HANDLING +;; +;; When a :time argument is required, fill the dictionary with +;; information about the current Emacs time. +(defun srecode-semantic-handle-:time (dict) + "Add macros into the dictionary DICT based on the current :time." + ;; DATE Values + (srecode-dictionary-set-value + dict "YEAR" (format-time-string "%Y" (current-time))) + (srecode-dictionary-set-value + dict "MONTHNAME" (format-time-string "%B" (current-time))) + (srecode-dictionary-set-value + dict "MONTH" (format-time-string "%m" (current-time))) + (srecode-dictionary-set-value + dict "DAY" (format-time-string "%d" (current-time))) + (srecode-dictionary-set-value + dict "WEEKDAY" (format-time-string "%a" (current-time))) + ;; Time Values + (srecode-dictionary-set-value + dict "HOUR" (format-time-string "%H" (current-time))) + (srecode-dictionary-set-value + dict "HOUR12" (format-time-string "%l" (current-time))) + (srecode-dictionary-set-value + dict "AMPM" (format-time-string "%p" (current-time))) + (srecode-dictionary-set-value + dict "MINUTE" (format-time-string "%M" (current-time))) + (srecode-dictionary-set-value + dict "SECOND" (format-time-string "%S" (current-time))) + (srecode-dictionary-set-value + dict "TIMEZONE" (format-time-string "%Z" (current-time))) + ;; Convenience pre-packed date/time + (srecode-dictionary-set-value + dict "DATE" (format-time-string "%D" (current-time))) + (srecode-dictionary-set-value + dict "TIME" (format-time-string "%X" (current-time))) + ) + +;;; :file ARGUMENT HANDLING +;; +;; When a :file argument is required, fill the dictionary with +;; information about the file Emacs is editing at the time of +;; insertion. +(defun srecode-semantic-handle-:file (dict) + "Add macros into the dictionary DICT based on the current :file." + (let* ((bfn (buffer-file-name)) + (file (file-name-nondirectory bfn)) + (dir (file-name-directory bfn))) + (srecode-dictionary-set-value dict "FILENAME" file) + (srecode-dictionary-set-value dict "FILE" (file-name-sans-extension file)) + (srecode-dictionary-set-value dict "EXTENSION" (file-name-extension file)) + (srecode-dictionary-set-value dict "DIRECTORY" dir) + (srecode-dictionary-set-value dict "MODE" (symbol-name major-mode)) + (srecode-dictionary-set-value + dict "SHORTMODE" + (let* ((mode-name (symbol-name major-mode)) + (match (string-match "-mode" mode-name))) + (if match + (substring mode-name 0 match) + mode-name))) + (if (or (file-exists-p "CVS") + (file-exists-p "RCS")) + (srecode-dictionary-show-section dict "RCS") + ))) + +;;; :system ARGUMENT HANDLING +;; +;; When a :system argument is required, fill the dictionary with +;; information about the computer Emacs is running on. +(defun srecode-semantic-handle-:system (dict) + "Add macros into the dictionary DICT based on the current :system." + (srecode-dictionary-set-value dict "SYSTEMCONF" system-configuration) + (srecode-dictionary-set-value dict "SYSTEMTYPE" system-type) + (srecode-dictionary-set-value dict "SYSTEMNAME" (system-name)) + (srecode-dictionary-set-value dict "MAILHOST" (or mail-host-address + (system-name))) + ) + +;;; :kill ARGUMENT HANDLING +;; +;; When a :kill argument is required, fill the dictionary with +;; information about the current kill ring. +(defun srecode-semantic-handle-:kill (dict) + "Add macros into the dictionary DICT based on the kill ring." + (srecode-dictionary-set-value dict "KILL" (car kill-ring)) + (srecode-dictionary-set-value dict "KILL2" (nth 1 kill-ring)) + (srecode-dictionary-set-value dict "KILL3" (nth 2 kill-ring)) + (srecode-dictionary-set-value dict "KILL4" (nth 3 kill-ring)) + ) + +(provide 'srecode/args) + +;;; srecode/args.el ends here + diff --git a/lisp/cedet/srecode/compile.el b/lisp/cedet/srecode/compile.el new file mode 100644 index 00000000000..5b3d8fb50fc --- /dev/null +++ b/lisp/cedet/srecode/compile.el @@ -0,0 +1,641 @@ +;;; srecode/compile --- Compilation of srecode template files. + +;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: codegeneration + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Compile a Semantic Recoder template file. +;; +;; Template files are parsed using a Semantic/Wisent parser into +;; a tag table. The code therin is then further parsed down using +;; a regular expression parser. +;; +;; The output are a series of EIEIO objects which represent the +;; templates in a way that could be inserted later. + +(require 'semantic) +(require 'eieio) +(require 'eieio-base) +(require 'srecode) +(require 'srecode/table) + +(declare-function srecode-template-inserter-newline-child-p "srecode/insert") +(declare-function srecode-create-section-dictionary "srecode/dictionary") +(declare-function srecode-dictionary-compound-variable "srecode/dictionary") + +;;; Code: + +;;; Template Class +;; +;; Templatets describe a patter of text that can be inserted into a +;; buffer. +;; +(defclass srecode-template (eieio-named) + ((context :initarg :context + :initform nil + :documentation + "Context this template belongs to.") + (args :initarg :args + :documentation + "List of arguments that this template requires.") + (code :initarg :code + :documentation + "Compiled text from the template.") + (dictionary :initarg :dictionary + :type (or null srecode-dictionary) + :documentation + "List of section dictinaries. +The compiled template can contain lists of section dictionaries, +or values that are expected to be passed down into different +section macros. The template section dictionaries are merged in with +any incomming dictionaries values.") + (binding :initarg :binding + :documentation + "Preferred keybinding for this template in `srecode-minor-mode-map'.") + (active :allocation :class + :initform nil + :documentation + "During template insertion, this is the stack of active templates. +The top-most template is the 'active' template. Use the accessor methods +for push, pop, and peek for the active template.") + (table :initarg :table + :documentation + "The table this template lives in.") + ) + "Class defines storage for semantic recoder templates.") + +(defun srecode-flush-active-templates () + "Flush the active template storage. +Useful if something goes wrong in SRecode, and the active tempalte +stack is broken." + (interactive) + (if (oref srecode-template active) + (when (y-or-n-p (format "%d active templates. Flush? " + (length (oref srecode-template active)))) + (oset-default srecode-template active nil)) + (message "No active templates to flush.")) + ) + +;;; Inserters +;; +;; Each inserter object manages a different thing that +;; might be inserted into a template output stream. +;; +;; The 'srecode-insert-method' on each inserter does the actual +;; work, and the smaller, simple inserter object is saved in +;; the compiled templates. +;; +;; See srecode-insert.el for the specialized classes. +;; +(defclass srecode-template-inserter (eieio-named) + ((secondname :initarg :secondname + :type (or null string) + :documentation + "If there is a colon in the inserter's name, it represents +additional static argument data.")) + "This represents an item to be inserted via a template macro. +Plain text strings are not handled via this baseclass." + :abstract t) + +(defmethod srecode-parse-input ((ins srecode-template-inserter) + tag input STATE) + "For the template inserter INS, parse INPUT. +Shorten input only by the amount needed. +Return the remains of INPUT. +STATE is the current compilation state." + input) + +(defmethod srecode-match-end ((ins srecode-template-inserter) name) + "For the template inserter INS, do I end a section called NAME?" + nil) + +(defmethod srecode-inserter-apply-state ((ins srecode-template-inserter) STATE) + "For the template inserter INS, apply information from STATE." + nil) + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (when (and (slot-exists-p ins 'key) (oref ins key)) + (princ (format "%c" (oref ins key)))) + (princ "VARNAME") + (princ escape-end) + (terpri) + ) + + +;;; Compile State +(defclass srecode-compile-state () + ((context :initform "declaration" + :documentation "The active context.") + (prompts :initform nil + :documentation "The active prompts.") + (escape_start :initform "{{" + :documentation "The starting escape sequence.") + (escape_end :initform "}}" + :documentation "The ending escape sequence.") + ) + "Current state of the compile.") + +(defmethod srecode-compile-add-prompt ((state srecode-compile-state) + prompttag) + "Add PROMPTTAG to the current list of prompts." + (with-slots (prompts) state + (let ((match (assoc (semantic-tag-name prompttag) prompts)) + (newprompts prompts)) + (when match + (let ((tmp prompts)) + (setq newprompts nil) + (while tmp + (when (not (string= (car (car tmp)) + (car prompttag))) + (setq newprompts (cons (car tmp) + newprompts))) + (setq tmp (cdr tmp))))) + (setq prompts (cons prompttag newprompts))) + )) + +;;; TEMPLATE COMPILER +;; +(defun srecode-compile-file (fname) + "Compile the templates from the file FNAME." + (let ((peb (get-file-buffer fname))) + (save-excursion + ;; Make whatever it is local. + (if (not peb) + (set-buffer (semantic-find-file-noselect fname)) + (set-buffer peb)) + ;; Do the compile. + (srecode-compile-templates) + ;; Trash the buffer if we had to read it in. + (if (not peb) + (kill-buffer (current-buffer))) + ))) + +;;;###autoload +(defun srecode-compile-templates () + "Compile a semantic recode template file into a mode-local variable." + (interactive) + (require 'srecode/insert) + (message "Compiling template %s..." + (file-name-nondirectory (buffer-file-name))) + (let ((tags (semantic-fetch-tags)) + (tag nil) + (class nil) + (table nil) + (STATE (srecode-compile-state (file-name-nondirectory + (buffer-file-name)))) + (mode nil) + (application nil) + (priority nil) + (vars nil) + ) + + ;; + ;; COMPILE + ;; + (while tags + (setq tag (car tags) + class (semantic-tag-class tag)) + ;; What type of item is it? + (cond + ;; CONTEXT tags specify the context all future tags + ;; belong to. + ((eq class 'context) + (oset STATE context (semantic-tag-name tag)) + ) + + ;; PROMPT tags specify prompts for dictionary ? inserters + ;; which appear in the following templates + ((eq class 'prompt) + (srecode-compile-add-prompt STATE tag) + ) + + ;; VARIABLE tags can specify operational control + ((eq class 'variable) + (let* ((name (semantic-tag-name tag)) + (value (semantic-tag-variable-default tag)) + (firstvalue (car value))) + ;; If it is a single string, and one value, then + ;; look to see if it is one of our special variables. + (if (and (= (length value) 1) (stringp firstvalue)) + (cond ((string= name "mode") + (setq mode (intern firstvalue))) + ((string= name "escape_start") + (oset STATE escape_start firstvalue) + ) + ((string= name "escape_end") + (oset STATE escape_end firstvalue) + ) + ((string= name "application") + (setq application (read firstvalue))) + ((string= name "priority") + (setq priority (read firstvalue))) + (t + ;; Assign this into some table of variables. + (setq vars (cons (cons name firstvalue) vars)) + )) + ;; If it isn't a single string, then the value of the + ;; variable belongs to a compound dictionary value. + ;; + ;; Create a compound dictionary value from "value". + (require 'srecode/dictionary) + (let ((cv (srecode-dictionary-compound-variable + name :value value))) + (setq vars (cons (cons name cv) vars))) + )) + ) + + ;; FUNCTION tags are really templates. + ((eq class 'function) + (setq table (cons (srecode-compile-one-template-tag tag STATE) + table)) + ) + + ;; Ooops + (t (error "Unknown TAG class %s" class)) + ) + ;; Continue + (setq tags (cdr tags))) + + ;; MSG - Before install since nreverse whacks our list. + (message "%d templates compiled for %s" + (length table) mode) + + ;; + ;; APPLY TO MODE + ;; + (if (not mode) + (error "You must specify a MODE for your templates")) + + ;; + ;; Calculate priority + ;; + (if (not priority) + (let ((d (file-name-directory (buffer-file-name))) + (sd (file-name-directory (locate-library "srecode"))) + (defaultdelta (if (eq mode 'default) 20 0))) + (if (string= d sd) + (setq priority (+ 80 defaultdelta)) + (setq priority (+ 30 defaultdelta))) + (message "Templates %s has estimated priority of %d" + (file-name-nondirectory (buffer-file-name)) + priority)) + (message "Compiling templates %s priority %d... done!" + (file-name-nondirectory (buffer-file-name)) + priority)) + + ;; Save it up! + (srecode-compile-template-table table mode priority application vars) + ) +) + +(defun srecode-compile-one-template-tag (tag STATE) + "Compile a template tag TAG into an srecode template class. +STATE is the current compile state as an object `srecode-compile-state'." + (require 'srecode/dictionary) + (let* ((context (oref STATE context)) + (codeout (srecode-compile-split-code + tag (semantic-tag-get-attribute tag :code) + STATE)) + (code (cdr codeout)) + (args (semantic-tag-function-arguments tag)) + (binding (semantic-tag-get-attribute tag :binding)) + (rawdicts (semantic-tag-get-attribute tag :dictionaries)) + (sdicts (srecode-create-section-dictionary rawdicts STATE)) + (addargs nil) + ) +; (message "Compiled %s to %d codes with %d args and %d prompts." +; (semantic-tag-name tag) +; (length code) +; (length args) +; (length prompts)) + (while args + (setq addargs (cons (intern (car args)) addargs)) + (when (eq (car addargs) :blank) + ;; If we have a wrap, then put wrap inserters on both + ;; ends of the code. + (setq code (append + (list (srecode-compile-inserter "BLANK" + "\r" + STATE + :secondname nil + :where 'begin)) + code + (list (srecode-compile-inserter "BLANK" + "\r" + STATE + :secondname nil + :where 'end)) + ))) + (setq args (cdr args))) + (srecode-template (semantic-tag-name tag) + :context context + :args (nreverse addargs) + :dictionary sdicts + :binding binding + :code code) + )) + +(defun srecode-compile-do-hard-newline-p (comp) + "Examine COMP to decide if the upcoming newline should be hard. +It is hard if the previous inserter is a newline object." + (while (and comp (stringp (car comp))) + (setq comp (cdr comp))) + (or (not comp) + (require 'srecode/insert) + (srecode-template-inserter-newline-child-p (car comp)))) + +(defun srecode-compile-split-code (tag str STATE + &optional end-name) + "Split the code for TAG into something templatable. +STR is the string of code from TAG to split. +STATE is the current compile state. +ESCAPE_START and ESCAPE_END are regexps that indicate the beginning +escape character, and end escape character pattern for expandable +macro names. +Optional argument END-NAME specifies the name of a token upon which +parsing should stop. +If END-NAME is specified, and the input string" + (let* ((what str) + (end-token nil) + (comp nil) + (regex (concat "\n\\|" (regexp-quote (oref STATE escape_start)))) + (regexend (regexp-quote (oref STATE escape_end))) + ) + (while (and what (not end-token)) + (cond + ((string-match regex what) + (let* ((prefix (substring what 0 (match-beginning 0))) + (match (substring what + (match-beginning 0) + (match-end 0))) + (namestart (match-end 0)) + (junk (string-match regexend what namestart)) + end tail name key) + ;; Add string to compiled output + (when (> (length prefix) 0) + (setq comp (cons prefix comp))) + (if (string= match "\n") + ;; Do newline thingy. + (let ((new-inserter + (srecode-compile-inserter + "INDENT" + "\n" + STATE + :secondname nil + ;; This newline is "hard" meaning ALWAYS do it + ;; if the previous entry is also a newline. + ;; Without it, user entered blank lines will be + ;; ignored. + :hard (srecode-compile-do-hard-newline-p comp) + ))) + ;; Trim WHAT back. + (setq what (substring what namestart)) + (when (> (length what) 0) + ;; make the new inserter, but only if we aren't last. + (setq comp (cons new-inserter comp)) + )) + ;; Regular inserter thingy. + (setq end (if junk + (match-beginning 0) + (error "Could not find end escape for %s" + (semantic-tag-name tag))) + tail (match-end 0)) + (cond ((not end) + (error "No matching escape end for %s" + (semantic-tag-name tag))) + ((<= end namestart) + (error "Stray end escape for %s" + (semantic-tag-name tag))) + ) + ;; Add string to compiled output + (setq name (substring what namestart end) + key nil) + ;; Trim WHAT back. + (setq what (substring what tail)) + ;; Get the inserter + (let ((new-inserter + (srecode-compile-parse-inserter name STATE)) + ) + ;; If this is an end inserter, then assign into + ;; the end-token. + (if (srecode-match-end new-inserter end-name) + (setq end-token new-inserter)) + ;; Add the inserter to our compilation stream. + (setq comp (cons new-inserter comp)) + ;; Allow the inserter an opportunity to modify + ;; the input stream. + (setq what (srecode-parse-input new-inserter tag what + STATE)) + ) + ))) + (t + (if end-name + (error "Unmatched section end %s" end-name)) + (setq comp (cons what comp) + what nil)))) + (cons what (nreverse comp)))) + +(defun srecode-compile-parse-inserter (txt STATE) + "Parse the inserter TXT with the current STATE. +Return an inserter object." + (let ((key (aref txt 0)) + name + ) + (if (and (or (< key ?A) (> key ?Z)) + (or (< key ?a) (> key ?z)) ) + (setq name (substring txt 1)) + (setq name txt + key nil)) + (let* ((junk (string-match ":" name)) + (namepart (if junk + (substring name 0 (match-beginning 0)) + name)) + (secondname (if junk + (substring name (match-end 0)) + nil)) + (new-inserter (srecode-compile-inserter + namepart key STATE + :secondname secondname + ))) + ;; Return the new inserter + new-inserter))) + +(defun srecode-compile-inserter (name key STATE &rest props) + "Create an srecode inserter object for some macro NAME. +KEY indicates a single character key representing a type +of inserter to create. +STATE is the current compile state. +PROPS are additional properties that might need to be passed +to the inserter constructor." + ;;(message "Compile: %s %S" name props) + (if (not key) + (apply 'srecode-template-inserter-variable name props) + (let ((classes (class-children srecode-template-inserter)) + (new nil)) + ;; Loop over the various subclasses and + ;; create the correct inserter. + (while (and (not new) classes) + (setq classes (append classes (class-children (car classes)))) + ;; Do we have a match? + (when (and (not (class-abstract-p (car classes))) + (equal (oref (car classes) key) key)) + ;; Create the new class, and apply state. + (setq new (apply (car classes) name props)) + (srecode-inserter-apply-state new STATE) + ) + (setq classes (cdr classes))) + (if (not new) (error "SRECODE: Unknown macro code %S" key)) + new))) + +(defun srecode-compile-template-table (templates mode priority application vars) + "Compile a list of TEMPLATES into an semantic recode table. +The table being compiled is for MODE, or the string \"default\". +PRIORITY is a numerical value that indicates this tables location +in an ordered search. +APPLICATION is the name of the application these templates belong to. +A list of defined variables VARS provides a variable table." + (let ((namehash (make-hash-table :test 'equal + :size (length templates))) + (contexthash (make-hash-table :test 'equal :size 10)) + (lp templates) + ) + + (while lp + + (let* ((objname (oref (car lp) :object-name)) + (context (oref (car lp) :context)) + (globalname (concat context ":" objname)) + ) + + ;; Place this template object into the global name hash. + (puthash globalname (car lp) namehash) + + ;; Place this template into the specific context name hash. + (let ((hs (gethash context contexthash))) + ;; Make a new context if none was available. + (when (not hs) + (setq hs (make-hash-table :test 'equal :size 20)) + (puthash context hs contexthash)) + ;; Put into that contenxt's hash. + (puthash objname (car lp) hs) + ) + + (setq lp (cdr lp)))) + + (let* ((table (srecode-mode-table-new mode (buffer-file-name) + :templates (nreverse templates) + :namehash namehash + :contexthash contexthash + :variables vars + :major-mode mode + :priority priority + :application application)) + (tmpl (oref table templates))) + ;; Loop over all the templates, and xref. + (while tmpl + (oset (car tmpl) :table table) + (setq tmpl (cdr tmpl)))) + )) + + + +;;; DEBUG +;; +;; Dump out information about the current srecoder compiled templates. +;; + +(defmethod srecode-dump ((tmp srecode-template)) + "Dump the contents of the SRecode template tmp." + (princ "== Template \"") + (princ (object-name-string tmp)) + (princ "\" in context ") + (princ (oref tmp context)) + (princ "\n") + (when (oref tmp args) + (princ " Arguments: ") + (prin1 (oref tmp args)) + (princ "\n")) + (when (oref tmp dictionary) + (princ " Section Dictionaries:\n") + (srecode-dump (oref tmp dictionary) 4) + ;(princ "\n") + ) + (when (and (slot-boundp tmp 'binding) (oref tmp binding)) + (princ " Binding: ") + (prin1 (oref tmp binding)) + (princ "\n")) + (princ " Compiled Codes:\n") + (srecode-dump-code-list (oref tmp code) " ") + (princ "\n\n") + ) + +(defun srecode-dump-code-list (code indent) + "Dump the CODE from a template code list to standard output. +Argument INDENT specifies the indentation level for the list." + (let ((i 1)) + (while code + (princ indent) + (prin1 i) + (princ ") ") + (cond ((stringp (car code)) + (prin1 (car code))) + ((srecode-template-inserter-child-p (car code)) + (srecode-dump (car code) indent)) + (t + (princ "Unknown Code: ") + (prin1 (car code)))) + (setq code (cdr code) + i (1+ i)) + (when code + (princ "\n")))) + ) + +(defmethod srecode-dump ((ins srecode-template-inserter) indent) + "Dump the state of the SRecode template inserter INS." + (princ "INS: \"") + (princ (object-name-string ins)) + (when (oref ins :secondname) + (princ "\" : \"") + (princ (oref ins :secondname))) + (princ "\" type \"") + (let* ((oc (symbol-name (object-class ins))) + (junk (string-match "srecode-template-inserter-" oc)) + (on (if junk + (substring oc (match-end 0)) + oc))) + (princ on)) + (princ "\"") + ) + +(provide 'srecode/compile) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/compile" +;; End: + +;;; srecode/compile.el ends here diff --git a/lisp/cedet/srecode/cpp.el b/lisp/cedet/srecode/cpp.el new file mode 100644 index 00000000000..28613a004ed --- /dev/null +++ b/lisp/cedet/srecode/cpp.el @@ -0,0 +1,149 @@ +;;; srecode/cpp.el --- C++ specific handlers for Semantic Recoder + +;; Copyright (C) 2007, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> +;; Jan Moringen <scymtym@users.sourceforge.net> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Supply some C++ specific dictionary fillers and helpers + +;;; Code: + +;;; :cpp ARGUMENT HANDLING +;; +;; When a :cpp argument is required, fill the dictionary with +;; information about the current C++ file. +;; +;; Error if not in a C++ mode. + +(require 'srecode) +(require 'srecode/dictionary) +(require 'srecode/semantic) + +;;;###autoload +(defun srecode-semantic-handle-:cpp (dict) + "Add macros into the dictionary DICT based on the current c++ file. +Adds the following: +FILENAME_SYMBOL - filename converted into a C compat symbol. +HEADER - Shown section if in a header file." + ;; A symbol representing + (let ((fsym (file-name-nondirectory (buffer-file-name))) + (case-fold-search t)) + + ;; Are we in a header file? + (if (string-match "\\.\\(h\\|hh\\|hpp\\|h\\+\\+\\)$" fsym) + (srecode-dictionary-show-section dict "HEADER") + (srecode-dictionary-show-section dict "NOTHEADER")) + + ;; Strip out bad characters + (while (string-match "\\.\\| " fsym) + (setq fsym (replace-match "_" t t fsym))) + (srecode-dictionary-set-value dict "FILENAME_SYMBOL" fsym) + ) + ) + +(define-mode-local-override srecode-semantic-apply-tag-to-dict + c++-mode (tag-wrapper dict) + "Apply C++ specific features from TAG-WRAPPER into DICT. +Calls `srecode-semantic-apply-tag-to-dict-default' first. Adds +special behavior for tag of classes include, using and function." + + ;; Use default implementation to fill in the basic properties. + (srecode-semantic-apply-tag-to-dict-default tag-wrapper dict) + + ;; Pull out the tag for the individual pieces. + (let* ((tag (oref tag-wrapper :prime)) + (class (semantic-tag-class tag))) + + ;; Add additional information based on the class of the tag. + (cond + ;; + ;; INCLUDE + ;; + ((eq class 'include) + ;; For include tags, we have to discriminate between system-wide + ;; and local includes. + (if (semantic-tag-include-system-p tag) + (srecode-dictionary-show-section dict "SYSTEM") + (srecode-dictionary-show-section dict "LOCAL"))) + + ;; + ;; USING + ;; + ((eq class 'using) + ;; Insert the subject (a tag) of the include statement as VALUE + ;; entry into the dictionary. + (let ((value-tag (semantic-tag-get-attribute tag :value)) + (value-dict (srecode-dictionary-add-section-dictionary + dict "VALUE"))) + (srecode-semantic-apply-tag-to-dict + (srecode-semantic-tag (semantic-tag-name value-tag) + :prime value-tag) + value-dict)) + ;; Discriminate using statements referring to namespaces and + ;; types. + (when (eq (semantic-tag-get-attribute tag :kind) 'namespace) + (srecode-dictionary-show-section dict "NAMESPACE"))) + + ;; + ;; FUNCTION + ;; + ((eq class 'function) + ;; @todo It would be nice to distinguish member functions from + ;; free functions and only apply the const and pure modifiers, + ;; when they make sense. My best bet would be + ;; (semantic-tag-function-parent tag), but it is not there, when + ;; the function is defined in the scope of a class. + (let ((member 't) + (modifiers (semantic-tag-modifiers tag))) + + ;; Add modifiers into the dictionary + (dolist (modifier modifiers) + (let ((modifier-dict (srecode-dictionary-add-section-dictionary + dict "MODIFIERS"))) + (srecode-dictionary-set-value modifier-dict "NAME" modifier))) + + ;; When the function is a member function, it can have + ;; additional modifiers. + (when member + + ;; For member functions, constness is called + ;; 'methodconst-flag'. + (when (semantic-tag-get-attribute tag :methodconst-flag) + (srecode-dictionary-show-section dict "CONST")) + + ;; If the member function is pure virtual, add a dictionary + ;; entry. + (when (semantic-tag-get-attribute tag :pure-virtual-flag) + (srecode-dictionary-show-section dict "PURE")) + ) + )) + )) + ) + +(provide 'srecode/cpp) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/cpp" +;; End: + +;;; srecode/cpp.el ends here diff --git a/lisp/cedet/srecode/ctxt.el b/lisp/cedet/srecode/ctxt.el new file mode 100644 index 00000000000..8dc302057ff --- /dev/null +++ b/lisp/cedet/srecode/ctxt.el @@ -0,0 +1,247 @@ +;;; srecode/ctxt.el --- Derive a context from the source buffer. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Manage context calculations for Semantic Recoder. +;; +;; SRecode templates are always bound to a context. By calculating +;; the current context, we can narrow down the selection of possible +;; templates to something reasonable. +;; +;; Alternately, code here will find a context for templates that +;; require different pieces of code placed in multiple areas. + +(require 'semantic) +(require 'semantic/tag-ls) + +(declare-function srecode-dictionary-show-section "srecode/dictionary") +(declare-function srecode-dictionary-set-value "srecode/dictionary") + +;;; Code: + +(define-overload srecode-calculate-context () + "Calculate the context at the current point. +The returned context is a list, with the top-most context first. +Each returned context is a string that that would show up in a `context' +statement in an `.srt' file. + +Some useful context values used by the provided srecode templates are: + \"file\" - Templates that for a file (such as an empty file.) + \"empty\" - The file is empty + \"declaration\" - Top-level declarations in a file. + \"include\" - In or near include statements + \"package\" - In or near provide statements + \"function\" - In or near function statements + \"NAME\" - Near functions within NAME namespace or class + \"variable\" - In or near variable statements. + \"type\" - In or near type declarations. + \"comment\" - In a comment + \"classdecl\" - Declarations within a class/struct/etc. + \"variable\" - In or near class fields + \"function\" - In or near methods/functions + \"virtual\" - Nearby items are virtual + \"pure\" - and those virtual items are pure virtual + \"type\" - In or near type declarations. + \"comment\" - In a comment in a block of code + -- these items show up at the end of the context list. -- + \"public\", \"protected\", \"private\" - + In or near a section of public/pritected/private entries. + \"code\" - In a block of code. + \"string\" - In a string in a block of code + \"comment\" - In a comment in a block of code + + ... More later." + ) + +(defun srecode-calculate-nearby-things () + ;; NOTE: May need to add bounes to this FCN + "Calculate the CONTEXT type items nearby the current point. +Assume that what we want to insert next is based on what is just +before point. If there is nothing, then assume it is whatever is +after point." + ;; @todo - ADD BOUNDS TO THE PREV/NEXT TAG SEARCH + ;; thus classdecl "near" stuff cannot be + ;; outside the bounds of the type in question. + (let ((near (semantic-find-tag-by-overlay-prev)) + (prot nil) + (ans nil)) + (if (not near) + (setq near (semantic-find-tag-by-overlay-next))) + (when near + ;; Calculate the type of thing we are near. + (if (not (semantic-tag-of-class-p near 'function)) + (setq ans (cons (symbol-name (semantic-tag-class near)) ans)) + ;; if the symbol NEAR has a parent, + (let ((p (semantic-tag-function-parent near))) + (setq ans (cons (symbol-name (semantic-tag-class near)) ans)) + (cond ((semantic-tag-p p) + (setq ans (cons (semantic-tag-name p) ans))) + ((stringp p) + (setq ans (cons p ans))) + (t nil))) + ;; Was it virtual? + (when (semantic-tag-get-attribute near :virtual) + (setq ans (cons "virtual" ans))) + ;; Was it pure? + (when (semantic-tag-get-attribute near :pure-virtual-flag) + (setq ans (cons "pure" ans))) + ) + ;; Calculate the protection + (setq prot (semantic-tag-protection near)) + (when (and prot (not (eq prot 'unknown))) + (setq ans (cons (symbol-name prot) ans))) + ) + (nreverse ans))) + +(defun srecode-calculate-context-font-lock () + "Calculate an srecode context by using font-lock." + (let ((face (get-text-property (point) 'face)) + ) + (cond ((member face '(font-lock-string-face + font-lock-doc-face)) + (list "string")) + ((member face '(font-lock-comment-face + font-lock-comment-delimiter-face)) + (list "comment")) + ) + )) + +(defun srecode-calculate-context-default () + "Generic method for calculating a context for srecode." + (if (= (point-min) (point-max)) + (list "file" "empty") + + (semantic-fetch-tags) + (let ((ct (semantic-find-tag-by-overlay)) + ) + (cond ((or (not ct) + ;; Ok, below is a bit C specific. + (and (eq (semantic-tag-class (car ct)) 'type) + (string= (semantic-tag-type (car ct)) "namespace"))) + (cons "declaration" + (or (srecode-calculate-context-font-lock) + (srecode-calculate-nearby-things) + )) + ) + ((eq (semantic-tag-class (car ct)) 'function) + (cons "code" (srecode-calculate-context-font-lock)) + ) + ((eq (semantic-tag-class (car ct)) 'type) ; We know not namespace + (cons "classdecl" + (or (srecode-calculate-context-font-lock) + (srecode-calculate-nearby-things))) + ) + ((and (car (cdr ct)) + (eq (semantic-tag-class (car (cdr ct))) 'type)) + (list "classdecl" + (symbol-name (semantic-tag-class (car ct)))) + ) + ) + ))) + + +;;; HANDLERS +;; +;; The calculated context is one thing, but more info is often available. +;; The context handlers can add info into the active dictionary that is +;; based on the context, such as a method parent name, protection scheme, +;; or other feature. + +(defun srecode-semantic-handle-:ctxt (dict &optional template) + "Add macros into the dictionary DICT based on the current Emacs Lisp file. +Argument TEMPLATE is the template object adding context dictionary +entries. +This might add the following: + VIRTUAL - show a section if a function is virtual + PURE - show a section if a function is pure virtual. + PARENT - The name of a parent type for functions. + PROTECTION - Show a protection section, and what the protection is." + (require 'srecode/dictionary) + (when template + + (let ((name (oref template object-name)) + (cc (if (boundp 'srecode-insertion-start-context) + srecode-insertion-start-context)) + ;(context (oref template context)) + ) + +; (when (and cc +; (null (string= (car cc) context)) +; ) +; ;; No current context, or the base is different, then +; ;; this is the section where we need to recalculate +; ;; the context based on user choice, if possible. +; ;; +; ;; The recalculation is complex, as there are many possibilities +; ;; that need to be divined. Set "cc" to the new context +; ;; at the end. +; ;; +; ;; @todo - +; +; ) + + ;; The various context all have different features. + (let ((ct (nth 0 cc)) + (it (nth 1 cc)) + (last (last cc)) + (parent nil) + ) + (cond ((string= it "function") + (setq parent (nth 2 cc)) + (when parent + (cond ((string= parent "virtual") + (srecode-dictionary-show-section dict "VIRTUAL") + (when (nth 3 cc) + (srecode-dictionary-show-section dict "PURE")) + ) + (t + (srecode-dictionary-set-value dict "PARENT" parent)))) + ) + ((and (string= it "type") + (or (string= name "function") (string= name "method"))) + ;; If we have a type, but we insert a fcn, then use that type + ;; as the function parent. + (let ((near (semantic-find-tag-by-overlay-prev))) + (when (and near (semantic-tag-of-class-p near 'type)) + (srecode-dictionary-set-value + dict "PARENT" (semantic-tag-name near)))) + ) + ((string= ct "code") + ;;(let ((analyzer (semantic-analyze-current-context))) + ;; @todo - Use the analyze to setup things like local + ;; variables we might use or something. + nil + ;;) + ) + (t + nil)) + (when (member last '("public" "private" "protected")) + ;; Hey, fancy that, we can do both. + (srecode-dictionary-set-value dict "PROTECTION" parent) + (srecode-dictionary-show-section dict "PROTECTION")) + )) + )) + + +(provide 'srecode/ctxt) + +;;; srecode/ctxt.el ends here diff --git a/lisp/cedet/srecode/dictionary.el b/lisp/cedet/srecode/dictionary.el new file mode 100644 index 00000000000..c637f1f2a5f --- /dev/null +++ b/lisp/cedet/srecode/dictionary.el @@ -0,0 +1,565 @@ +;;; srecode-dictionary.el --- Dictionary code for the semantic recoder. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Dictionaries contain lists of names and their assocaited values. +;; These dictionaries are used to fill in macros from recoder templates. + +;;; Code: + +;;; CLASSES + +(require 'eieio) +(require 'srecode) +(require 'srecode/table) +(eval-when-compile (require 'semantic)) + +(declare-function srecode-compile-parse-inserter "srecode/compile") +(declare-function srecode-dump-code-list "srecode/compile") +(declare-function srecode-load-tables-for-mode "srecode/find") +(declare-function srecode-insert-code-stream "srecode/insert") +(declare-function data-debug-new-buffer "data-debug") +(declare-function data-debug-insert-object-slots "eieio-datadebug") +(declare-function srecode-field "srecode/fields") + +(defclass srecode-dictionary () + ((namehash :initarg :namehash + :documentation + "Hash table containing the names of all the templates.") + (buffer :initarg :buffer + :documentation + "The buffer this dictionary was initialized with.") + (parent :initarg :parent + :type (or null srecode-dictionary) + :documentation + "The parent dictionary. +Symbols not appearing in this dictionary will be checked against the +parent dictionary.") + (origin :initarg :origin + :type string + :documentation + "A string representing the origin of this dictionary. +Useful only while debugging.") + ) + "Dictionary of symbols and what they mean. +Dictionaries are used to look up named symbols from +templates to decide what to do with those symbols.") + +(defclass srecode-dictionary-compound-value () + () + "A compound dictionary value. +Values stored in a dictionary must be a STRING, +a dictionary for showing sections, or an instance of a subclass +of this class. + +Compound dictionary values derive from this class, and must +provide a sequence of method implementations to convert into +a string." + :abstract t) + +(defclass srecode-dictionary-compound-variable + (srecode-dictionary-compound-value) + ((value :initarg :value + :documentation + "The value of this template variable. +Variables in template files are usually a single string +which can be inserted into a dictionary directly. + +Some variables may be more complex and involve dictionary +lookups, strings, concatenation, or the like. + +The format of VALUE is determined by current template +formatting rules.") + (compiled :initarg :compiled + :type list + :documentation + "The compiled version of VALUE.") + ) + "A compound dictionary value for template file variables. +You can declare a variable in a template like this: + +set NAME \"str\" macro \"OTHERNAME\" + +with appending various parts together in a list.") + +(defmethod initialize-instance ((this srecode-dictionary-compound-variable) + &optional fields) + "Initialize the compound variable THIS. +Makes sure that :value is compiled." + (let ((newfields nil) + (state nil)) + (while fields + ;; Strip out :state + (if (eq (car fields) :state) + (setq state (car (cdr fields))) + (setq newfields (cons (car (cdr fields)) + (cons (car fields) newfields)))) + (setq fields (cdr (cdr fields)))) + + (when (not state) + (error "Cannot create compound variable without :state")) + + (call-next-method this (nreverse newfields)) + (when (not (slot-boundp this 'compiled)) + (let ((val (oref this :value)) + (comp nil)) + (while val + (let ((nval (car val)) + ) + (cond ((stringp nval) + (setq comp (cons nval comp))) + ((and (listp nval) + (equal (car nval) 'macro)) + (require 'srecode/compile) + (setq comp (cons + (srecode-compile-parse-inserter + (cdr nval) + state) + comp))) + (t + (error "Don't know how to handle variable value %S" nval))) + ) + (setq val (cdr val))) + (oset this :compiled (nreverse comp)))))) + +;;; DICTIONARY METHODS +;; + +(defun srecode-create-dictionary (&optional buffer-or-parent) + "Create a dictionary for BUFFER. +If BUFFER-OR-PARENT is not specified, assume a buffer, and +use the current buffer. +If BUFFER-OR-PARENT is another dictionary, then remember the +parent within the new dictionary, and assume that BUFFER +is the same as belongs to the parent dictionary. +The dictionary is initialized with variables setup for that +buffer's table. +If BUFFER-OR-PARENT is t, then this dictionary should not be +assocated with a buffer or parent." + (save-excursion + (let ((parent nil) + (buffer nil) + (origin nil) + (initfrombuff nil)) + (cond ((bufferp buffer-or-parent) + (set-buffer buffer-or-parent) + (setq buffer buffer-or-parent + origin (buffer-name buffer-or-parent) + initfrombuff t)) + ((srecode-dictionary-child-p buffer-or-parent) + (setq parent buffer-or-parent + buffer (oref buffer-or-parent buffer) + origin (concat (object-name buffer-or-parent) " in " + (if buffer (buffer-name buffer) + "no buffer"))) + (when buffer + (set-buffer buffer))) + ((eq buffer-or-parent t) + (setq buffer nil + origin "Unspecified Origin")) + (t + (setq buffer (current-buffer) + origin (concat "Unspecified. Assume " + (buffer-name buffer)) + initfrombuff t) + ) + ) + (let ((dict (srecode-dictionary + major-mode + :buffer buffer + :parent parent + :namehash (make-hash-table :test 'equal + :size 20) + :origin origin))) + ;; Only set up the default variables if we are being built + ;; directroy for a particular buffer. + (when initfrombuff + ;; Variables from the table we are inserting from. + ;; @todo - get a better tree of tables. + (let ((mt (srecode-get-mode-table major-mode)) + (def (srecode-get-mode-table 'default))) + ;; Each table has multiple template tables. + ;; Do DEF first so that MT can override any values. + (srecode-dictionary-add-template-table dict def) + (srecode-dictionary-add-template-table dict mt) + )) + dict)))) + +(defmethod srecode-dictionary-add-template-table ((dict srecode-dictionary) + tpl) + "Insert into DICT the variables found in table TPL. +TPL is an object representing a compiled template file." + (when tpl + (let ((tabs (oref tpl :tables))) + (while tabs + (let ((vars (oref (car tabs) variables))) + (while vars + (srecode-dictionary-set-value + dict (car (car vars)) (cdr (car vars))) + (setq vars (cdr vars)))) + (setq tabs (cdr tabs)))))) + + +(defmethod srecode-dictionary-set-value ((dict srecode-dictionary) + name value) + "In dictionary DICT, set NAME to have VALUE." + ;; Validate inputs + (if (not (stringp name)) + (signal 'wrong-type-argument (list name 'stringp))) + ;; Add the value. + (with-slots (namehash) dict + (puthash name value namehash)) + ) + +(defmethod srecode-dictionary-add-section-dictionary ((dict srecode-dictionary) + name &optional show-only) + "In dictionary DICT, add a section dictionary for section macro NAME. +Return the new dictionary. + +You can add several dictionaries to the same section macro. +For each dictionary added to a macro, the block of codes in the +template will be repeated. + +If optional argument SHOW-ONLY is non-nil, then don't add a new dictionarly +if there is already one in place. Also, don't add FIRST/LAST entries. +These entries are not needed when we are just showing a section. + +Each dictionary added will automatically get values for positional macros +which will enable SECTIONS to be enabled. + + * FIRST - The first entry in the table. + * NOTFIRST - Not the first entry in the table. + * LAST - The last entry in the table + * NOTLAST - Not the last entry in the table. + +Adding a new dictionary will alter these values in previously +inserted dictionaries." + ;; Validate inputs + (if (not (stringp name)) + (signal 'wrong-type-argument (list name 'stringp))) + (let ((new (srecode-create-dictionary dict)) + (ov (srecode-dictionary-lookup-name dict name))) + + (when (not show-only) + ;; Setup the FIRST/NOTFIRST and LAST/NOTLAST entries. + (if (null ov) + (progn + (srecode-dictionary-show-section new "FIRST") + (srecode-dictionary-show-section new "LAST")) + ;; Not the very first one. Lets clean up CAR. + (let ((tail (car (last ov)))) + (srecode-dictionary-hide-section tail "LAST") + (srecode-dictionary-show-section tail "NOTLAST") + ) + (srecode-dictionary-show-section new "NOTFIRST") + (srecode-dictionary-show-section new "LAST")) + ) + + (when (or (not show-only) (null ov)) + (srecode-dictionary-set-value dict name (append ov (list new)))) + ;; Return the new sub-dictionary. + new)) + +(defmethod srecode-dictionary-show-section ((dict srecode-dictionary) name) + "In dictionary DICT, indicate that the section NAME should be exposed." + ;; Validate inputs + (if (not (stringp name)) + (signal 'wrong-type-argument (list name 'stringp))) + ;; Showing a section is just like making a section dictionary, but + ;; with no dictionary values to add. + (srecode-dictionary-add-section-dictionary dict name t) + nil) + +(defmethod srecode-dictionary-hide-section ((dict srecode-dictionary) name) + "In dictionary DICT, indicate that the section NAME should be hidden." + ;; We need to find the has value, and then delete it. + ;; Validate inputs + (if (not (stringp name)) + (signal 'wrong-type-argument (list name 'stringp))) + ;; Add the value. + (with-slots (namehash) dict + (remhash name namehash)) + nil) + +(defmethod srecode-dictionary-merge ((dict srecode-dictionary) otherdict) + "Merge into DICT the dictionary entries from OTHERDICT." + (when otherdict + (maphash + (lambda (key entry) + ;; Only merge in the new values if there was no old value. + ;; This protects applications from being whacked, and basically + ;; makes these new section dictionary entries act like + ;; "defaults" instead of overrides. + (when (not (srecode-dictionary-lookup-name dict key)) + (cond ((and (listp entry) (srecode-dictionary-p (car entry))) + ;; A list of section dictionaries. + ;; We need to merge them in. + (while entry + (let ((new-sub-dict + (srecode-dictionary-add-section-dictionary + dict key))) + (srecode-dictionary-merge new-sub-dict (car entry))) + (setq entry (cdr entry))) + ) + + (t + (srecode-dictionary-set-value dict key entry))) + )) + (oref otherdict namehash)))) + +(defmethod srecode-dictionary-lookup-name ((dict srecode-dictionary) + name) + "Return information about the current DICT's value for NAME." + (if (not (slot-boundp dict 'namehash)) + nil + ;; Get the value of this name from the dictionary + (or (with-slots (namehash) dict + (gethash name namehash)) + (and (not (member name '("FIRST" "LAST" "NOTFIRST" "NOTLAST"))) + (oref dict parent) + (srecode-dictionary-lookup-name (oref dict parent) name)) + ))) + +(defmethod srecode-root-dictionary ((dict srecode-dictionary)) + "For dictionary DICT, return the root dictionary. +The root dictionary is usually for a current or active insertion." + (let ((ans dict)) + (while (oref ans parent) + (setq ans (oref ans parent))) + ans)) + +;;; COMPOUND VALUE METHODS +;; +;; Compound values must provide at least the toStriong method +;; for use in converting the compound value into sometehing insertable. + +(defmethod srecode-compound-toString ((cp srecode-dictionary-compound-value) + function + dictionary) + "Convert the compound dictionary value CP to a string. +If FUNCTION is non-nil, then FUNCTION is somehow applied to an aspect +of the compound value. The FUNCTION could be a fraction +of some function symbol with a logical prefix excluded. + +If you subclass `srecode-dictionary-compound-value' then this +method could return nil, but if it does that, it must insert +the value itself using `princ', or by detecting if the current +standard out is a buffer, and using `insert'." + (object-name cp)) + +(defmethod srecode-dump ((cp srecode-dictionary-compound-value) + &optional indent) + "Display information about this compound value." + (princ (object-name cp)) + ) + +(defmethod srecode-compound-toString ((cp srecode-dictionary-compound-variable) + function + dictionary) + "Convert the compound dictionary variable value CP into a string. +FUNCTION and DICTIONARY are as for the baseclass." + (require 'srecode/insert) + (srecode-insert-code-stream (oref cp compiled) dictionary)) + + +(defmethod srecode-dump ((cp srecode-dictionary-compound-variable) + &optional indent) + "Display information about this compound value." + (require 'srecode/compile) + (princ "# Compound Variable #\n") + (let ((indent (+ 4 (or indent 0))) + (cmp (oref cp compiled)) + ) + (srecode-dump-code-list cmp (make-string indent ? )) + )) + +;;; FIELD EDITING COMPOUND VALUE +;; +;; This is an interface to using field-editing objects +;; instead of asking questions. This provides the basics +;; behind this compound value. + +(defclass srecode-field-value (srecode-dictionary-compound-value) + ((firstinserter :initarg :firstinserter + :documentation + "The inserter object for the first occurance of this field.") + (defaultvalue :initarg :defaultvalue + :documentation + "The default value for this inserter.") + ) + "When inserting values with editable field mode, a dictionary value. +Compound values allow a field to be stored in the dictionary for when +it is referenced a second time. This compound value can then be +inserted with a new editable field.") + +(defmethod srecode-compound-toString((cp srecode-field-value) + function + dictionary) + "Convert this field into an insertable string." + (require 'srecode/fields) + ;; If we are not in a buffer, then this is not supported. + (when (not (bufferp standard-output)) + (error "FIELDS invoked while inserting template to non-buffer.")) + + (if function + (error "@todo: Cannot mix field insertion with functions.") + + ;; No function. Perform a plain field insertion. + ;; We know we are in a buffer, so we can perform the insertion. + (let* ((dv (oref cp defaultvalue)) + (sti (oref cp firstinserter)) + (start (point)) + (name (oref sti :object-name))) + + (if (or (not dv) (string= dv "")) + (insert name) + (insert dv)) + + (srecode-field name :name name + :start start + :end (point) + :prompt (oref sti prompt) + :read-fcn (oref sti read-fcn) + ) + )) + ;; Returning nil is a signal that we have done the insertion ourselves. + nil) + + +;;; Higher level dictionary functions +;; +(defun srecode-create-section-dictionary (sectiondicts STATE) + "Create a dictionary with section entries for a template. +The format for SECTIONDICTS is what is emitted from the template parsers. +STATE is the current compiler state." + (when sectiondicts + (let ((new (srecode-create-dictionary t))) + ;; Loop over each section. The section is a macro w/in the + ;; template. + (while sectiondicts + (let* ((sect (car (car sectiondicts))) + (entries (cdr (car sectiondicts))) + (subdict (srecode-dictionary-add-section-dictionary new sect)) + ) + ;; Loop over each entry. This is one variable in the + ;; section dictionary. + (while entries + (let ((tname (semantic-tag-name (car entries))) + (val (semantic-tag-variable-default (car entries)))) + (if (eq val t) + (srecode-dictionary-show-section subdict tname) + (cond + ((and (stringp (car val)) + (= (length val) 1)) + (setq val (car val))) + (t + (setq val (srecode-dictionary-compound-variable + tname :value val :state STATE)))) + (srecode-dictionary-set-value + subdict tname val)) + (setq entries (cdr entries)))) + ) + (setq sectiondicts (cdr sectiondicts))) + new))) + +;;; DUMP DICTIONARY +;; +;; Make a dictionary, and dump it's contents. + +(defun srecode-adebug-dictionary () + "Run data-debug on this mode's dictionary." + (interactive) + (require 'eieio-datadebug) + (require 'semantic) + (require 'srecode/find) + (let* ((modesym major-mode) + (start (current-time)) + (junk (or (progn (srecode-load-tables-for-mode modesym) + (srecode-get-mode-table modesym)) + (error "No table found for mode %S" modesym))) + (dict (srecode-create-dictionary (current-buffer))) + (end (current-time)) + ) + (message "Creating a dictionary took %.2f seconds." + (semantic-elapsed-time start end)) + (data-debug-new-buffer "*SRECODE ADEBUG*") + (data-debug-insert-object-slots dict "*"))) + +(defun srecode-dictionary-dump () + "Dump a typical fabricated dictionary." + (interactive) + (require 'srecode/find) + (let ((modesym major-mode)) + ;; This load allows the dictionary access to inherited + ;; and stacked dictionary entries. + (srecode-load-tables-for-mode modesym) + (let ((tmp (srecode-get-mode-table modesym)) + ) + (if (not tmp) + (error "No table found for mode %S" modesym)) + ;; Now make the dictionary. + (let ((dict (srecode-create-dictionary (current-buffer)))) + (with-output-to-temp-buffer "*SRECODE DUMP*" + (princ "DICTIONARY FOR ") + (princ major-mode) + (princ "\n--------------------------------------------\n") + (srecode-dump dict)) + )))) + +(defmethod srecode-dump ((dict srecode-dictionary) &optional indent) + "Dump a dictionary." + (if (not indent) (setq indent 0)) + (maphash (lambda (key entry) + (princ (make-string indent ? )) + (princ " ") + (princ key) + (princ " ") + (cond ((and (listp entry) + (srecode-dictionary-p (car entry))) + (let ((newindent (if indent + (+ indent 4) + 4))) + (while entry + (princ " --> SUBDICTIONARY ") + (princ (object-name dict)) + (princ "\n") + (srecode-dump (car entry) newindent) + (setq entry (cdr entry)) + )) + (princ "\n") + ) + ((srecode-dictionary-compound-value-child-p entry) + (srecode-dump entry indent) + (princ "\n") + ) + (t + (prin1 entry) + ;(princ "\n") + )) + (terpri) + ) + (oref dict namehash)) + ) + +(provide 'srecode/dictionary) + +;;; srecode/dictionary.el ends here diff --git a/lisp/cedet/srecode/document.el b/lisp/cedet/srecode/document.el new file mode 100644 index 00000000000..fd35a1828e3 --- /dev/null +++ b/lisp/cedet/srecode/document.el @@ -0,0 +1,841 @@ +;;; srecode/document.el --- Documentation (comment) generation + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Routines for fabricating human readable text from function and +;; variable names as base-text for function comments. Document is not +;; meant to generate end-text for any function. It is merely meant to +;; provide some useful base words and text, and as a framework for +;; managing comments. +;; +;;; Origins: +;; +;; Document was first written w/ cparse, a custom regexp based c parser. +;; +;; Document was then ported to cedet/semantic using sformat (super +;; format) as the templating engine. +;; +;; Document has now been ported to srecode, using the semantic recoder +;; as the templating engine. + +;; This file combines srecode-document.el and srecode-document-vars.el +;; from the CEDET repository. + +(require 'srecode/args) +(require 'srecode/dictionary) +(require 'srecode/extract) +(require 'srecode/insert) +(require 'srecode/semantic) + +(require 'semantic) +(require 'semantic/tag) +(require 'semantic/doc) +(require 'pulse) + +;;; Code: + +(defgroup document nil + "File and tag browser frame." + :group 'texinfo + :group 'srecode) + +(defcustom srecode-document-autocomment-common-nouns-abbrevs + '( + ("sock\\(et\\)?" . "socket") + ("addr\\(ess\\)?" . "address") + ("buf\\(f\\(er\\)?\\)?" . "buffer") + ("cur\\(r\\(ent\\)?\\)?" . "current") + ("dev\\(ice\\)?" . "device") + ("doc" . "document") + ("i18n" . "internationalization") + ("file" . "file") + ("line" . "line") + ("l10n" . "localization") + ("msg\\|message" . "message") + ("name" . "name") + ("next\\|nxt" . "next") + ("num\\(ber\\)?" . "number") + ("port" . "port") + ("host" . "host") + ("obj\\|object" . "object") + ("previous\\|prev" . "previous") + ("str\\(ing\\)?" . "string") + ("use?r" . "user") + ("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;common syllable + ) + "List of common English abbreviations or full words. +These are nouns (as opposed to verbs) for use in creating expanded +versions of names.This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-function-alist + '( + ("abort" . "Aborts the") + ;; trick to get re-alloc and alloc to pair into one sentence. + ("realloc" . "moves or ") + ("alloc\\(ate\\)?" . "Allocates and initializes a new ") + ("clean" . "Cleans up the") + ("clobber" . "Removes") + ("close" . "Cleanly closes") + ("check" . "Checks the") + ("comp\\(are\\)?" . "Compares the") + ("create" . "Creates a new ") + ("find" . "Finds ") + ("free" . "Frees up space") + ("gen\\(erate\\)?" . "Generates a new ") + ("get\\|find" . "Looks for the given ") + ("gobble" . "Removes") + ("he?lp" . "Provides help for") + ("li?ste?n" . "Listens for ") + ("connect" . "Connects to ") + ("acc?e?pt" . "Accepts a ") + ("load" . "Loads in ") + ("match" . "Check that parameters match") + ("name" . "Provides a name which ") + ("new" . "Allocates a ") + ("parse" . "Parses the parameters and returns ") + ("print\\|display" . "Prints out") + ("read" . "Reads from") + ("reset" . "Resets the parameters and returns") + ("scan" . "Scans the ") + ("setup\\|init\\(iallize\\)?" . "Initializes the ") + ("select" . "Chooses the ") + ("send" . "Sends a") + ("re?c\\(v\\|ieves?\\)" . "Receives a ") + ("to" . "Converts ") + ("update" . "Updates the ") + ("wait" . "Waits for ") + ("write" . "Writes to") + ) + "List of names to string match against the function name. +This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string. + +Certain prefixes may always mean the same thing, and the same comment +can be used as a beginning for the description. Regexp should be +lower case since the string they are compared to is downcased. +A string may end in a space, in which case, last-alist is searched to +see how best to describe what can be returned. +Doesn't always work correctly, but that is just because English +doesn't always work correctly." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-common-nouns-abbrevs + '( + ("sock\\(et\\)?" . "socket") + ("addr\\(ess\\)?" . "address") + ("buf\\(f\\(er\\)?\\)?" . "buffer") + ("cur\\(r\\(ent\\)?\\)?" . "current") + ("dev\\(ice\\)?" . "device") + ("file" . "file") + ("line" . "line") + ("msg\\|message" . "message") + ("name" . "name") + ("next\\|nxt" . "next") + ("port" . "port") + ("host" . "host") + ("obj\\|object" . "object") + ("previous\\|prev" . "previous") + ("str\\(ing\\)?" . "string") + ("use?r" . "user") + ("num\\(ber\\)?" . "number") + ("\\(^\\|\\s-\\)id\\($\\|\\s-\\)" . "Identifier") ;complex cause ;commen sylable + ) + "List of common English abbreviations or full words. +These are nouns (as opposed to verbs) for use in creating expanded +versions of names.This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-return-first-alist + '( + ;; Static must be first in the list to provide the intro to the sentence + ("static" . "Locally defined function which ") + ("Bool\\|BOOL" . "Status of ") + ) + "List of regexp matches for types. +They provide a little bit of text when typing information is +described. +This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-return-last-alist + '( + ("static[ \t\n]+struct \\([a-zA-Z0-9_]+\\)" . "%s") + ("struct \\([a-zA-Z0-9_]+\\)" . "%s") + ("static[ \t\n]+union \\([a-zA-Z0-9_]+\\)" . "%s") + ("union \\([a-zA-Z0-9_]+\\)" . "%s") + ("static[ \t\n]+enum \\([a-zA-Z0-9_]+\\)" . "%s") + ("enum \\([a-zA-Z0-9_]+\\)" . "%s") + ("static[ \t\n]+\\([a-zA-Z0-9_]+\\)" . "%s") + ("\\([a-zA-Z0-9_]+\\)" . "of type %s") + ) + "List of regexps which provide the type of the return value. +This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string, which can contain %s, whih is replaced with +`match-string' 1." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-param-alist + '( ("[Cc]txt" . "Context") + ("[Ii]d" . "Identifier of") + ("[Tt]ype" . "Type of") + ("[Nn]ame" . "Name of") + ("argc" . "Number of arguments") + ("argv" . "Argument vector") + ("envp" . "Environment variable vector") + ) + "Alist of common variable names appearing as function parameters. +This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string of text to use to describe MATCH. +When one is encountered, document-insert-parameters will automatically +place this comment after the parameter name." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +(defcustom srecode-document-autocomment-param-type-alist + '(("const" . "Constant") + ("void" . "Empty") + ("char[ ]*\\*" . "String ") + ("\\*\\*" . "Pointer to ") + ("\\*" . "Pointer ") + ("char[ ]*\\([^ \t*]\\|$\\)" . "Character") + ("int\\|long" . "Number of") + ("FILE" . "File of") + ("float\\|double" . "Value of") + ;; How about some X things? + ("Bool\\|BOOL" . "Flag") + ("Window" . "Window") + ("GC" . "Graphic Context") + ("Widget" . "Widget") + ) + "Alist of input parameter types and strings desribing them. +This is an alist with each element of the form: + (MATCH . RESULT) +MATCH is a regexp to match in the type field. +RESULT is a string." + :group 'document + :type '(repeat (cons (string :tag "Regexp") + (string :tag "Doc Text")))) + +;;;###autoload +(defun srecode-document-insert-comment () + "Insert some comments. +Whack any comments that may be in the way and replace them. +If the region is active, then insert group function comments. +If the cursor is in a comment, figure out what kind of comment it is + and replace it. +If the cursor is in a function, insert a function comment. +If the cursor is on a one line prototype, then insert post-fcn comments." + (interactive) + (semantic-fetch-tags) + (let ((ctxt (srecode-calculate-context))) + (if ;; Active region stuff. + (or srecode-handle-region-when-non-active-flag + (eq last-command 'mouse-drag-region) + (and transient-mark-mode mark-active)) + (if (> (point) (mark)) + (srecode-document-insert-group-comments (mark) (point)) + (srecode-document-insert-group-comments (point) (mark))) + ;; ELSE + + ;; A declaration comment. Find what it documents. + (when (equal ctxt '("declaration" "comment")) + + ;; If we are on a one line tag/comment, go to that fcn. + (if (save-excursion (back-to-indentation) + (semantic-current-tag)) + (back-to-indentation) + + ;; Else, do we have a fcn following us? + (let ((tag (semantic-find-tag-by-overlay-next))) + (when tag (semantic-go-to-tag tag)))) + ) + + ;; Now analyze the tag we may be on. + + (if (semantic-current-tag) + (cond + ;; A one-line variable + ((and (semantic-tag-of-class-p (semantic-current-tag) 'variable) + (srecode-document-one-line-tag-p (semantic-current-tag))) + (srecode-document-insert-variable-one-line-comment)) + ;; A plain function + ((semantic-tag-of-class-p (semantic-current-tag) 'function) + (srecode-document-insert-function-comment)) + ;; Don't know. + (t + (error "Not sure what to comment")) + ) + + ;; ELSE, no tag. Perhaps we should just insert a nice section + ;; header?? + + (let ((title (read-string "Section Title (RET to skip): "))) + + (when (and (stringp title) (not (= (length title) 0))) + (srecode-document-insert-section-comment title))) + + )))) + +(defun srecode-document-insert-section-comment (&optional title) + "Insert a section comment with TITLE." + (interactive "sSection Title: ") + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'document) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let* ((dict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) + "section-comment" + "declaration" + 'document))) + (if (not temp) + (error "No templates for inserting section comments")) + + (when title + (srecode-dictionary-set-value + dict "TITLE" title)) + + (srecode-insert-fcn temp dict) + )) + + +(defun srecode-document-trim-whitespace (str) + "Strip stray whitespace from around STR." + (when (string-match "^\\(\\s-\\|\n\\)+" str) + (setq str (replace-match "" t t str))) + (when (string-match "\\(\\s-\\|\n\\)+$" str) + (setq str (replace-match "" t t str))) + str) + +;;;###autoload +(defun srecode-document-insert-function-comment (&optional fcn-in) + "Insert or replace a function comment. +FCN-IN is the Semantic tag of the function to add a comment too. +If FCN-IN is not provied, the current tag is used instead. +It is assumed that the comment occurs just in front of FCN-IN." + (interactive) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'document) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let* ((dict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) + "function-comment" + "declaration" + 'document))) + (if (not temp) + (error "No templates for inserting function comments")) + + ;; Try to figure out the tag we want to use. + (when (not fcn-in) + (semantic-fetch-tags) + (setq fcn-in (semantic-current-tag))) + + (when (or (not fcn-in) + (not (semantic-tag-of-class-p fcn-in 'function))) + (error "No tag of class 'function to insert comment for")) + + (if (not (eq (current-buffer) (semantic-tag-buffer fcn-in))) + (error "Only insert comments for tags in the current buffer")) + + ;; Find any existing doc strings. + (semantic-go-to-tag fcn-in) + (beginning-of-line) + (forward-char -1) + + (let ((lextok (semantic-documentation-comment-preceeding-tag fcn-in 'lex)) + (doctext + (srecode-document-function-name-comment fcn-in)) + ) + + (when lextok + (let* ((s (semantic-lex-token-start lextok)) + (e (semantic-lex-token-end lextok)) + (plaintext + (srecode-document-trim-whitespace + (save-excursion + (goto-char s) + (semantic-doc-snarf-comment-for-tag nil)))) + (extract (condition-case nil + (srecode-extract temp s e) + (error nil)) + ) + (distance (count-lines e (semantic-tag-start fcn-in))) + (belongelsewhere (save-excursion + (goto-char s) + (back-to-indentation) + (semantic-current-tag))) + ) + + (when (not belongelsewhere) + + (pulse-momentary-highlight-region s e) + + ;; There are many possible states that comment could be in. + ;; Take a guess about what the user would like to do, and ask + ;; the right kind of question. + (when (or (not (> distance 2)) + (y-or-n-p "Replace this comment? ")) + + (when (> distance 2) + (goto-char e) + (delete-horizontal-space) + (delete-blank-lines)) + + (cond + ((and plaintext (not extract)) + (if (y-or-n-p "Convert old-style comment to Template with old text? ") + (setq doctext plaintext)) + (delete-region s e) + (goto-char s)) + (extract + (when (y-or-n-p "Refresh pre-existing comment (recycle old doc)? ") + (delete-region s e) + (goto-char s) + (setq doctext + (srecode-document-trim-whitespace + (srecode-dictionary-lookup-name extract "DOC"))))) + )) + ))) + + (beginning-of-line) + + ;; Perform the insertion + (let ((srecode-semantic-selected-tag fcn-in) + (srecode-semantic-apply-tag-augment-hook + (lambda (tag dict) + (srecode-dictionary-set-value + dict "DOC" + (if (eq tag fcn-in) + doctext + (srecode-document-parameter-comment tag)) + ))) + ) + (srecode-insert-fcn temp dict) + )) + )) + +;;;###autoload +(defun srecode-document-insert-variable-one-line-comment (&optional var-in) + "Insert or replace a variable comment. +VAR-IN is the Semantic tag of the function to add a comment too. +If VAR-IN is not provied, the current tag is used instead. +It is assumed that the comment occurs just after VAR-IN." + (interactive) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'document) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let* ((dict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) + "variable-same-line-comment" + "declaration" + 'document))) + (if (not temp) + (error "No templates for inserting variable comments")) + + ;; Try to figure out the tag we want to use. + (when (not var-in) + (semantic-fetch-tags) + (setq var-in (semantic-current-tag))) + + (when (or (not var-in) + (not (semantic-tag-of-class-p var-in 'variable))) + (error "No tag of class 'variable to insert comment for")) + + (if (not (eq (current-buffer) (semantic-tag-buffer var-in))) + (error "Only insert comments for tags in the current buffer")) + + ;; Find any existing doc strings. + (goto-char (semantic-tag-end var-in)) + (skip-syntax-forward "-" (point-at-eol)) + (let ((lextok (semantic-doc-snarf-comment-for-tag 'lex)) + ) + + (when lextok + (let ((s (semantic-lex-token-start lextok)) + (e (semantic-lex-token-end lextok))) + + (pulse-momentary-highlight-region s e) + + (when (not (y-or-n-p "A comment already exists. Replace? ")) + (error "Quit")) + + ;; Extract text from the existing comment. + (srecode-extract temp s e) + + (delete-region s e) + (goto-char s) ;; To avoid adding a CR. + )) + ) + + ;; Clean up the end of the line and use handy comment-column. + (end-of-line) + (delete-horizontal-space) + (move-to-column comment-column t) + (when (< (point) (point-at-eol)) (end-of-line)) + + ;; Perform the insertion + (let ((srecode-semantic-selected-tag var-in) + (srecode-semantic-apply-tag-augment-hook + (lambda (tag dict) + (srecode-dictionary-set-value + dict "DOC" (srecode-document-parameter-comment + tag)))) + ) + (srecode-insert-fcn temp dict) + )) + ) + +;;;###autoload +(defun srecode-document-insert-group-comments (beg end) + "Insert group comments around the active between BEG and END. +If the region includes only parts of some tags, expand out +to the beginning and end of the tags on the region. +If there is only one tag in the region, complain." + (interactive "r") + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'document) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let* ((dict (srecode-create-dictionary)) + (context "declaration") + (temp-start nil) + (temp-end nil) + (tag-start (save-excursion + (goto-char beg) + (or (semantic-current-tag) + (semantic-find-tag-by-overlay-next)))) + (tag-end (save-excursion + (goto-char end) + (or (semantic-current-tag) + (semantic-find-tag-by-overlay-prev)))) + (parent-tag nil) + (first-pos beg) + (second-pos end) + ) + + ;; If beg/end wrapped nothing, then tag-start,end would actually + ;; point at some odd stuff that is out of order. + (when (or (not tag-start) (not tag-end) + (> (semantic-tag-end tag-start) + (semantic-tag-start tag-end))) + (setq tag-start nil + tag-end nil)) + + (when tag-start + ;; If tag-start and -end are the same, and it is a class or + ;; struct, try to find child tags inside the classdecl. + (cond + ((and (eq tag-start tag-end) + tag-start + (semantic-tag-of-class-p tag-start 'type)) + (setq parent-tag tag-start) + (setq tag-start (semantic-find-tag-by-overlay-next beg) + tag-end (semantic-find-tag-by-overlay-prev end)) + ) + ((eq (semantic-find-tag-parent-by-overlay tag-start) tag-end) + (setq parent-tag tag-end) + (setq tag-end (semantic-find-tag-by-overlay-prev end)) + ) + ((eq tag-start (semantic-find-tag-parent-by-overlay tag-end)) + (setq parent-tag tag-start) + (setq tag-start (semantic-find-tag-by-overlay-next beg)) + ) + ) + + (when parent-tag + ;; We are probably in a classdecl + ;; @todo -could I really use (srecode-calculate-context) ? + + (setq context "classdecl") + ) + + ;; Derive start and end locations based on the tags. + (setq first-pos (semantic-tag-start tag-start) + second-pos (semantic-tag-end tag-end)) + ) + ;; Now load the templates + (setq temp-start (srecode-template-get-table (srecode-table) + "group-comment-start" + context + 'document) + temp-end (srecode-template-get-table (srecode-table) + "group-comment-end" + context + 'document)) + + (when (or (not temp-start) (not temp-end)) + (error "No templates for inserting group comments")) + + ;; Setup the name of this group ahead of time. + + ;; @todo - guess at a name based on common strings + ;; of the tags in the group. + (srecode-dictionary-set-value + dict "GROUPNAME" + (read-string "Name of group: ")) + + ;; Perform the insertion + ;; Do the end first so we don't need to recalculate anything. + ;; + (goto-char second-pos) + (end-of-line) + (srecode-insert-fcn temp-end dict) + + (goto-char first-pos) + (beginning-of-line) + (srecode-insert-fcn temp-start dict) + + )) + + +;;; Document Generation Functions +;; +;; Routines for making up English style comments. + +(defun srecode-document-function-name-comment (tag) + "Create documentation for the function defined in TAG. +If we can identify a verb in the list followed by some +name part then check the return value to see if we can use that to +finish off the sentence. ie. any function with 'alloc' in it will be +allocating something based on its type." + (let ((al srecode-document-autocomment-return-first-alist) + (dropit nil) + (tailit nil) + (news "") + (fname (semantic-tag-name tag)) + (retval (or (semantic-tag-type tag) ""))) + (if (listp retval) + ;; convert a type list into a long string to analyze. + (setq retval (car retval))) + ;; check for modifiers like static + (while al + (if (string-match (car (car al)) (downcase retval)) + (progn + (setq news (concat news (cdr (car al)))) + (setq dropit t) + (setq al nil))) + (setq al (cdr al))) + ;; check for verb parts! + (setq al srecode-document-autocomment-function-alist) + (while al + (if (string-match (car (car al)) (downcase fname)) + (progn + (setq news + (concat news (if dropit (downcase (cdr (car al))) + (cdr (car al))))) + ;; if we end in a space, then we are expecting a potential + ;; return value. + (if (= ? (aref news (1- (length news)))) + (setq tailit t)) + (setq al nil))) + (setq al (cdr al))) + ;; check for noun parts! + (setq al srecode-document-autocomment-common-nouns-abbrevs) + (while al + (if (string-match (car (car al)) (downcase fname)) + (progn + (setq news + (concat news (if dropit (downcase (cdr (car al))) + (cdr (car al))))) + (setq al nil))) + (setq al (cdr al))) + ;; add tailers to names which are obviously returning something. + (if tailit + (progn + (setq al srecode-document-autocomment-return-last-alist) + (while al + (if (string-match (car (car al)) (downcase retval)) + (progn + (setq news + (concat news " " + ;; this one may use parts of the return value. + (format (cdr (car al)) + (srecode-document-programmer->english + (substring retval (match-beginning 1) + (match-end 1)))))) + (setq al nil))) + (setq al (cdr al))))) + news)) + +(defun srecode-document-parameter-comment (param &optional commentlist) + "Convert tag or string PARAM into a name,comment pair. +Optional COMMENTLIST is list of previously existing comments to +use instead in alist form. If the name doesn't appear in the list of +standard names, then englishify it instead." + (let ((cmt "") + (aso srecode-document-autocomment-param-alist) + (fnd nil) + (name (if (stringp param) param (semantic-tag-name param))) + (tt (if (stringp param) nil (semantic-tag-type param)))) + ;; Make sure the type is a string. + (if (listp tt) + (setq tt (semantic-tag-name tt))) + ;; Find name description parts. + (while aso + (if (string-match (car (car aso)) name) + (progn + (setq fnd t) + (setq cmt (concat cmt (cdr (car aso)))))) + (setq aso (cdr aso))) + (if (/= (length cmt) 0) + nil + ;; finally check for array parts + (if (and (not (stringp param)) (semantic-tag-modifiers param)) + (setq cmt (concat cmt "array of "))) + (setq aso srecode-document-autocomment-param-type-alist) + (while (and aso tt) + (if (string-match (car (car aso)) tt) + (setq cmt (concat cmt (cdr (car aso))))) + (setq aso (cdr aso)))) + ;; Convert from programmer to english. + (if (not fnd) + (setq cmt (concat cmt " " + (srecode-document-programmer->english name)))) + cmt)) + +(defun srecode-document-programmer->english (programmer) + "Take PROGRAMMER and convert it into English. +Works with the following rules: + 1) convert all _ into spaces. + 2) inserts spaces between CamelCasing word breaks. + 3) expands noun names based on common programmer nouns. + + This function is designed for variables, not functions. This does +not account for verb parts." + (if (string= "" programmer) + "" + (let ((ind 0) ;index in string + (llow nil) ;lower/upper case flag + (newstr nil) ;new string being generated + (al nil)) ;autocomment list + ;; + ;; 1) Convert underscores + ;; + (while (< ind (length programmer)) + (setq newstr (concat newstr + (if (= (aref programmer ind) ?_) + " " (char-to-string (aref programmer ind))))) + (setq ind (1+ ind))) + (setq programmer newstr + newstr nil + ind 0) + ;; + ;; 2) Find word breaks between case changes + ;; + (while (< ind (length programmer)) + (setq newstr + (concat newstr + (let ((tc (aref programmer ind))) + (if (and (>= tc ?a) (<= tc ?z)) + (progn + (setq llow t) + (char-to-string tc)) + (if llow + (progn + (setq llow nil) + (concat " " (char-to-string tc))) + (char-to-string tc)))))) + (setq ind (1+ ind))) + ;; + ;; 3) Expand the words if possible + ;; + (setq llow nil + ind 0 + programmer newstr + newstr nil) + (while (string-match (concat "^\\s-*\\([^ \t\n]+\\)") programmer) + (let ((ts (substring programmer (match-beginning 1) (match-end 1))) + (end (match-end 1))) + (setq al srecode-document-autocomment-common-nouns-abbrevs) + (setq llow nil) + (while al + (if (string-match (car (car al)) (downcase ts)) + (progn + (setq newstr (concat newstr (cdr (car al)))) + ;; don't terminate because we may actuall have 2 words + ;; next to eachother we didn't identify before + (setq llow t))) + (setq al (cdr al))) + (if (not llow) (setq newstr (concat newstr ts))) + (setq newstr (concat newstr " ")) + (setq programmer (substring programmer end)))) + newstr))) + +;;; UTILS +;; +(defun srecode-document-one-line-tag-p (tag) + "Does TAG fit on one line with space on the end?" + (save-excursion + (semantic-go-to-tag tag) + (and (<= (semantic-tag-end tag) (point-at-eol)) + (goto-char (semantic-tag-end tag)) + (< (current-column) 70)))) + +(provide 'srecode/document) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/document" +;; End: + +;;; srecode/document.el ends here diff --git a/lisp/cedet/srecode/el.el b/lisp/cedet/srecode/el.el new file mode 100644 index 00000000000..3df606a59c5 --- /dev/null +++ b/lisp/cedet/srecode/el.el @@ -0,0 +1,113 @@ +;;; srecode/el.el --- Emacs Lisp specific arguments + +;; Copyright (C) 2008 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Emacs Lisp specific handlers. To use these handlers in your +;; template, add the :name part to your template argument list. +;; +;; Error if not in a Emacs Lisp mode + +;;; Code: + +(require 'srecode) +(require 'srecode/semantic) + +(declare-function semanticdb-brute-find-tags-by-class "semantic/db-find") + +;;;###autoload +(defun srecode-semantic-handle-:el (dict) + "Add macros into the dictionary DICT based on the current Emacs Lisp file. +Adds the following: + PRENAME - The common name prefix of this file." + (let* ((names (append (semantic-find-tags-by-class 'function (current-buffer)) + (semantic-find-tags-by-class 'variable (current-buffer))) + ) + (common (try-completion "" names))) + + (srecode-dictionary-set-value dict "PRENAME" common) + )) + +;;;###autoload +(defun srecode-semantic-handle-:el-custom (dict) + "Add macros into the dictionary DICT based on the current Emacs Lisp file. +Adds the following: + GROUP - The 'defgroup' name we guess you want for variables. + FACEGROUP - The `defgroup' name you might want for faces." + (require 'semantic/db-find) + (let ((groups (semanticdb-strip-find-results + (semanticdb-brute-find-tags-by-class 'customgroup))) + (varg nil) + (faceg nil) + ) + + ;; Pick the best group + (while groups + (cond ((string-match "face" (semantic-tag-name (car groups))) + (setq faceg (car groups))) + ((not varg) + (setq varg (car groups))) + (t + ;; What about other groups? + )) + (setq groups (cdr groups))) + + ;; Double check the facegroup. + (setq faceg (or faceg varg)) + + ;; Setup some variables + (srecode-dictionary-set-value dict "GROUP" (semantic-tag-name varg)) + (srecode-dictionary-set-value dict "FACEGROUP" (semantic-tag-name faceg)) + + )) + +(define-mode-local-override srecode-semantic-apply-tag-to-dict + emacs-lisp-mode (tagobj dict) + "Apply Emacs Lisp specific features from TAGOBJ into DICT. +Calls `srecode-semantic-apply-tag-to-dict-default' first." + (srecode-semantic-apply-tag-to-dict-default tagobj dict) + + ;; Pull out the tag for the individual pieces. + (let* ((tag (oref tagobj :prime)) + (doc (semantic-tag-docstring tag))) + + ;; It is much more common to have doc on ELisp. + (srecode-dictionary-set-value dict "DOC" doc) + + (cond + ;; + ;; FUNCTION + ;; + ((eq (semantic-tag-class tag) 'function) + (if (semantic-tag-get-attribute tag :user-visible-flag) + (srecode-dictionary-set-value dict "INTERACTIVE" " (interactive)\n ") + (srecode-dictionary-set-value dict "INTERACTIVE" "")))))) + + +(provide 'srecode/el) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/el" +;; End: + +;;; srecode/el.el ends here diff --git a/lisp/cedet/srecode/expandproto.el b/lisp/cedet/srecode/expandproto.el new file mode 100644 index 00000000000..a0c8ec62816 --- /dev/null +++ b/lisp/cedet/srecode/expandproto.el @@ -0,0 +1,133 @@ +;;; srecode/expandproto.el --- Expanding prototypes. + +;; Copyright (C) 2007 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Methods for expanding a prototype into an implementation. + +(require 'ring) +(require 'semantic) +(require 'semantic/analyze) +(require 'semantic/senator) +(require 'srecode/insert) +(require 'srecode/dictionary) + +(declare-function semantic-brute-find-tag-by-attribute-value "semantic/find") + +;;; Code: +(defcustom srecode-expandproto-template-file-alist + '( ( c++-mode . "srecode-expandproto-cpp.srt" ) + ) + ;; @todo - Make this variable auto-generated from the Makefile. + "Associate template files for expanding prototypes to a major mode." + :group 'srecode + :type '(repeat (cons (sexp :tag "Mode") + (sexp :tag "Filename")) + )) + +;;;###autoload +(defun srecode-insert-prototype-expansion () + "Insert get/set methods for the current class." + (interactive) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode + srecode-expandproto-template-file-alist) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (let ((proto + ;; Step 1: Find the prototype, or prototype list to expand. + (srecode-find-prototype-for-expansion))) + + (if (not proto) + (error "Could not find prototype to expand")) + + ;; Step 2: Insert implementations of the prototypes. + + + )) + +(defun srecode-find-prototype-for-expansion () + "Find a prototype to use for expanding into an implementation." + ;; We may find a prototype tag in one of several places. + ;; Search in order of logical priority. + (let ((proto nil) + ) + + ;; 1) A class full of prototypes under point. + (let ((tag (semantic-current-tag))) + (when tag + (when (not (semantic-tag-of-class-p tag 'type)) + (setq tag (semantic-current-tag-parent)))) + (when (and tag (semantic-tag-of-class-p tag 'type)) + ;; If the current class has prototype members, then + ;; we will do the whole class! + (require 'semantic/find) + (if (semantic-brute-find-tag-by-attribute-value + :prototype t + (semantic-tag-type-members tag)) + (setq proto tag))) + ) + + ;; 2) A prototype under point. + (when (not proto) + (let ((tag (semantic-current-tag))) + (when (and tag + (and + (semantic-tag-of-class-p tag 'function) + (semantic-tag-get-attribute tag :prototype))) + (setq proto tag)))) + + ;; 3) A tag in the kill ring that is a prototype + (when (not proto) + (if (ring-empty-p senator-tag-ring) + nil ;; Not for us. + (let ((tag (ring-ref senator-tag-ring 0)) + ) + (when + (and tag + (or + (and + (semantic-tag-of-class-p tag 'function) + (semantic-tag-get-attribute tag :prototype)) + (and + (semantic-tag-of-class-p tag 'type) + (require 'semantic/find) + (semantic-brute-find-tag-by-attribute-value + :prototype t + (semantic-tag-type-members tag)))) + ) + (setq proto tag)) + ))) + + proto)) + +(provide 'srecode-expandproto) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/expandproto" +;; End: + +;;; srecode/expandproto.el ends here diff --git a/lisp/cedet/srecode/extract.el b/lisp/cedet/srecode/extract.el new file mode 100644 index 00000000000..c6de1e1faaa --- /dev/null +++ b/lisp/cedet/srecode/extract.el @@ -0,0 +1,242 @@ +;;; srecode/extract.el --- Extract content from previously inserted macro. + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Extract content from a previously inserted macro. +;; +;; The extraction routines can be handy if you want to extract users +;; added text from the middle of a template inserted block of text. +;; This code will not work for all templates. It will only work for +;; templates with unique static text between all the different insert +;; macros. +;; +;; That said, it will handle include and section templates, so complex +;; or deep template calls can be extracted. +;; +;; This code was specifically written for srecode-document, which +;; wants to extract user written text, and re-use it in a reformatted +;; comment. + +(require 'srecode) +(require 'srecode/compile) +(require 'srecode/insert) + +;;; Code: + +(defclass srecode-extract-state () + ((anchor :initform nil + :documentation + "The last known plain-text end location.") + (lastinserter :initform nil + :documentation + "The last inserter with 'later extraction type.") + (lastdict :initform nil + :documentation + "The dictionary associated with lastinserter.") + ) + "The current extraction state.") + +(defmethod srecode-extract-state-set ((st srecode-extract-state) ins dict) + "Set onto the extract state ST a new inserter INS and dictinary DICT." + (oset st lastinserter ins) + (oset st lastdict dict)) + +(defmethod srecode-extract-state-set-anchor ((st srecode-extract-state)) + "Reset the achor point on extract state ST." + (oset st anchor (point))) + +(defmethod srecode-extract-state-extract ((st srecode-extract-state) + endpoint) + "Perform an extraction on the extract state ST with ENDPOITNT. +If there was no waiting inserter, do nothing." + (when (oref st lastinserter) + (save-match-data + (srecode-inserter-extract (oref st lastinserter) + (oref st anchor) + endpoint + (oref st lastdict) + st)) + ;; Clear state. + (srecode-extract-state-set st nil nil))) + +;;; Extraction +;l +(defun srecode-extract (template start end) + "Extract TEMPLATE from between START and END in the current buffer. +Uses TEMPLATE's constant strings to break up the text and guess what +the dictionary entries were for that block of text." + (save-excursion + (save-restriction + (narrow-to-region start end) + (let ((dict (srecode-create-dictionary t)) + (state (srecode-extract-state "state")) + ) + (goto-char start) + (srecode-extract-method template dict state) + dict)))) + +(defmethod srecode-extract-method ((st srecode-template) dictionary + state) + "Extract template ST and store extracted text in DICTIONARY. +Optional STARTRETURN is a symbol in which the start of the first +plain-text match occured." + (srecode-extract-code-stream (oref st code) dictionary state)) + +(defun srecode-extract-code-stream (code dictionary state) + "Extract CODE from buffer text into DICTIONARY. +Uses string constants in CODE to split up the buffer. +Uses STATE to maintain the current extraction state." + (while code + (cond + + ;; constant strings need mark the end of old inserters that + ;; need to extract values, or are just there. + ((stringp (car code)) + (srecode-extract-state-set-anchor state) + ;; When we have a string, find it in the collection, then extract + ;; that start point as the end point of the inserter + (unless (re-search-forward (regexp-quote (car code)) + (point-max) t) + (error "Unable to extract all dictionary entries")) + + (srecode-extract-state-extract state (match-beginning 0)) + (goto-char (match-end 0)) + ) + + ;; Some inserters are simple, and need to be extracted after + ;; we find our next block of static text. + ((eq (srecode-inserter-do-extract-p (car code)) 'later) + (srecode-extract-state-set state (car code) dictionary) + ) + + ;; Some inserter want to start extraction now, such as sections. + ;; We can't predict the end point till we parse out the middle. + ((eq (srecode-inserter-do-extract-p (car code)) 'now) + (srecode-extract-state-set-anchor state) + (srecode-inserter-extract (car code) (point) nil dictionary state)) + ) + (setq code (cdr code)) + )) + +;;; Inserter Base Extractors +;; +(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter)) + "Return non-nil if this inserter can extract values." + nil) + +(defmethod srecode-inserter-extract ((ins srecode-template-inserter) + start end dict state) + "Extract text from START/END and store in DICT. +Return nil as this inserter will extract nothing." + nil) + +;;; Variable extractor is simple and can extract later. +;; +(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-variable)) + "Return non-nil if this inserter can extract values." + 'later) + +(defmethod srecode-inserter-extract ((ins srecode-template-inserter-variable) + start end vdict state) + "Extract text from START/END and store in VDICT. +Return t if something was extracted. +Return nil if this inserter doesn't need to extract anything." + (srecode-dictionary-set-value vdict + (oref ins :object-name) + (buffer-substring-no-properties + start end) + ) + t) + +;;; Section Inserter +;; +(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-section-start)) + "Return non-nil if this inserter can extract values." + 'now) + +(defmethod srecode-inserter-extract ((ins srecode-template-inserter-section-start) + start end indict state) + "Extract text from START/END and store in INDICT. +Return the starting location of the first plain-text match. +Return nil if nothing was extracted." + (let ((name (oref ins :object-name)) + (subdict (srecode-create-dictionary indict)) + (allsubdict nil) + ) + + ;; Keep extracting till we can extract no more. + (while (condition-case nil + (progn + (srecode-extract-method + (oref ins template) subdict state) + t) + (error nil)) + + ;; Success means keep this subdict, and also make a new one for + ;; the next iteration. + (setq allsubdict (cons subdict allsubdict)) + (setq subdict (srecode-create-dictionary indict)) + ) + + (srecode-dictionary-set-value indict name (nreverse allsubdict)) + + nil)) + +;;; Include Extractor must extract now. +;; +(defmethod srecode-inserter-do-extract-p ((ins srecode-template-inserter-include)) + "Return non-nil if this inserter can extract values." + 'now) + +(defmethod srecode-inserter-extract ((ins srecode-template-inserter-include) + start end dict state) + "Extract text from START/END and store in DICT. +Return the starting location of the first plain-text match. +Return nil if nothing was extracted." + (goto-char start) + (srecode-insert-include-lookup ins dict) + ;; There are two modes for includes. One is with no dict, + ;; so it is inserted straight. If the dict has a name, then + ;; we need to run once per dictionary occurance. + (if (not (string= (oref ins :object-name) "")) + ;; With a name, do the insertion. + (let ((subdict (srecode-dictionary-add-section-dictionary + dict (oref ins :object-name)))) + (error "Need to implement include w/ name extractor.") + ;; Recurse into the new template while no errors. + (while (condition-case nil + (progn + (srecode-extract-method + (oref ins includedtemplate) subdict + state) + t) + (error nil)))) + + ;; No stream, do the extraction into the current dictionary. + (srecode-extract-method (oref ins includedtemplate) dict + state)) + ) + + +(provide 'srecode/extract) + +;;; srecode/extract.el ends here diff --git a/lisp/cedet/srecode/fields.el b/lisp/cedet/srecode/fields.el new file mode 100644 index 00000000000..f335b0fef79 --- /dev/null +++ b/lisp/cedet/srecode/fields.el @@ -0,0 +1,438 @@ +;;; srecode/fields.el --- Handling type-in fields in a buffer. +;; +;; Copyright (C) 2009 Free Software Foundation, Inc. +;; +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Idea courtesy of yasnippets. +;; +;; If someone prefers not to type unknown dictionary entries into +;; mini-buffer prompts, it could instead use in-buffer fields. +;; +;; A template-region specifies an area in which the fields exist. If +;; the cursor exits the region, all fields are cleared. +;; +;; Each field is independent, but some are linked together by name. +;; Typing in one will cause the matching ones to change in step. +;; +;; Each field has 2 overlays. The second overlay allows control in +;; the character just after the field, but does not highlight it. + +;; Keep this library independent of SRecode proper. +(require 'eieio) + +;;; Code: +(defvar srecode-field-archive nil + "While inserting a set of fields, collect in this variable. +Once an insertion set is done, these fields will be activated.") + +(defface srecode-field-face + '((((class color) (background dark)) + (:underline "green")) + (((class color) (background light)) + (:underline "green4"))) + "*Face used to specify editable fields from a template." + :group 'semantic-faces) + +;;; BASECLASS +;; +;; Fields and the template region share some basic overlay features. + +(defclass srecode-overlaid () + ((overlay :documentation + "Overlay representing this field. +The overlay will crossreference this object.") + ) + "An object that gets automatically bound to an overlay. +Has virtual :start and :end initializers.") + +(defmethod initialize-instance ((olaid srecode-overlaid) &optional args) + "Initialize OLAID, being sure it archived." + ;; Extract :start and :end from the olaid list. + (let ((newargs nil) + (olay nil) + start end + ) + + (while args + (cond ((eq (car args) :start) + (setq args (cdr args)) + (setq start (car args)) + (setq args (cdr args)) + ) + ((eq (car args) :end) + (setq args (cdr args)) + (setq end (car args)) + (setq args (cdr args)) + ) + (t + (push (car args) newargs) + (setq args (cdr args)) + (push (car args) newargs) + (setq args (cdr args))) + )) + + ;; Create a temporary overlay now. We have to use an overlay and + ;; not a marker becaues of the in-front insertion rules. The rules + ;; are backward from what is wanted while typing. + (setq olay (make-overlay start end (current-buffer) t nil)) + (overlay-put olay 'srecode-init-only t) + + (oset olaid overlay olay) + (call-next-method olaid (nreverse newargs)) + + )) + +(defmethod srecode-overlaid-activate ((olaid srecode-overlaid)) + "Activate the overlaid area." + (let* ((ola (oref olaid overlay)) + (start (overlay-start ola)) + (end (overlay-end ola)) + ;; Create a new overlay here. + (ol (make-overlay start end (current-buffer) nil t))) + + ;; Remove the old one. + (delete-overlay ola) + + (overlay-put ol 'srecode olaid) + + (oset olaid overlay ol) + + )) + +(defmethod srecode-delete ((olaid srecode-overlaid)) + "Delete the overlay from OLAID." + (delete-overlay (oref olaid overlay)) + (slot-makeunbound olaid 'overlay) + ) + +(defmethod srecode-empty-region-p ((olaid srecode-overlaid)) + "Return non-nil if the region covered by OLAID is of length 0." + (= 0 (srecode-region-size olaid))) + +(defmethod srecode-region-size ((olaid srecode-overlaid)) + "Return the length of region covered by OLAID." + (let ((start (overlay-start (oref olaid overlay))) + (end (overlay-end (oref olaid overlay)))) + (- end start))) + +(defmethod srecode-point-in-region-p ((olaid srecode-overlaid)) + "Return non-nil if point is in the region of OLAID." + (let ((start (overlay-start (oref olaid overlay))) + (end (overlay-end (oref olaid overlay)))) + (and (>= (point) start) (<= (point) end)))) + +(defun srecode-overlaid-at-point (class) + "Return a list of overlaid fields of type CLASS at point." + (let ((ol (overlays-at (point))) + (ret nil)) + (while ol + (let ((tmp (overlay-get (car ol) 'srecode))) + (when (and tmp (object-of-class-p tmp class)) + (setq ret (cons tmp ret)))) + (setq ol (cdr ol))) + (car (nreverse ret)))) + +(defmethod srecode-overlaid-text ((olaid srecode-overlaid) &optional set-to) + "Return the text under OLAID. +If SET-TO is a string, then replace the text of OLAID wit SET-TO." + (let* ((ol (oref olaid overlay)) + (start (overlay-start ol))) + (if (not (stringp set-to)) + ;; Just return it. + (buffer-substring-no-properties start (overlay-end ol)) + ;; Replace it. + (save-excursion + (delete-region start (overlay-end ol)) + (goto-char start) + (insert set-to) + (move-overlay ol start (+ start (length set-to)))) + nil))) + +;;; INSERTED REGION +;; +;; Managing point-exit, and flushing fields. + +(defclass srecode-template-inserted-region (srecode-overlaid) + ((fields :documentation + "A list of field overlays in this region.") + (active-region :allocation :class + :initform nil + :documentation + "The template region currently being handled.") + ) + "Manage a buffer region in which fields exist.") + +(defmethod initialize-instance ((ir srecode-template-inserted-region) + &rest args) + "Initialize IR, capturing the active fields, and creating the overlay." + ;; Fill in the fields + (oset ir fields srecode-field-archive) + (setq srecode-field-archive nil) + + ;; Initailize myself first. + (call-next-method) + ) + +(defmethod srecode-overlaid-activate ((ir srecode-template-inserted-region)) + "Activate the template area for IR." + ;; Activate all our fields + + (dolist (F (oref ir fields)) + (srecode-overlaid-activate F)) + + ;; Activate our overlay. + (call-next-method) + + ;; Position the cursor at the first field + (let ((first (car (oref ir fields)))) + (goto-char (overlay-start (oref first overlay)))) + + ;; Set ourselves up as 'active' + (oset ir active-region ir) + + ;; Setup the post command hook. + (add-hook 'post-command-hook 'srecode-field-post-command t t) + ) + +(defmethod srecode-delete ((ir srecode-template-inserted-region)) + "Call into our base, but also clear out the fields." + ;; Clear us out of the baseclass. + (oset ir active-region nil) + ;; Clear our fields. + (mapc 'srecode-delete (oref ir fields)) + ;; Call to our base + (call-next-method) + ;; Clear our hook. + (remove-hook 'post-command-hook 'srecode-field-post-command t) + ) + +(defsubst srecode-active-template-region () + "Return the active region for template fields." + (oref srecode-template-inserted-region active-region)) + +(defun srecode-field-post-command () + "Srecode field handler in the post command hook." + (let ((ar (srecode-active-template-region)) + ) + (if (not ar) + ;; Find a bug and fix it. + (remove-hook 'post-command-hook 'srecode-field-post-command t) + (if (srecode-point-in-region-p ar) + nil ;; Keep going + ;; We moved out of the temlate. Cancel the edits. + (srecode-delete ar))) + )) + +;;; FIELDS + +(defclass srecode-field (srecode-overlaid) + ((tail :documentation + "Overlay used on character just after this field. +Used to provide useful keybindings there.") + (name :initarg :name + :documentation + "The name of this field. +Usually initialized from the dictionary entry name that +the users needs to edit.") + (prompt :initarg :prompt + :documentation + "A prompt string to use if this were in the minibuffer. +Display when the cursor enters this field.") + (read-fcn :initarg :read-fcn + :documentation + "A function that would be used to read a string. +Try to use this to provide useful completion when available.") + ) + "Representation of one field.") + +(defvar srecode-field-keymap + (let ((km (make-sparse-keymap))) + (define-key km "\C-i" 'srecode-field-next) + (define-key km "\M-\C-i" 'srecode-field-prev) + (define-key km "\C-e" 'srecode-field-end) + (define-key km "\C-a" 'srecode-field-start) + (define-key km "\M-m" 'srecode-field-start) + (define-key km "\C-c\C-c" 'srecode-field-exit-ask) + km) + "Keymap applied to field overlays.") + +(defmethod initialize-instance ((field srecode-field) &optional args) + "Initialize FIELD, being sure it archived." + (add-to-list 'srecode-field-archive field t) + (call-next-method) + ) + +(defmethod srecode-overlaid-activate ((field srecode-field)) + "Activate the FIELD area." + (call-next-method) + + (let* ((ol (oref field overlay)) + (end nil) + (tail nil)) + (overlay-put ol 'face 'srecode-field-face) + (overlay-put ol 'keymap srecode-field-keymap) + (overlay-put ol 'modification-hooks '(srecode-field-mod-hook)) + (overlay-put ol 'insert-behind-hooks '(srecode-field-behind-hook)) + (overlay-put ol 'insert-in-front-hooks '(srecode-field-mod-hook)) + + (setq end (overlay-end ol)) + (setq tail (make-overlay end (+ end 1) (current-buffer))) + + (overlay-put tail 'srecode field) + (overlay-put tail 'keymap srecode-field-keymap) + (overlay-put tail 'face 'srecode-field-face) + (oset field tail tail) + ) + ) + +(defmethod srecode-delete ((olaid srecode-field)) + "Delete our secondary overlay." + ;; Remove our spare overlay + (delete-overlay (oref olaid tail)) + (slot-makeunbound olaid 'tail) + ;; Do our baseclass work. + (call-next-method) + ) + +(defvar srecode-field-replication-max-size 100 + "Maximum size of a field before cancelling replication.") + +(defun srecode-field-mod-hook (ol after start end &optional pre-len) + "Modification hook for the field overlay. +OL is the overlay. +AFTER is non-nil if it is called after the change. +START and END are the bounds of the change. +PRE-LEN is used in the after mode for the length of the changed text." + (when (and after (not undo-in-progress)) + (let* ((field (overlay-get ol 'srecode)) + (inhibit-point-motion-hooks t) + (inhibit-modification-hooks t) + ) + ;; Sometimes a field is deleted, but we might still get a stray + ;; event. Lets just ignore those events. + (when (slot-boundp field 'overlay) + ;; First, fixup the two overlays, in case they got confused. + (let ((main (oref field overlay)) + (tail (oref field tail))) + (move-overlay main + (overlay-start main) + (1- (overlay-end tail))) + (move-overlay tail + (1- (overlay-end tail)) + (overlay-end tail))) + ;; Now capture text from the main overlay, and propagate it. + (let* ((new-text (srecode-overlaid-text field)) + (region (srecode-active-template-region)) + (allfields (when region (oref region fields))) + (name (oref field name))) + (dolist (F allfields) + (when (and (not (eq F field)) + (string= name (oref F name))) + (if (> (length new-text) srecode-field-replication-max-size) + (message "Field size too large for replication.") + ;; If we find other fields with the same name, then keep + ;; then all together. Disable change hooks to make sure + ;; we don't get a recursive edit. + (srecode-overlaid-text F new-text) + )))) + )))) + +(defun srecode-field-behind-hook (ol after start end &optional pre-len) + "Modification hook for the field overlay. +OL is the overlay. +AFTER is non-nil if it is called after the change. +START and END are the bounds of the change. +PRE-LEN is used in the after mode for the length of the changed text." + (when after + (let* ((field (overlay-get ol 'srecode)) + ) + (move-overlay ol (overlay-start ol) end) + (srecode-field-mod-hook ol after start end pre-len)) + )) + +(defmethod srecode-field-goto ((field srecode-field)) + "Goto the FIELD." + (goto-char (overlay-start (oref field overlay)))) + +(defun srecode-field-next () + "Move to the next field." + (interactive) + (let* ((f (srecode-overlaid-at-point 'srecode-field)) + (tr (srecode-overlaid-at-point 'srecode-template-inserted-region)) + ) + (when (not f) (error "Not in a field")) + (when (not tr) (error "Not in a template region")) + + (let ((fields (oref tr fields))) + (while fields + ;; Loop over fields till we match. Then move to the next one. + (when (eq f (car fields)) + (if (cdr fields) + (srecode-field-goto (car (cdr fields))) + (srecode-field-goto (car (oref tr fields)))) + (setq fields nil) + ) + (setq fields (cdr fields)))) + )) + +(defun srecode-field-prev () + "Move to the prev field." + (interactive) + (let* ((f (srecode-overlaid-at-point 'srecode-field)) + (tr (srecode-overlaid-at-point 'srecode-template-inserted-region)) + ) + (when (not f) (error "Not in a field")) + (when (not tr) (error "Not in a template region")) + + (let ((fields (reverse (oref tr fields)))) + (while fields + ;; Loop over fields till we match. Then move to the next one. + (when (eq f (car fields)) + (if (cdr fields) + (srecode-field-goto (car (cdr fields))) + (srecode-field-goto (car (oref tr fields)))) + (setq fields nil) + ) + (setq fields (cdr fields)))) + )) + +(defun srecode-field-end () + "Move to the end of this field." + (interactive) + (let* ((f (srecode-overlaid-at-point 'srecode-field))) + (goto-char (overlay-end (oref f overlay))))) + +(defun srecode-field-start () + "Move to the end of this field." + (interactive) + (let* ((f (srecode-overlaid-at-point 'srecode-field))) + (goto-char (overlay-start (oref f overlay))))) + +(defun srecode-field-exit-ask () + "Ask if the user wants to exit field-editing mini-mode." + (interactive) + (when (y-or-n-p "Exit field-editing mode? ") + (srecode-delete (srecode-active-template-region)))) + + +(provide 'srecode/fields) + +;;; srecode/fields.el ends here diff --git a/lisp/cedet/srecode/filters.el b/lisp/cedet/srecode/filters.el new file mode 100644 index 00000000000..1e3582f46fb --- /dev/null +++ b/lisp/cedet/srecode/filters.el @@ -0,0 +1,56 @@ +;;; srecode/filters.el --- Filters for use in template variables. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Various useful srecoder template functions. + +;;; Code: + +(require 'newcomment) +(require 'srecode/table) +(require 'srecode/insert) + +(defun srecode-comment-prefix (str) + "Prefix each line of STR with the comment prefix characters." + (let* ((dict srecode-inserter-variable-current-dictionary) + ;; Derive the comment characters to put in front of each line. + (cs (or (and dict + (srecode-dictionary-lookup-name dict "comment_prefix")) + (and comment-multi-line comment-continue) + (and (not comment-multi-line) comment-start))) + (strs (split-string str "\n")) + (newstr "") + ) + (while strs + (cond ((and (not comment-multi-line) (string= (car strs) "")) + ; (setq newstr (concat newstr "\n"))) + ) + (t + (setq newstr (concat newstr cs " " (car strs))))) + (setq strs (cdr strs)) + (when strs (setq newstr (concat newstr "\n")))) + newstr)) + +(provide 'srecode/filters) + +;;; srecode/filters.el ends here + diff --git a/lisp/cedet/srecode/find.el b/lisp/cedet/srecode/find.el new file mode 100644 index 00000000000..aecba0a2ec3 --- /dev/null +++ b/lisp/cedet/srecode/find.el @@ -0,0 +1,261 @@ +;;;; srecode/find.el --- Tools for finding templates in the database. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Various routines that search through various template tables +;; in search of the right template. + +(require 'srecode/ctxt) +(require 'srecode/table) +(require 'srecode/map) + +(declare-function srecode-compile-file "srecode/compile") + +;;; Code: + +(defun srecode-table (&optional mode) + "Return the currently active Semantic Recoder table for this buffer. +Optional argument MODE specifies the mode table to use." + (let* ((modeq (or mode major-mode)) + (table (srecode-get-mode-table modeq))) + + ;; If there isn't one, keep searching backwards for a table. + (while (and (not table) (setq modeq (get-mode-local-parent modeq))) + (setq table (srecode-get-mode-table modeq))) + + ;; Last ditch effort. + (when (not table) + (setq table (srecode-get-mode-table 'default))) + + table)) + +;;; TRACKER +;; +;; Template file tracker for between sessions. +;; +(defun srecode-load-tables-for-mode (mmode &optional appname) + "Load all the template files for MMODE. +Templates are found in the SRecode Template Map. +See `srecode-get-maps' for more. +APPNAME is the name of an application. In this case, +all template files for that application will be loaded." + (require 'srecode/compile) + (let ((files + (if appname + (apply 'append + (mapcar + (lambda (map) + (srecode-map-entries-for-app-and-mode map appname mmode)) + (srecode-get-maps))) + (apply 'append + (mapcar + (lambda (map) + (srecode-map-entries-for-mode map mmode)) + (srecode-get-maps))))) + ) + ;; Don't recurse if we are already the 'default state. + (when (not (eq mmode 'default)) + ;; Are we a derived mode? If so, get the parent mode's + ;; templates loaded too. + (if (get-mode-local-parent mmode) + (srecode-load-tables-for-mode (get-mode-local-parent mmode) + appname) + ;; No parent mode, all templates depend on the defaults being + ;; loaded in, so get that in instead. + (srecode-load-tables-for-mode 'default appname))) + + ;; Load in templates for our major mode. + (dolist (f files) + (let ((mt (srecode-get-mode-table mmode)) + ) + (when (or (not mt) (not (srecode-mode-table-find mt (car f)))) + (srecode-compile-file (car f))) + )) + )) + +;;; SEARCH +;; +;; Find a given template based on name, and features of the current +;; buffer. +(defmethod srecode-template-get-table ((tab srecode-template-table) + template-name &optional + context application) + "Find in the template in table TAB, the template with TEMPLATE-NAME. +Optional argument CONTEXT specifies that the template should part +of a particular context. +The APPLICATION argument is unused." + (if context + ;; If a context is specified, then look it up there. + (let ((ctxth (gethash context (oref tab contexthash)))) + (when ctxth + (gethash template-name ctxth))) + ;; No context, perhaps a merged name? + (gethash template-name (oref tab namehash)))) + +(defmethod srecode-template-get-table ((tab srecode-mode-table) + template-name &optional + context application) + "Find in the template in mode table TAB, the template with TEMPLATE-NAME. +Optional argument CONTEXT specifies a context a particular template +would belong to. +Optional argument APPLICATION restricts searches to only template tables +belonging to a specific application. If APPLICATION is nil, then only +tables that do not belong to an application will be searched." + (let* ((mt tab) + (tabs (oref mt :tables)) + (ans nil)) + (while (and (not ans) tabs) + (let ((app (oref (car tabs) :application))) + (when (or (and (not application) (null app)) + (and application (eq app application))) + (setq ans (srecode-template-get-table (car tabs) template-name + context))) + (setq tabs (cdr tabs)))) + (or ans + ;; Recurse to the default. + (when (not (equal (oref tab :major-mode) 'default)) + (srecode-template-get-table (srecode-get-mode-table 'default) + template-name context application))))) + +;; +;; Find a given template based on a key binding. +;; +(defmethod srecode-template-get-table-for-binding + ((tab srecode-template-table) binding &optional context) + "Find in the template name in table TAB, the template with BINDING. +Optional argument CONTEXT specifies that the template should part +of a particular context." + (let* ((keyout nil) + (hashfcn (lambda (key value) + (when (and (slot-boundp value 'binding) + (oref value binding) + (= (aref (oref value binding) 0) binding)) + (setq keyout key)))) + (contextstr (cond ((listp context) + (car-safe context)) + ((stringp context) + context) + (t nil))) + ) + (if context + (let ((ctxth (gethash contextstr (oref tab contexthash)))) + (when ctxth + ;; If a context is specified, then look it up there. + (maphash hashfcn ctxth) + ;; Context hashes EXCLUDE the context prefix which + ;; we need to include, so concat it here + (when keyout + (setq keyout (concat contextstr ":" keyout))) + ))) + (when (not keyout) + ;; No context, or binding in context. Try full hash. + (maphash hashfcn (oref tab namehash))) + keyout)) + +(defmethod srecode-template-get-table-for-binding + ((tab srecode-mode-table) binding &optional context application) + "Find in the template name in mode table TAB, the template with BINDING. +Optional argument CONTEXT specifies a context a particular template +would belong to. +Optional argument APPLICATION restricts searches to only template tables +belonging to a specific application. If APPLICATION is nil, then only +tables that do not belong to an application will be searched." + (let* ((mt tab) + (tabs (oref mt :tables)) + (ans nil)) + (while (and (not ans) tabs) + (let ((app (oref (car tabs) :application))) + (when (or (and (not application) (null app)) + (and application (eq app application))) + (setq ans (srecode-template-get-table-for-binding + (car tabs) binding context))) + (setq tabs (cdr tabs)))) + (or ans + ;; Recurse to the default. + (when (not (equal (oref tab :major-mode) 'default)) + (srecode-template-get-table-for-binding + (srecode-get-mode-table 'default) binding context))))) +;;; Interactive +;; +;; Interactive queries into the template data. +;; +(defvar srecode-read-template-name-history nil + "History for completing reads for template names.") + +(defun srecode-all-template-hash (&optional mode hash) + "Create a hash table of all the currently available templates. +Optional argument MODE is the major mode to look for. +Optional argument HASH is the hash table to fill in." + (let* ((mhash (or hash (make-hash-table :test 'equal))) + (mmode (or mode major-mode)) + (mp (get-mode-local-parent mmode)) + ) + ;; Get the parent hash table filled into our current hash. + (when (not (eq mode 'default)) + (if mp + (srecode-all-template-hash mp mhash) + (srecode-all-template-hash 'default mhash))) + ;; Load up the hash table for our current mode. + (let* ((mt (srecode-get-mode-table mmode)) + (tabs (when mt (oref mt :tables))) + ) + (while tabs + ;; Exclude templates for a perticular application. + (when (not (oref (car tabs) :application)) + (maphash (lambda (key temp) + (puthash key temp mhash) + ) + (oref (car tabs) namehash))) + (setq tabs (cdr tabs))) + mhash))) + +(defun srecode-calculate-default-template-string (hash) + "Calculate the name of the template to use as a DEFAULT. +Templates are read from HASH. +Context into which the template is inserted is calculated +with `srecode-calculate-context'." + (let* ((ctxt (srecode-calculate-context)) + (ans (concat (nth 0 ctxt) ":" (nth 1 ctxt)))) + (if (gethash ans hash) + ans + ;; No hash at the specifics, at least offer + ;; the prefix for the completing read + (concat (nth 0 ctxt) ":")))) + +(defun srecode-read-template-name (prompt &optional initial hist default) + "Completing read for Semantic Recoder template names. +PROMPT is used to query for the name of the template desired. +INITIAL is the initial string to use. +HIST is a history variable to use. +DEFAULT is what to use if the user presses RET." + (srecode-load-tables-for-mode major-mode) + (let* ((hash (srecode-all-template-hash)) + (def (or initial + (srecode-calculate-default-template-string hash)))) + (completing-read prompt hash + nil t def + (or hist + 'srecode-read-template-name-history)))) + +(provide 'srecode/find) + +;;; srecode/find.el ends here diff --git a/lisp/cedet/srecode/getset.el b/lisp/cedet/srecode/getset.el new file mode 100644 index 00000000000..b9ff6af2003 --- /dev/null +++ b/lisp/cedet/srecode/getset.el @@ -0,0 +1,366 @@ +;;; srecode/getset.el --- Package for inserting new get/set methods. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; SRecoder application for inserting new get/set methods into a class. + +(require 'semantic) +(require 'semantic/analyze) +(require 'semantic/find) +(require 'srecode/insert) +(require 'srecode/dictionary) + +;;; Code: +(defvar srecode-insert-getset-fully-automatic-flag nil + "Non-nil means accept choices srecode comes up with without asking.") + +;;;###autoload +(defun srecode-insert-getset (&optional class-in field-in) + "Insert get/set methods for the current class. +CLASS-IN is the semantic tag of the class to update. +FIELD-IN is the semantic tag, or string name, of the field to add. +If you do not specify CLASS-IN or FIELD-IN then a class and field +will be derived." + (interactive) + + (srecode-load-tables-for-mode major-mode) + (srecode-load-tables-for-mode major-mode 'getset) + + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + + (if (not (srecode-template-get-table (srecode-table) + "getset-in-class" + "declaration" + 'getset)) + (error "No templates for inserting get/set")) + + ;; Step 1: Try to derive the tag for the class we will use + (let* ((class (or class-in (srecode-auto-choose-class (point)))) + (tagstart (semantic-tag-start class)) + (inclass (eq (semantic-current-tag-of-class 'type) class)) + (field nil) + ) + + (when (not class) + (error "Move point to a class and try again")) + + ;; Step 2: Select a name for the field we will use. + (when field-in + (setq field field-in)) + + (when (and inclass (not field)) + (setq field (srecode-auto-choose-field (point)))) + + (when (not field) + (setq field (srecode-query-for-field class))) + + ;; Step 3: Insert a new field if needed + (when (stringp field) + + (goto-char (point)) + (srecode-position-new-field class inclass) + + (let* ((dict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) + "getset-field" + "declaration" + 'getset)) + ) + (when (not temp) + (error "Getset templates for %s not loaded!" major-mode)) + (srecode-resolve-arguments temp dict) + (srecode-dictionary-set-value dict "NAME" field) + (when srecode-insert-getset-fully-automatic-flag + (srecode-dictionary-set-value dict "TYPE" "int")) + (srecode-insert-fcn temp dict) + + (semantic-fetch-tags) + (save-excursion + (goto-char tagstart) + ;; Refresh our class tag. + (setq class (srecode-auto-choose-class (point))) + ) + + (let ((tmptag (semantic-deep-find-tags-by-name-regexp + field (current-buffer)))) + (setq tmptag (semantic-find-tags-by-class 'variable tmptag)) + + (if tmptag + (setq field (car tmptag)) + (error "Could not find new field %s" field))) + ) + + ;; Step 3.5: Insert an initializer if needed. + ;; ... + + + ;; Set up for the rest. + ) + + (if (not (semantic-tag-p field)) + (error "Must specify field for get/set. (parts may not be impl'd yet.)")) + + ;; Set 4: Position for insertion of methods + (srecode-position-new-methods class field) + + ;; Step 5: Insert the get/set methods + (if (not (eq (semantic-current-tag) class)) + ;; We are positioned on top of something else. + ;; insert a /n + (insert "\n")) + + (let* ((dict (srecode-create-dictionary)) + (srecode-semantic-selected-tag field) + (temp (srecode-template-get-table (srecode-table) + "getset-in-class" + "declaration" + 'getset)) + ) + (if (not temp) + (error "Getset templates for %s not loaded!" major-mode)) + (srecode-resolve-arguments temp dict) + (srecode-dictionary-set-value dict "GROUPNAME" + (concat (semantic-tag-name field) + " Accessors")) + (srecode-dictionary-set-value dict "NICENAME" + (srecode-strip-fieldname + (semantic-tag-name field))) + (srecode-insert-fcn temp dict) + ))) + +(defun srecode-strip-fieldname (name) + "Strip the fieldname NAME of polish notation things." + (cond ((string-match "[a-z]\\([A-Z]\\w+\\)" name) + (substring name (match-beginning 1))) + ;; Add more rules here. + (t + name))) + +(defun srecode-position-new-methods (class field) + "Position the cursor in CLASS where new getset methods should go. +FIELD is the field for the get sets. +INCLASS specifies if the cursor is already in CLASS or not." + (semantic-go-to-tag field) + + (let ((prev (semantic-find-tag-by-overlay-prev)) + (next (semantic-find-tag-by-overlay-next)) + (setname nil) + (aftertag nil) + ) + (cond + ((and prev (semantic-tag-of-class-p prev 'variable)) + (setq setname + (concat "set" + (srecode-strip-fieldname (semantic-tag-name prev)))) + ) + ((and next (semantic-tag-of-class-p next 'variable)) + (setq setname + (concat "set" + (srecode-strip-fieldname (semantic-tag-name prev))))) + (t nil)) + + (setq aftertag (semantic-find-first-tag-by-name + setname (semantic-tag-type-members class))) + + (when (not aftertag) + (setq aftertag (car-safe + (semantic--find-tags-by-macro + (semantic-tag-get-attribute (car tags) :destructor-flag) + (semantic-tag-type-members class)))) + ;; Make sure the tag is public + (when (not (eq (semantic-tag-protection aftertag class) 'public)) + (setq aftertag nil)) + ) + + (if (not aftertag) + (setq aftertag (car-safe + (semantic--find-tags-by-macro + (semantic-tag-get-attribute (car tags) :constructor-flag) + (semantic-tag-type-members class)))) + ;; Make sure the tag is public + (when (not (eq (semantic-tag-protection aftertag class) 'public)) + (setq aftertag nil)) + ) + + (when (not aftertag) + (setq aftertag (semantic-find-first-tag-by-name + "public" (semantic-tag-type-members class)))) + + (when (not aftertag) + (setq aftertag (car (semantic-tag-type-members class)))) + + (if aftertag + (let ((te (semantic-tag-end aftertag))) + (when (not te) + (message "Unknown location for tag-end in %s:" (semantic-tag-name aftertag))) + (goto-char te) + ;; If there is a comment immediatly after aftertag, skip over it. + (when (looking-at (concat "\\s-*\n?\\s-*" semantic-lex-comment-regex)) + (let ((pos (point)) + (rnext (semantic-find-tag-by-overlay-next (point)))) + (forward-comment 1) + ;; Make sure the comment we skipped didn't say anything about + ;; the rnext tag. + (when (and rnext + (re-search-backward + (regexp-quote (semantic-tag-name rnext)) pos t)) + ;; It did mention rnext, so go back to our starting position. + (goto-char pos) + ) + )) + ) + + ;; At the very beginning of the class. + (goto-char (semantic-tag-end class)) + (forward-sexp -1) + (forward-char 1) + + ) + + (end-of-line) + (forward-char 1) + )) + +(defun srecode-position-new-field (class inclass) + "Select a position for a new field for CLASS. +If INCLASS is non-nil, then the cursor is already in the class +and should not be moved during point selection." + + ;; If we aren't in the class, get the cursor there, pronto! + (when (not inclass) + + (error "You must position the cursor where to insert the new field") + + (let ((kids (semantic-find-tags-by-class + 'variable (semantic-tag-type-members class)))) + (cond (kids + (semantic-go-to-tag (car kids) class)) + (t + (semantic-go-to-tag class))) + ) + + (switch-to-buffer (current-buffer)) + + ;; Once the cursor is in our class, ask the user to position + ;; the cursor to keep going. + ) + + (if (or srecode-insert-getset-fully-automatic-flag + (y-or-n-p "Insert new field here? ")) + nil + (error "You must position the cursor where to insert the new field first")) + ) + + + +(defun srecode-auto-choose-field (point) + "Choose a field for the get/set methods. +Base selection on the field related to POINT." + (save-excursion + (when point + (goto-char point)) + + (let ((field (semantic-current-tag-of-class 'variable))) + + ;; If we get a field, make sure the user gets a chance to choose. + (when field + (if srecode-insert-getset-fully-automatic-flag + nil + (when (not (y-or-n-p + (format "Use field %s? " (semantic-tag-name field)))) + (setq field nil)) + )) + field))) + +(defun srecode-query-for-field (class) + "Query for a field in CLASS." + (let* ((kids (semantic-find-tags-by-class + 'variable (semantic-tag-type-members class))) + (sel (completing-read "Use Field: " kids)) + ) + + (or (semantic-find-tags-by-name sel kids) + sel) + )) + +(defun srecode-auto-choose-class (point) + "Choose a class based on locatin of POINT." + (save-excursion + (when point + (goto-char point)) + + (let ((tag (semantic-current-tag-of-class 'type))) + + (when (or (not tag) + (not (string= (semantic-tag-type tag) "class"))) + ;; The current tag is not a class. Are we in a fcn + ;; that is a method? + (setq tag (semantic-current-tag-of-class 'function)) + + (when (and tag + (semantic-tag-function-parent tag)) + (let ((p (semantic-tag-function-parent tag))) + ;; @TODO : Copied below out of semantic-analyze + ;; Turn into a routine. + + (let* ((searchname (cond ((stringp p) p) + ((semantic-tag-p p) + (semantic-tag-name p)) + ((and (listp p) (stringp (car p))) + (car p)))) + (ptag (semantic-analyze-find-tag searchname + 'type nil))) + (when ptag (setq tag ptag )) + )))) + + (when (or (not tag) + (not (semantic-tag-of-class-p tag 'type)) + (not (string= (semantic-tag-type tag) "class"))) + ;; We are not in a class that needs a get/set method. + ;; Analyze the current context, and derive a class name. + (let* ((ctxt (semantic-analyze-current-context)) + (pfix nil) + (ans nil)) + (when ctxt + (setq pfix (reverse (oref ctxt prefix))) + (while (and (not ans) pfix) + ;; Start at the end and back up to the first class. + (when (and (semantic-tag-p (car pfix)) + (semantic-tag-of-class-p (car pfix) 'type) + (string= (semantic-tag-type (car pfix)) + "class")) + (setq ans (car pfix))) + (setq pfix (cdr pfix)))) + (setq tag ans))) + + tag))) + +(provide 'srecode/getset) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/getset" +;; End: + +;;; srecode/getset.el ends here diff --git a/lisp/cedet/srecode/insert.el b/lisp/cedet/srecode/insert.el new file mode 100644 index 00000000000..e1772b3c578 --- /dev/null +++ b/lisp/cedet/srecode/insert.el @@ -0,0 +1,983 @@ +;;; srecode/insert --- Insert srecode templates to an output stream. + +;;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Define and implements specific inserter objects. +;; +;; Manage the insertion process for a template. +;; + +(require 'srecode/compile) +(require 'srecode/find) +(require 'srecode/dictionary) + +(defvar srecode-template-inserter-point) +(declare-function srecode-overlaid-activate "srecode/fields") +(declare-function srecode-template-inserted-region "srecode/fields") + +;;; Code: + +(defcustom srecode-insert-ask-variable-method 'ask + "Determine how to ask for a dictionary value when inserting a template. +Only the ASK style inserter will query the user for a value. +Dictionary value references that ask begin with the ? character. +Possible values are: + 'ask - Prompt in the minibuffer as the value is inserted. + 'field - Use the dictionary macro name as the inserted value, + and place a field there. Matched fields change together. + +NOTE: The field feature does not yet work with XEmacs." + :group 'srecode + :type '(choice (const :tag "Ask" ask) + (cons :tag "Field" field))) + +(defvar srecode-insert-with-fields-in-progress nil + "Non-nil means that we are actively inserting a template with fields.") + +;;; INSERTION COMMANDS +;; +;; User level commands for inserting stuff. +(defvar srecode-insertion-start-context nil + "The context that was at point at the beginning of the template insertion.") + +(defun srecode-insert-again () + "Insert the previously inserted template (by name) again." + (interactive) + (let ((prev (car srecode-read-template-name-history))) + (if prev + (srecode-insert prev) + (call-interactively 'srecode-insert)))) + +;;;###autoload +(defun srecode-insert (template-name &rest dict-entries) + "Inesrt the template TEMPLATE-NAME into the current buffer at point. +DICT-ENTRIES are additional dictionary values to add." + (interactive (list (srecode-read-template-name "Template Name: "))) + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + (let ((newdict (srecode-create-dictionary)) + (temp (srecode-template-get-table (srecode-table) template-name)) + (srecode-insertion-start-context (srecode-calculate-context)) + ) + (if (not temp) + (error "No Template named %s" template-name)) + (while dict-entries + (srecode-dictionary-set-value newdict + (car dict-entries) + (car (cdr dict-entries))) + (setq dict-entries (cdr (cdr dict-entries)))) + ;;(srecode-resolve-arguments temp newdict) + (srecode-insert-fcn temp newdict) + ;; Don't put code here. We need to return the end-mark + ;; for this insertion step. + )) + +(defun srecode-insert-fcn (template dictionary &optional stream skipresolver) + "Insert TEMPLATE using DICTIONARY into STREAM. +Optional SKIPRESOLVER means to avoid refreshing the tag list, +or resolving any template arguments. It is assumed the caller +has set everything up already." + ;; Perform the insertion. + (let ((standard-output (or stream (current-buffer))) + (end-mark nil)) + (unless skipresolver + ;; Make sure the semantic tags are up to date. + (semantic-fetch-tags) + ;; Resolve the arguments + (srecode-resolve-arguments template dictionary)) + ;; Insert + (if (bufferp standard-output) + ;; If there is a buffer, turn off various hooks. This will cause + ;; the mod hooks to be buffered up during the insert, but + ;; prevent tools like font-lock from fontifying mid-template. + ;; Especialy important during insertion of complex comments that + ;; cause the new font-lock to comment-color stuff after the inserted + ;; comment. + ;; + ;; I'm not sure about the motion hooks. It seems like a good + ;; idea though. + ;; + ;; Borrowed these concepts out of font-lock. + ;; + ;; I tried `combine-after-change-calls', but it did not have + ;; the effect I wanted. + (let ((start (point))) + (let ((inhibit-point-motion-hooks t) + (inhibit-modification-hooks t) + ) + (srecode--insert-into-buffer template dictionary) + ) + ;; Now call those after change functions. + (run-hook-with-args 'after-change-functions + start (point) 0) + ) + (srecode-insert-method template dictionary)) + ;; Handle specialization of the POINT inserter. + (when (and (bufferp standard-output) + (slot-boundp 'srecode-template-inserter-point 'point) + ) + (set-buffer standard-output) + (setq end-mark (point-marker)) + (goto-char (oref srecode-template-inserter-point point))) + (oset-default 'srecode-template-inserter-point point eieio-unbound) + + ;; Return the end-mark. + (or end-mark (point))) + ) + +(defun srecode--insert-into-buffer (template dictionary) + "Insert a TEMPLATE with DICTIONARY into a buffer. +Do not call this function yourself. Instead use: + `srecode-insert' - Inserts by name. + `srecode-insert-fcn' - Insert with objects. +This function handles the case from one of the above functions when +the template is inserted into a buffer. It looks +at `srecode-insert-ask-variable-method' to decide if unbound dictionary +entries ask questions or insert editable fields. + +Buffer based features related to change hooks is handled one level up." + ;; This line prevents the field archive from being let bound + ;; while the field insert tool is loaded via autoloads during + ;; the insert. + (when (eq srecode-insert-ask-variable-method 'field) + (require 'srecode/fields)) + + (let ((srecode-field-archive nil) ; Prevent field leaks during insert + (start (point)) ; Beginning of the region. + ) + ;; This sub-let scopes the 'in-progress' piece so we know + ;; when to setup the end-template. + (let ((srecode-insert-with-fields-in-progress + (if (eq srecode-insert-ask-variable-method 'field) t nil)) + ) + (srecode-insert-method template dictionary) + ) + ;; If we are not in-progress, and we insert fields, then + ;; create the end-template with fields editable area. + (when (and (not srecode-insert-with-fields-in-progress) + (eq srecode-insert-ask-variable-method 'field) ; Only if user asked + srecode-field-archive ; Only if there were fields created + ) + (let ((reg + ;; Create the field-driven editable area. + (srecode-template-inserted-region + "TEMPLATE" :start start :end (point)))) + (srecode-overlaid-activate reg)) + ) + ;; We return with 'point being the end of the template insertion + ;; area. Return value is not important. + )) + +;;; TEMPLATE ARGUMENTS +;; +;; Some templates have arguments. Each argument is assocaited with +;; a function that can resolve the inputs needed. +(defun srecode-resolve-arguments (temp dict) + "Resolve all the arguments needed by the template TEMP. +Apply anything learned to the dictionary DICT." + (srecode-resolve-argument-list (oref temp args) dict temp)) + +(defun srecode-resolve-argument-list (args dict &optional temp) + "Resolve arguments in the argument list ARGS. +ARGS is a list of symbols, such as :blank, or :file. +Apply values to DICT. +Optional argument TEMP is the template that is getting it's arguments resolved." + (let ((fcn nil)) + (while args + (setq fcn (intern-soft (concat "srecode-semantic-handle-" + (symbol-name (car args))))) + (if (not fcn) + (error "Error resolving template argument %S" (car args))) + (if temp + (condition-case nil + ;; Allow some to accept a 2nd argument optionally. + ;; They throw an error if not available, so try again. + (funcall fcn dict temp) + (wrong-number-of-arguments (funcall fcn dict))) + (funcall fcn dict)) + (setq args (cdr args))) + )) + +;;; INSERTION STACK & METHOD +;; +;; Code managing the top-level insert method and the current +;; insertion stack. +;; +(defmethod srecode-push ((st srecode-template)) + "Push the srecoder template ST onto the active stack." + (oset st active (cons st (oref st active)))) + +(defmethod srecode-pop :STATIC ((st srecode-template)) + "Pop the srecoder template ST onto the active stack. +ST can be a class, or an object." + (oset st active (cdr (oref st active)))) + +(defmethod srecode-peek :STATIC ((st srecode-template)) + "Fetch the topmost active template record. ST can be a class." + (car (oref st active))) + +(defmethod srecode-insert-method ((st srecode-template) dictionary) + "Insert the srecoder template ST." + ;; Merge any template entries into the input dictionary. + (when (slot-boundp st 'dictionary) + (srecode-dictionary-merge dictionary (oref st dictionary))) + ;; Do an insertion. + (unwind-protect + (let ((c (oref st code))) + (srecode-push st) + (srecode-insert-code-stream c dictionary)) + ;; Poping the stack is protected + (srecode-pop st))) + +(defun srecode-insert-code-stream (code dictionary) + "Insert the CODE from a template into `standard-output'. +Use DICTIONARY to resolve any macros." + (while code + (cond ((stringp (car code)) + (princ (car code))) + (t + (srecode-insert-method (car code) dictionary))) + (setq code (cdr code)))) + +;;; INSERTERS +;; +;; Specific srecode inserters. +;; The base class is from srecode-compile. +;; +;; Each inserter handles various macro codes from the temlate. +;; The `code' slot specifies a character used to identify which +;; inserter is to be created. +;; +(defclass srecode-template-inserter-newline (srecode-template-inserter) + ((key :initform "\n" + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + (hard :initform nil + :initarg :hard + :documentation + "Is this a hard newline (always inserted) or optional? +Optional newlines don't insert themselves if they are on a blank line +by themselves.") + ) + "Insert a newline, and possibly do indenting. +Specify the :indent argument to enable automatic indentation when newlines +occur in your template.") + +(defmethod srecode-insert-method ((sti srecode-template-inserter-newline) + dictionary) + "Insert the STI inserter." + ;; To be safe, indent the previous line since the template will + ;; change what is there to indent + (let ((i (srecode-dictionary-lookup-name dictionary "INDENT")) + (inbuff (bufferp standard-output)) + (doit t) + (pm (point-marker))) + (when (and inbuff (not (oref sti hard))) + ;; If this is not a hard newline, we need do the calculation + ;; and set "doit" to nil. + (beginning-of-line) + (save-restriction + (narrow-to-region (point) pm) + (when (looking-at "\\s-*$") + (setq doit nil))) + (goto-char pm) + ) + ;; Do indentation reguardless of the newline. + (when (and (eq i t) inbuff) + (indent-according-to-mode) + (goto-char pm)) + + (when doit + (princ "\n") + ;; Indent after the newline, particularly for numeric indents. + (cond ((and (eq i t) (bufferp standard-output)) + ;; WARNING - indent according to mode requires that standard-output + ;; is a buffer! + ;; @todo - how to indent in a string??? + (setq pm (point-marker)) + (indent-according-to-mode) + (goto-char pm)) + ((numberp i) + (princ (make-string i " "))) + ((stringp i) + (princ i)))))) + +(defmethod srecode-dump ((ins srecode-template-inserter-newline) indent) + "Dump the state of the SRecode template inserter INS." + (call-next-method) + (when (oref ins hard) + (princ " : hard") + )) + +(defclass srecode-template-inserter-blank (srecode-template-inserter) + ((key :initform "\r" + :allocation :class + :documentation + "The character represeinting this inserter style. +Can't be blank, or it might be used by regular variable insertion.") + (where :initform 'begin + :initarg :where + :documentation + "This should be 'begin or 'end, indicating where to insrt a CR. +When set to 'begin, it will insert a CR if we are not at 'bol'. +When set to 'end it will insert a CR if we are not at 'eol'") + ;; @TODO - Add slot and control for the number of blank + ;; lines before and after point. + ) + "Insert a newline before and after a template, and possibly do indenting. +Specify the :blank argument to enable this inserter.") + +(defmethod srecode-insert-method ((sti srecode-template-inserter-blank) + dictionary) + "Make sure there is no text before or after point." + (let ((i (srecode-dictionary-lookup-name dictionary "INDENT")) + (inbuff (bufferp standard-output)) + (pm (point-marker))) + (when (and inbuff + ;; Don't do this if we are not the active template. + (= (length (oref srecode-template active)) 1)) + + (when (and (eq i t) inbuff (not (eq (oref sti where) 'begin))) + (indent-according-to-mode) + (goto-char pm)) + + (cond ((and (eq (oref sti where) 'begin) (not (bolp))) + (princ "\n")) + ((eq (oref sti where) 'end) + ;; If there is whitespace after pnt, then clear it out. + (when (looking-at "\\s-*$") + (delete-region (point) (point-at-eol))) + (when (not (eolp)) + (princ "\n"))) + ) + (setq pm (point-marker)) + (when (and (eq i t) inbuff (not (eq (oref sti where) 'end))) + (indent-according-to-mode) + (goto-char pm)) + ))) + +(defclass srecode-template-inserter-comment (srecode-template-inserter) + ((key :initform ?! + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + ) + "Allow comments within template coding. This inserts nothing.") + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-comment) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (princ "! Miscellaneous text commenting in your template. ") + (princ escape-end) + (terpri) + ) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-comment) + dictionary) + "Don't insert anything for comment macros in STI." + nil) + + +(defclass srecode-template-inserter-variable (srecode-template-inserter) + ((key :initform nil + :allocation :class + :documentation + "The character code used to identify inserters of this style.")) + "Insert the value of a dictionary entry +If there is no entry, insert nothing.") + +(defvar srecode-inserter-variable-current-dictionary nil + "The active dictionary when calling a variable filter.") + +(defmethod srecode-insert-variable-secondname-handler + ((sti srecode-template-inserter-variable) dictionary value secondname) + "For VALUE handle SECONDNAME behaviors for this variable inserter. +Return the result as a string. +By default, treat as a function name. +If SECONDNAME is nil, return VALUE." + (if secondname + (let ((fcnpart (read secondname))) + (if (fboundp fcnpart) + (let ((srecode-inserter-variable-current-dictionary dictionary)) + (funcall fcnpart value)) + ;; Else, warn. + (error "Variable insertion second arg %s is not a function." + secondname))) + value)) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-variable) + dictionary) + "Insert the STI inserter." + ;; Convert the name into a name/fcn pair + (let* ((name (oref sti :object-name)) + (fcnpart (oref sti :secondname)) + (val (srecode-dictionary-lookup-name + dictionary name)) + (do-princ t) + ) + ;; Alert if a macro wasn't found. + (when (not val) + (message "Warning: macro %S was not found in the dictionary." name) + (setq val "")) + ;; If there was a functional part, call that function. + (cond ;; Strings + ((stringp val) + (setq val (srecode-insert-variable-secondname-handler + sti dictionary val fcnpart))) + ;; Compound data value + ((srecode-dictionary-compound-value-child-p val) + ;; Force FCN to be a symbol + (when fcnpart (setq fcnpart (read fcnpart))) + ;; Convert compound value to a string with the fcn. + (setq val (srecode-compound-toString val fcnpart dictionary)) + ;; If the value returned is nil, then it may be a special + ;; field inserter that requires us to set do-princ to nil. + (when (not val) + (setq do-princ nil) + ) + ) + ;; Dictionaries... not allowed in this style + ((srecode-dictionary-child-p val) + (error "Macro %s cannot insert a dictionary. Use section macros instead." + name)) + ;; Other stuff... convert + (t + (error "Macro %s cannot insert arbitrary data." name) + ;;(if (and val (not (stringp val))) + ;; (setq val (format "%S" val)))) + )) + ;; Output the dumb thing unless the type of thing specifically + ;; did the inserting forus. + (when do-princ + (princ val)))) + +(defclass srecode-template-inserter-ask (srecode-template-inserter-variable) + ((key :initform ?? + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + (prompt :initarg :prompt + :initform nil + :documentation + "The prompt used to query for this dictionary value.") + (defaultfcn :initarg :defaultfcn + :initform nil + :documentation + "The function which can calculate a default value.") + (read-fcn :initarg :read-fcn + :initform 'read-string + :documentation + "The function used to read in the text for this prompt.") + ) + "Insert the value of a dictionary entry +If there is no entry, prompt the user for the value to use. +The prompt text used is derived from the previous PROMPT command in the +template file.") + +(defmethod srecode-inserter-apply-state ((ins srecode-template-inserter-ask) STATE) + "For the template inserter INS, apply information from STATE. +Loop over the prompts to see if we have a match." + (let ((prompts (oref STATE prompts)) + ) + (while prompts + (when (string= (semantic-tag-name (car prompts)) + (oref ins :object-name)) + (oset ins :prompt + (semantic-tag-get-attribute (car prompts) :text)) + (oset ins :defaultfcn + (semantic-tag-get-attribute (car prompts) :default)) + (oset ins :read-fcn + (or (semantic-tag-get-attribute (car prompts) :read) + 'read-string)) + ) + (setq prompts (cdr prompts))) + )) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-ask) + dictionary) + "Insert the STI inserter." + (let ((val (srecode-dictionary-lookup-name + dictionary (oref sti :object-name)))) + (if val + ;; Does some extra work. Oh well. + (call-next-method) + + ;; How is our -ask value determined? + (if srecode-insert-with-fields-in-progress + ;; Setup editable fields. + (setq val (srecode-insert-method-field sti dictionary)) + ;; Ask the question... + (setq val (srecode-insert-method-ask sti dictionary))) + + ;; After asking, save in the dictionary so that + ;; the user can use the same name again later. + (srecode-dictionary-set-value + (srecode-root-dictionary dictionary) + (oref sti :object-name) val) + + ;; Now that this value is safely stowed in the dictionary, + ;; we can do what regular inserters do. + (call-next-method)))) + +(defmethod srecode-insert-ask-default ((sti srecode-template-inserter-ask) + dictionary) + "Derive the default value for an askable inserter STI. +DICTIONARY is used to derive some values." + (let ((defaultfcn (oref sti :defaultfcn))) + (cond ((stringp defaultfcn) + defaultfcn) + ((functionp defaultfcn) + (funcall defaultfcn)) + ((and (listp defaultfcn) + (eq (car defaultfcn) 'macro)) + (srecode-dictionary-lookup-name + dictionary (cdr defaultfcn))) + ((null defaultfcn) + "") + (t + (error "Unknown default for prompt: %S" + defaultfcn))))) + +(defmethod srecode-insert-method-ask ((sti srecode-template-inserter-ask) + dictionary) + "Do the \"asking\" for the template inserter STI. +Use DICTIONARY to resolve values." + (let* ((prompt (oref sti prompt)) + (default (srecode-insert-ask-default sti dictionary)) + (reader (oref sti :read-fcn)) + (val nil) + ) + (cond ((eq reader 'y-or-n-p) + (if (y-or-n-p (or prompt + (format "%s? " + (oref sti :object-name)))) + (setq val default) + (setq val ""))) + ((eq reader 'read-char) + (setq val (format + "%c" + (read-char (or prompt + (format "Char for %s: " + (oref sti :object-name)))))) + ) + (t + (save-excursion + (setq val (funcall reader + (or prompt + (format "Specify %s: " + (oref sti :object-name))) + default + ))))) + ;; Return our derived value. + val) + ) + +(defmethod srecode-insert-method-field ((sti srecode-template-inserter-ask) + dictionary) + "Create an editable field for the template inserter STI. +Use DICTIONARY to resolve values." + (let* ((default (srecode-insert-ask-default sti dictionary)) + (compound-value + (srecode-field-value (oref sti :object-name) + :firstinserter sti + :defaultvalue default)) + ) + ;; Return this special compound value as the thing to insert. + ;; This special compound value will repeat our asked question + ;; across multiple locations. + compound-value)) + +(defmethod srecode-dump ((ins srecode-template-inserter-ask) indent) + "Dump the state of the SRecode template inserter INS." + (call-next-method) + (princ " : \"") + (princ (oref ins prompt)) + (princ "\"") + ) + +(defclass srecode-template-inserter-width (srecode-template-inserter-variable) + ((key :initform ?| + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + ) + "Inserts the value of a dictionary variable with a specific width. +The second argument specifies the width, and a pad, seperated by a colon. +thus a specification of `10:left' will insert the value of A +to 10 characters, with spaces added to the left. Use `right' for adding +spaces to the right.") + +(defmethod srecode-insert-variable-secondname-handler + ((sti srecode-template-inserter-width) dictionary value width) + "For VALUE handle WIDTH behaviors for this variable inserter. +Return the result as a string. +By default, treat as a function name." + (if width + ;; Trim or pad to new length + (let* ((split (split-string width ":")) + (width (string-to-number (nth 0 split))) + (second (nth 1 split)) + (pad (cond ((or (null second) (string= "right" second)) + 'right) + ((string= "left" second) + 'left) + (t + (error "Unknown pad type %s" second))))) + (if (>= (length value) width) + ;; Simple case - too long. + (substring value 0 width) + ;; We need to pad on one side or the other. + (let ((padchars (make-string (- width (length value)) ? ))) + (if (eq pad 'left) + (concat padchars value) + (concat value padchars))))) + (error "Width not specified for variable/width inserter."))) + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-width) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (princ "|A:10:right") + (princ escape-end) + (terpri) + ) + +(defvar srecode-template-inserter-point-override nil + "When non-nil, the point inserter will do this functin instead.") + +(defclass srecode-template-inserter-point (srecode-template-inserter) + ((key :initform ?^ + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + (point :type (or null marker) + :allocation :class + :documentation + "Record the value of (point) in this class slot. +It is the responsibility of the inserter algorithm to clear this +after a successful insertion.")) + "Record the value of (point) when inserted. +The cursor is placed at the ^ macro after insertion. +Some inserter macros, such as `srecode-template-inserter-include-wrap' +will place text at the ^ macro from the included macro.") + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-point) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (princ "^") + (princ escape-end) + (terpri) + ) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-point) + dictionary) + "Insert the STI inserter. +Save point in the class allocated 'point' slot. +If `srecode-template-inserter-point-override' then this generalized +marker will do something else. See `srecode-template-inserter-include-wrap' +as an example." + (if srecode-template-inserter-point-override + ;; Disable the old override while we do this. + (let ((over srecode-template-inserter-point-override) + (srecode-template-inserter-point-override nil)) + (funcall over dictionary) + ) + (oset sti point (point-marker)) + )) + +(defclass srecode-template-inserter-subtemplate (srecode-template-inserter) + () + "Wrap a section of a template under the control of a macro." + :abstract t) + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-subtemplate) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (call-next-method) + (princ " Template Text to control") + (terpri) + (princ " ") + (princ escape-start) + (princ "/VARNAME") + (princ escape-end) + (terpri) + ) + +(defmethod srecode-insert-subtemplate ((sti srecode-template-inserter-subtemplate) + dict slot) + "Insert a subtemplate for the inserter STI with dictionary DICT." + ;; make sure that only dictionaries are used. + (when (not (srecode-dictionary-child-p dict)) + (error "Only section dictionaries allowed for %s" + (object-name-string sti))) + ;; Output the code from the sub-template. + (srecode-insert-method (slot-value sti slot) dict) + ) + +(defmethod srecode-insert-method-helper ((sti srecode-template-inserter-subtemplate) + dictionary slot) + "Do the work for inserting the STI inserter. +Loops over the embedded CODE which was saved here during compilation. +The template to insert is stored in SLOT." + (let ((dicts (srecode-dictionary-lookup-name + dictionary (oref sti :object-name)))) + ;; If there is no section dictionary, then don't output anything + ;; from this section. + (while dicts + (srecode-insert-subtemplate sti (car dicts) slot) + (setq dicts (cdr dicts))))) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-subtemplate) + dictionary) + "Insert the STI inserter. +Calls back to `srecode-insert-method-helper' for this class." + (srecode-insert-method-helper sti dictionary 'template)) + + +(defclass srecode-template-inserter-section-start (srecode-template-inserter-subtemplate) + ((key :initform ?# + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + (template :initarg :template + :documentation + "A Template used to frame the codes from this inserter.") + ) + "Apply values from a sub-dictionary to a template section. +The dictionary saved at the named dictionary entry will be +applied to the text between the section start and the +`srecode-template-inserter-section-end' macro.") + +(defmethod srecode-parse-input ((ins srecode-template-inserter-section-start) + tag input STATE) + "For the section inserter INS, parse INPUT. +Shorten input until the END token is found. +Return the remains of INPUT." + (let* ((out (srecode-compile-split-code tag input STATE + (oref ins :object-name)))) + (oset ins template (srecode-template + (object-name-string ins) + :context nil + :args nil + :code (cdr out))) + (car out))) + +(defmethod srecode-dump ((ins srecode-template-inserter-section-start) indent) + "Dump the state of the SRecode template inserter INS." + (call-next-method) + (princ "\n") + (srecode-dump-code-list (oref (oref ins template) code) + (concat indent " ")) + ) + +(defclass srecode-template-inserter-section-end (srecode-template-inserter) + ((key :initform ?/ + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + ) + "All template segments between the secion-start and section-end +are treated specially.") + +(defmethod srecode-insert-method ((sti srecode-template-inserter-section-end) + dictionary) + "Insert the STI inserter." + ) + +(defmethod srecode-match-end ((ins srecode-template-inserter-section-end) name) + + "For the template inserter INS, do I end a section called NAME?" + (string= name (oref ins :object-name))) + +(defclass srecode-template-inserter-include (srecode-template-inserter-subtemplate) + ((key :initform ?> + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + (includedtemplate + :initarg :includedtemplate + :documentation + "The template included for this inserter.")) + "Include a different template into this one. +The included template will have additional dictionary entries from the subdictionary +stored specified by this macro.") + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-include) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (princ ">DICTNAME:contextname:templatename") + (princ escape-end) + (terpri) + ) + +(defmethod srecode-insert-include-lookup ((sti srecode-template-inserter-include) + dictionary) + "For the template inserter STI, lookup the template to include. +Finds the template with this macro function part and stores it in +this template instance." + (let* ((templatenamepart (oref sti :secondname)) + ) + ;; If there was no template name, throw an error + (if (not templatenamepart) + (error "Include macro %s needs a template name." (oref sti :object-name))) + ;; Find the template by name, and save it. + (if (or (not (slot-boundp sti 'includedtemplate)) + (not (oref sti includedtemplate))) + (let ((tmpl (srecode-template-get-table (srecode-table) + templatenamepart)) + (active (oref srecode-template active)) + ctxt) + (when (not tmpl) + ;; If it isn't just available, scan back through + ;; the active template stack, searching for a matching + ;; context. + (while (and (not tmpl) active) + (setq ctxt (oref (car active) context)) + (setq tmpl (srecode-template-get-table (srecode-table) + templatenamepart + ctxt)) + (when (not tmpl) + (when (slot-boundp (car active) 'table) + (let ((app (oref (oref (car active) table) application))) + (when app + (setq tmpl (srecode-template-get-table + (srecode-table) + templatenamepart + ctxt app))) + ))) + (setq active (cdr active))) + (when (not tmpl) + ;; If it wasn't in this context, look to see if it + ;; defines it's own context + (setq tmpl (srecode-template-get-table (srecode-table) + templatenamepart))) + ) + (oset sti :includedtemplate tmpl))) + + (if (not (oref sti includedtemplate)) + ;; @todo - Call into a debugger to help find the template in question. + (error "No template \"%s\" found for include macro `%s'" + templatenamepart (oref sti :object-name))) + )) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-include) + dictionary) + "Insert the STI inserter. +Finds the template with this macro function part, and inserts it +with the dictionaries found in the dictinary." + (srecode-insert-include-lookup sti dictionary) + ;; Insert the template. + ;; Our baseclass has a simple way to do this. + (if (srecode-dictionary-lookup-name dictionary (oref sti :object-name)) + ;; If we have a value, then call the next method + (srecode-insert-method-helper sti dictionary 'includedtemplate) + ;; If we don't have a special dictitonary, then just insert with the + ;; current dictionary. + (srecode-insert-subtemplate sti dictionary 'includedtemplate)) + ) + +;; +;; This template combines the include template and the sectional template. +;; It will first insert the included template, then insert the embedded +;; template wherever the $^$ in the included template was. +;; +;; Since it uses dual inheretance, it will magically get the end-matching +;; behavior of #, with the including feature of >. +;; +(defclass srecode-template-inserter-include-wrap (srecode-template-inserter-include srecode-template-inserter-section-start) + ((key :initform ?< + :allocation :class + :documentation + "The character code used to identify inserters of this style.") + ) + "Include a different template into this one, and add text at the ^ macro. +The included template will have additional dictionary entries from the subdictionary +stored specified by this macro. If the included macro includes a ^ macro, +then the text between this macro and the end macro will be inserted at +the ^ macro.") + +(defmethod srecode-inserter-prin-example :STATIC ((ins srecode-template-inserter-include-wrap) + escape-start escape-end) + "Insert an example using inserter INS. +Arguments ESCAPE-START and ESCAPE-END are the current escape sequences in use." + (princ " ") + (princ escape-start) + (princ "<DICTNAME:contextname:templatename") + (princ escape-end) + (terpri) + (princ " Template Text to insert at ^ macro") + (terpri) + (princ " ") + (princ escape-start) + (princ "/DICTNAME") + (princ escape-end) + (terpri) + ) + +(defmethod srecode-insert-method ((sti srecode-template-inserter-include-wrap) + dictionary) + "Insert the template STI. +This will first insert the include part via inheritance, then +insert the section it wraps into the location in the included +template where a ^ inserter occurs." + ;; Step 1: Look up the included inserter + (srecode-insert-include-lookup sti dictionary) + ;; Step 2: Temporarilly override the point inserter. + (let* ((vaguely-unique-name sti) + (srecode-template-inserter-point-override + (lambda (dict2) + (if (srecode-dictionary-lookup-name + dict2 (oref vaguely-unique-name :object-name)) + ;; Insert our sectional part with looping. + (srecode-insert-method-helper + vaguely-unique-name dict2 'template) + ;; Insert our sectional part just once. + (srecode-insert-subtemplate vaguely-unique-name + dict2 'template)) + ))) + ;; Do a regular insertion for an include, but with our override in + ;; place. + (call-next-method) + )) + +(provide 'srecode/insert) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/insert" +;; End: + +;;; srecode/insert.el ends here diff --git a/lisp/cedet/srecode/java.el b/lisp/cedet/srecode/java.el new file mode 100644 index 00000000000..325cf215ee8 --- /dev/null +++ b/lisp/cedet/srecode/java.el @@ -0,0 +1,62 @@ +;;; srecode-java.el --- Srecode Java support + +;; Copyright (C) 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Special support for the Java language. + +;;; Code: + +(require 'srecode/dictionary) + +;;;###autoload +(defun srecode-semantic-handle-:java (dict) + "Add macros into the dictionary DICT based on the current java file. +Adds the following: +FILENAME_AS_PACKAGE - file/dir converted into a java package name. +FILENAME_AS_CLASS - file converted to a Java class name." + ;; A symbol representing + (let* ((fsym (file-name-nondirectory (buffer-file-name))) + (fnox (file-name-sans-extension fsym)) + (dir (file-name-directory (buffer-file-name))) + (fpak fsym) + ) + (while (string-match "\\.\\| " fpak) + (setq fpak (replace-match "_" t t fpak))) + (if (string-match "src/" dir) + (setq dir (substring dir (match-end 0))) + (setq dir (file-name-nondirectory (directory-file-name dir)))) + (while (string-match "/" dir) + (setq dir (replace-match "_" t t dir))) + (srecode-dictionary-set-value dict "FILENAME_AS_PACKAGE" + (concat dir "." fpak)) + (srecode-dictionary-set-value dict "FILENAME_AS_CLASS" fnox) + )) + +(provide 'srecode/java) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/java" +;; End: + +;;; srecode/java.el ends here diff --git a/lisp/cedet/srecode/map.el b/lisp/cedet/srecode/map.el new file mode 100644 index 00000000000..efa858fca78 --- /dev/null +++ b/lisp/cedet/srecode/map.el @@ -0,0 +1,415 @@ +;;; srecode/map.el --- Manage a template file map + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Read template files, and build a map of where they can be found. +;; Save the map to disk, and refer to it when bootstrapping a new +;; Emacs session with srecode. + +(require 'semantic) +(require 'eieio-base) +(require 'srecode) + +;;; Code: + +;; The defcustom is given at the end of the file. +(defvar srecode-map-load-path) + +(defun srecode-map-base-template-dir () + "Find the base template directory for SRecode." + (let* ((lib (locate-library "srecode.el")) + (dir (file-name-directory lib))) + (expand-file-name "templates/" dir) + )) + +;;; Current MAP +;; + +(defvar srecode-current-map nil + "The current map for global SRecode templtes.") + +(defcustom srecode-map-save-file (expand-file-name "~/.srecode/srecode-map") + "The save location for SRecode's map file. +If the save file is nil, then the MAP is not saved between sessions." + :group 'srecode + :type 'file) + +(defclass srecode-map (eieio-persistent) + ((fileheaderline :initform ";; SRECODE TEMPLATE MAP") + (files :initarg :files + :initform nil + :type list + :documentation + "An alist of files and the major-mode that they cover.") + (apps :initarg :apps + :initform nil + :type list + :documentation + "An alist of applications. +Each app keys to an alist of files and modes (as above.)") + ) + "A map of srecode templates.") + +(defmethod srecode-map-entry-for-file ((map srecode-map) file) + "Return the entry in MAP for FILE." + (assoc file (oref map files))) + +(defmethod srecode-map-entries-for-mode ((map srecode-map) mode) + "Return the entries in MAP for major MODE." + (let ((ans nil)) + (dolist (f (oref map files)) + (when (mode-local-use-bindings-p mode (cdr f)) + (setq ans (cons f ans)))) + ans)) + +(defmethod srecode-map-entry-for-app ((map srecode-map) app) + "Return the entry in MAP for APP'lication." + (assoc app (oref map apps)) + ) + +(defmethod srecode-map-entries-for-app-and-mode ((map srecode-map) app mode) + "Return the entries in MAP for major MODE." + (let ((ans nil) + (appentry (srecode-map-entry-for-app map app))) + (dolist (f (cdr appentry)) + (when (eq (cdr f) mode) + (setq ans (cons f ans)))) + ans)) + +(defmethod srecode-map-entry-for-file-anywhere ((map srecode-map) file) + "Search in all entry points in MAP for FILE. +Return a list ( APP . FILE-ASSOC ) where APP is nil +in the global map." + (or + ;; Look in the global entry + (let ((globalentry (srecode-map-entry-for-file map file))) + (when globalentry + (cons nil globalentry))) + ;; Look in each app. + (let ((match nil)) + (dolist (app (oref map apps)) + (let ((appmatch (assoc file (cdr app)))) + (when appmatch + (setq match (cons app appmatch))))) + match) + ;; Other? + )) + +(defmethod srecode-map-delete-file-entry ((map srecode-map) file) + "Update MAP to exclude FILE from the file list." + (let ((entry (srecode-map-entry-for-file map file))) + (when entry + (object-remove-from-list map 'files entry)))) + +(defmethod srecode-map-update-file-entry ((map srecode-map) file mode) + "Update a MAP entry for FILE to be used with MODE. +Return non-nil if the MAP was changed." + (let ((entry (srecode-map-entry-for-file map file)) + (dirty t)) + (cond + ;; It is already a match.. do nothing. + ((and entry (eq (cdr entry) mode)) + (setq dirty nil)) + ;; We have a non-matching entry. Change the cdr. + (entry + (setcdr entry mode)) + ;; No entry, just add it to the list. + (t + (object-add-to-list map 'files (cons file mode)) + )) + dirty)) + +(defmethod srecode-map-delete-file-entry-from-app ((map srecode-map) file app) + "Delete from MAP the FILE entry within the APP'lication." + (let* ((appe (srecode-map-entry-for-app map app)) + (fentry (assoc file (cdr appe)))) + (setcdr appe (delete fentry (cdr appe)))) + ) + +(defmethod srecode-map-update-app-file-entry ((map srecode-map) file mode app) + "Update the MAP entry for FILE to be used with MODE within APP. +Return non-nil if the map was changed." + (let* ((appentry (srecode-map-entry-for-app map app)) + (appfileentry (assoc file (cdr appentry))) + (dirty t) + ) + (cond + ;; Option 1 - We have this file in this application already + ;; with the correct mode. + ((and appfileentry (eq (cdr appfileentry) mode)) + (setq dirty nil) + ) + ;; Option 2 - We have a non-matching entry. Change Cdr. + (appfileentry + (setcdr appfileentry mode)) + (t + ;; For option 3 & 4 - remove the entry from any other lists + ;; we can find. + (let ((any (srecode-map-entry-for-file-anywhere map file))) + (when any + (if (null (car any)) + ;; Global map entry + (srecode-map-delete-file-entry map file) + ;; Some app + (let ((appentry (srecode-map-entry-for-app map app))) + (setcdr appentry (delete (cdr any) (cdr appentry)))) + ))) + ;; Now do option 3 and 4 + (cond + ;; Option 3 - No entry for app. Add to the list. + (appentry + (setcdr appentry (cons (cons file mode) (cdr appentry))) + ) + ;; Option 4 - No app entry. Add app to list with this file. + (t + (object-add-to-list map 'apps (list app (cons file mode))) + ))) + ) + dirty)) + + +;;; MAP Updating +;; +;;;###autoload +(defun srecode-get-maps (&optional reset) + "Get a list of maps relevant to the current buffer. +Optional argument RESET forces a reset of the current map." + (interactive "P") + ;; Always update the map, but only do a full reset if + ;; the user asks for one. + (srecode-map-update-map (not reset)) + + (if (interactive-p) + ;; Dump this map. + (with-output-to-temp-buffer "*SRECODE MAP*" + (princ " -- SRecode Global map --\n") + (srecode-maps-dump-file-list (oref srecode-current-map files)) + (princ "\n -- Application Maps --\n") + (dolist (ap (oref srecode-current-map apps)) + (let ((app (car ap)) + (files (cdr ap))) + (princ app) + (princ " :\n") + (srecode-maps-dump-file-list files)) + (princ "\n")) + (princ "\nUse:\n\n M-x customize-variable RET srecode-map-load-path RET") + (princ "\n To change the path where SRecode loads templates from.") + ) + ;; Eventually, I want to return many maps to search through. + (list srecode-current-map))) + +(eval-when-compile (require 'data-debug)) + +(defun srecode-adebug-maps () + "Run ADEBUG on the output of `srecode-get-maps'." + (interactive) + (require 'data-debug) + (let ((start (current-time)) + (p (srecode-get-maps t)) ;; Time the reset. + (end (current-time)) + ) + (message "Updating the map took %.2f seconds." + (semantic-elapsed-time start end)) + (data-debug-new-buffer "*SRECODE ADEBUG*") + (data-debug-insert-stuff-list p "*"))) + +(defun srecode-maps-dump-file-list (flist) + "Dump a file list FLIST to `standard-output'." + (princ "Mode\t\t\tFilename\n") + (princ "------\t\t\t------------------\n") + (dolist (fe flist) + (prin1 (cdr fe)) + (princ "\t") + (when (> (* 2 8) (length (symbol-name (cdr fe)))) + (princ "\t")) + (when (> 8 (length (symbol-name (cdr fe)))) + (princ "\t")) + (princ (car fe)) + (princ "\n") + )) + +(defun srecode-map-file-still-valid-p (filename map) + "Return t if FILENAME should be in MAP still." + (let ((valid nil)) + (and (file-exists-p filename) + (progn + (dolist (p srecode-map-load-path) + (when (and (< (length p) (length filename)) + (string= p (substring filename 0 (length p)))) + (setq valid t)) + ) + valid)) + )) + +(defun srecode-map-update-map (&optional fast) + "Update the current map from `srecode-map-load-path'. +Scans all the files on the path, and makes sure we have entries +for them. +If option FAST is non-nil, then only parse a file for the mode-string +if that file is NEW, otherwise assume the mode has not changed." + (interactive) + + ;; When no map file, we are configured to not use a save file. + (if (not srecode-map-save-file) + ;; 0) Create a MAP when in no save file mode. + (when (not srecode-current-map) + (setq srecode-current-map (srecode-map "SRecode Map")) + (message "SRecode map created in non-save mode.") + ) + + ;; 1) Do we even have a MAP or save file? + (when (and (not srecode-current-map) + (not (file-exists-p srecode-map-save-file))) + (when (not (file-exists-p (file-name-directory srecode-map-save-file))) + ;; Only bother with this interactively, not during a build + ;; or test. + (when (not noninteractive) + ;; No map, make the dir? + (if (y-or-n-p (format "Create dir %s? " + (file-name-directory srecode-map-save-file))) + (make-directory (file-name-directory srecode-map-save-file)) + ;; No make, change save file + (customize-variable 'srecode-map-save-file) + (error "Change your SRecode map file")))) + ;; Have a dir. Make the object. + (setq srecode-current-map + (srecode-map "SRecode Map" + :file srecode-map-save-file))) + + ;; 2) Do we not have a current map? If so load. + (when (not srecode-current-map) + (setq srecode-current-map + (eieio-persistent-read srecode-map-save-file)) + ) + + ) + + ;; + ;; We better have a MAP object now. + ;; + (let ((dirty nil)) + ;; 3) - Purge dead files from the file list. + (dolist (entry (copy-sequence (oref srecode-current-map files))) + (when (not (srecode-map-file-still-valid-p + (car entry) srecode-current-map)) + (srecode-map-delete-file-entry srecode-current-map (car entry)) + (setq dirty t) + )) + (dolist (app (copy-sequence (oref srecode-current-map apps))) + (dolist (entry (copy-sequence (cdr app))) + (when (not (srecode-map-file-still-valid-p + (car entry) srecode-current-map)) + (srecode-map-delete-file-entry-from-app + srecode-current-map (car entry) (car app)) + (setq dirty t) + ))) + ;; 4) - Find new files and add them to the map. + (dolist (dir srecode-map-load-path) + (when (file-exists-p dir) + (dolist (f (directory-files dir t "\\.srt$")) + (when (and (not (backup-file-name-p f)) + (not (auto-save-file-name-p f)) + (file-readable-p f)) + (let ((fdirty (srecode-map-validate-file-for-mode f fast))) + (setq dirty (or dirty fdirty)))) + ))) + ;; Only do the save if we are dirty, or if we are in an interactive + ;; Emacs. + (when (and dirty (not noninteractive) + (slot-boundp srecode-current-map :file)) + (eieio-persistent-save srecode-current-map)) + )) + +(defun srecode-map-validate-file-for-mode (file fast) + "Read and validate FILE via the parser. Return the mode. +Argument FAST implies that the file should not be reparsed if there +is already an entry for it. +Return non-nil if the map changed." + (when (or (not fast) + (not (srecode-map-entry-for-file-anywhere srecode-current-map file))) + (let ((buff-orig (get-file-buffer file)) + (dirty nil)) + (save-excursion + (if buff-orig + (set-buffer buff-orig) + (set-buffer (get-buffer-create " *srecode-map-tmp*")) + (insert-file-contents file nil nil nil t) + ;; Force it to be ready to parse. + (srecode-template-mode) + (let ((semantic-init-hook nil)) + (semantic-new-buffer-fcn)) + ) + + (semantic-fetch-tags) + (let* ((mode-tag + (semantic-find-first-tag-by-name "mode" (current-buffer))) + (val nil) + (app-tag + (semantic-find-first-tag-by-name "application" (current-buffer))) + (app nil)) + (if mode-tag + (setq val (car (semantic-tag-variable-default mode-tag))) + (error "There should be a mode declaration in %s" file)) + (when app-tag + (setq app (car (semantic-tag-variable-default app-tag)))) + + (setq dirty + (if app + (srecode-map-update-app-file-entry srecode-current-map + file + (read val) + (read app)) + (srecode-map-update-file-entry srecode-current-map + file + (read val)))) + ) + ) + dirty))) + + +;;; THE PATH +;; +;; We need to do this last since the setter needs the above code. + +(defun srecode-map-load-path-set (sym val) + "Set SYM to the new VAL, then update the srecode map." + (set-default sym val) + (srecode-map-update-map t)) + +(defcustom srecode-map-load-path + (list (srecode-map-base-template-dir) + (expand-file-name "~/.srecode/") + ) + "*Global load path for SRecode template files." + :group 'srecode + :type '(repeat file) + :set 'srecode-map-load-path-set) + +(provide 'srecode/map) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/map" +;; End: + +;;; srecode/map.el ends here diff --git a/lisp/cedet/srecode/mode.el b/lisp/cedet/srecode/mode.el new file mode 100644 index 00000000000..d085fbac34f --- /dev/null +++ b/lisp/cedet/srecode/mode.el @@ -0,0 +1,419 @@ +;;; srecode/mode.el --- Minor mode for managing and using SRecode templates + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Minor mode for working with SRecode template files. +;; +;; Depends on Semantic for minor-mode convenience functions. + +(require 'mode-local) +(require 'srecode) +(require 'srecode/insert) +(require 'srecode/find) +(require 'srecode/map) +(require 'semantic/decorate) +(require 'semantic/wisent) + +(eval-when-compile (require 'semantic/find)) + +;;; Code: + +(defcustom global-srecode-minor-mode nil + "Non-nil in buffers with Semantic Recoder macro keybindings." + :group 'srecode + :type 'boolean + :require 'srecode/mode + :initialize 'custom-initialize-default + :set (lambda (sym val) + (global-srecode-minor-mode (if val 1 -1)))) + +(defvar srecode-minor-mode nil + "Non-nil in buffers with Semantic Recoder macro keybindings.") +(make-variable-buffer-local 'srecode-minor-mode) + +(defcustom srecode-minor-mode-hook nil + "Hook run at the end of the function `srecode-minor-mode'." + :group 'srecode + :type 'hook) + +;; We don't want to waste space. There is a menu after all. +;;(add-to-list 'minor-mode-alist '(srecode-minor-mode "")) + +(defvar srecode-prefix-key [(control ?c) ?/] + "The common prefix key in srecode minor mode.") + +(defvar srecode-prefix-map + (let ((km (make-sparse-keymap))) + ;; Basic template codes + (define-key km "/" 'srecode-insert) + (define-key km [insert] 'srecode-insert) + (define-key km "." 'srecode-insert-again) + (define-key km "E" 'srecode-edit) + ;; Template indirect binding + (let ((k ?a)) + (while (<= k ?z) + (define-key km (format "%c" k) 'srecode-bind-insert) + (setq k (1+ k)))) + km) + "Keymap used behind the srecode prefix key in in srecode minor mode.") + +(defvar srecode-menu-bar + (list + "SRecoder" + (semantic-menu-item + ["Insert Template" + srecode-insert + :active t + :help "Insert a template by name." + ]) + (semantic-menu-item + ["Insert Template Again" + srecode-insert-again + :active t + :help "Run the same template as last time again." + ]) + (semantic-menu-item + ["Edit Template" + srecode-edit + :active t + :help "Edit a template for this language by name." + ]) + "---" + '( "Insert ..." :filter srecode-minor-mode-templates-menu ) + `( "Generate ..." :filter srecode-minor-mode-generate-menu ) + "---" + (semantic-menu-item + ["Customize..." + (customize-group "srecode") + :active t + :help "Customize SRecode options" + ]) + (list + "Debugging Tools..." + (semantic-menu-item + ["Dump Template MAP" + srecode-get-maps + :active t + :help "Calculate (if needed) and display the current template file map." + ]) + (semantic-menu-item + ["Dump Tables" + srecode-dump-templates + :active t + :help "Dump the current template table." + ]) + (semantic-menu-item + ["Dump Dictionary" + srecode-dictionary-dump + :active t + :help "Calculate a dump a dictionary for point." + ]) + ) + ) + "Menu for srecode minor mode.") + +(defvar srecode-minor-menu nil + "Menu keymap build from `srecode-menu-bar'.") + +(defcustom srecode-takeover-INS-key nil + "Use the insert key for inserting templates." + :group 'srecode + :type 'boolean) + +(defvar srecode-mode-map + (let ((km (make-sparse-keymap))) + (define-key km srecode-prefix-key srecode-prefix-map) + (easy-menu-define srecode-minor-menu km "Srecode Minor Mode Menu" + srecode-menu-bar) + (when srecode-takeover-INS-key + (define-key km [insert] srecode-prefix-map)) + km) + "Keymap for srecode minor mode.") + +;;;###autoload +(defun srecode-minor-mode (&optional arg) + "Toggle srecode minor mode. +With prefix argument ARG, turn on if positive, otherwise off. The +minor mode can be turned on only if semantic feature is available and +the current buffer was set up for parsing. Return non-nil if the +minor mode is enabled. + +\\{srecode-mode-map}" + (interactive + (list (or current-prefix-arg + (if srecode-minor-mode 0 1)))) + ;; Flip the bits. + (setq srecode-minor-mode + (if arg + (> + (prefix-numeric-value arg) + 0) + (not srecode-minor-mode))) + ;; If we are turning things on, make sure we have templates for + ;; this mode first. + (when srecode-minor-mode + (when (not (apply + 'append + (mapcar (lambda (map) + (srecode-map-entries-for-mode map major-mode)) + (srecode-get-maps)))) + (setq srecode-minor-mode nil)) + ) + ;; Run hooks if we are turning this on. + (when srecode-minor-mode + (run-hooks 'srecode-minor-mode-hook)) + srecode-minor-mode) + +;;;###autoload +(defun global-srecode-minor-mode (&optional arg) + "Toggle global use of srecode minor mode. +If ARG is positive, enable, if it is negative, disable. +If ARG is nil, then toggle." + (interactive "P") + (setq global-srecode-minor-mode + (semantic-toggle-minor-mode-globally + 'srecode-minor-mode arg))) + +;; Use the semantic minor mode magic stuff. +(semantic-add-minor-mode 'srecode-minor-mode "" srecode-mode-map) + +;;; Menu Filters +;; +(defun srecode-minor-mode-templates-menu (menu-def) + "Create a menu item of cascading filters active for this mode. +MENU-DEF is the menu to bind this into." + ;; Doing this SEGVs Emacs on windows. + ;;(srecode-load-tables-for-mode major-mode) + + (let* ((modetable (srecode-get-mode-table major-mode)) + (subtab (when modetable (oref modetable :tables))) + (context nil) + (active nil) + (ltab nil) + (temp nil) + (alltabs nil) + ) + (if (not subtab) + ;; No tables, show a "load the tables" option. + (list (vector "Load Mode Tables..." + (lambda () + (interactive) + (srecode-load-tables-for-mode major-mode)) + )) + ;; Build something + (setq context (car-safe (srecode-calculate-context))) + + (while subtab + (setq ltab (oref (car subtab) templates)) + (while ltab + (setq temp (car ltab)) + + ;; Do something with this template. + + (let* ((ctxt (oref temp context)) + (ctxtcons (assoc ctxt alltabs)) + (bind (if (slot-boundp temp 'binding) + (oref temp binding))) + (name (object-name-string temp))) + + (when (not ctxtcons) + (if (string= context ctxt) + ;; If this context is not in the current list of contexts + ;; is equal to the current context, then manage the + ;; active list instead + (setq active + (setq ctxtcons (or active (cons ctxt nil)))) + ;; This is not an active context, add it to alltabs. + (setq ctxtcons (cons ctxt nil)) + (setq alltabs (cons ctxtcons alltabs)))) + + (let ((new (vector + (if bind + (concat name " (" bind ")") + name) + `(lambda () (interactive) + (srecode-insert (concat ,ctxt ":" ,name))) + t))) + + (setcdr ctxtcons (cons + new + (cdr ctxtcons))))) + + (setq ltab (cdr ltab))) + (setq subtab (cdr subtab))) + + ;; Now create the menu + (easy-menu-filter-return + (easy-menu-create-menu + "Semantic Recoder Filters" + (append (cdr active) + alltabs) + )) + ))) + +(defvar srecode-minor-mode-generators nil + "List of code generators to be displayed in the srecoder menu.") + +(defun srecode-minor-mode-generate-menu (menu-def) + "Create a menu item of cascading filters active for this mode. +MENU-DEF is the menu to bind this into." + ;; Doing this SEGVs Emacs on windows. + ;;(srecode-load-tables-for-mode major-mode) + (let ((allgeneratorapps nil)) + + (dolist (gen srecode-minor-mode-generators) + (setq allgeneratorapps + (cons (vector (cdr gen) (car gen)) + allgeneratorapps)) + (message "Adding %S to srecode menu" (car gen)) + ) + + (easy-menu-filter-return + (easy-menu-create-menu + "Semantic Recoder Generate Filters" + allgeneratorapps))) + ) + +;;; Minor Mode commands +;; +(defun srecode-bind-insert () + "Bound insert for Srecode macros. +This command will insert whichever srecode template has a binding +to the current key." + (interactive) + (let* ((k last-command-event) + (ctxt (srecode-calculate-context)) + ;; Find the template with the binding K + (template (srecode-template-get-table-for-binding + (srecode-table) k ctxt))) + ;; test it. + (when (not template) + (error "No template bound to %c" k)) + ;; insert + (srecode-insert template) + )) + +(defun srecode-edit (template-name) + "Switch to the template buffer for TEMPLATE-NAME. +Template is chosen based on the mode of the starting buffer." + ;; @todo - Get a template stack from the last run template, and show + ;; those too! + (interactive (list (srecode-read-template-name + "Template Name: " + (car srecode-read-template-name-history)))) + (if (not (srecode-table)) + (error "No template table found for mode %s" major-mode)) + (let ((temp (srecode-template-get-table (srecode-table) template-name))) + (if (not temp) + (error "No Template named %s" template-name)) + ;; We need a template specific table, since tables chain. + (let ((tab (oref temp :table)) + (names nil) + ) + (find-file (oref tab :file)) + (setq names (semantic-find-tags-by-name (oref temp :object-name) + (current-buffer))) + (cond ((= (length names) 1) + (semantic-go-to-tag (car names)) + (semantic-momentary-highlight-tag (car names))) + ((> (length names) 1) + (let* ((ctxt (semantic-find-tags-by-name (oref temp :context) + (current-buffer))) + (cls (semantic-find-tags-by-class 'context ctxt)) + ) + (while (and names + (< (semantic-tag-start (car names)) + (semantic-tag-start (car cls)))) + (setq names (cdr names))) + (if names + (progn + (semantic-go-to-tag (car names)) + (semantic-momentary-highlight-tag (car names))) + (error "Can't find template %s" template-name)) + )) + (t (error "Can't find template %s" template-name))) + ))) + +(defun srecode-add-code-generator (function name &optional binding) + "Add the srecoder code generator FUNCTION with NAME to the menu. +Optional BINDING specifies the keybinding to use in the srecoder map. +BINDING should be a capital letter. Lower case letters are reserved +for individual templates. +Optional MODE specifies a major mode this function applies to. +Do not specify a mode if this function could be applied to most +programming modes." + ;; Update the menu generating part. + (let ((remloop nil)) + (while (setq remloop (assoc function srecode-minor-mode-generators)) + (setq srecode-minor-mode-generators + (remove remloop srecode-minor-mode-generators)))) + + (add-to-list 'srecode-minor-mode-generators + (cons function name)) + + ;; Remove this function from any old bindings. + (when binding + (let ((oldkey (where-is-internal function + (list srecode-prefix-map) + t t t))) + (if (or (not oldkey) + (and (= (length oldkey) 1) + (= (length binding) 1) + (= (aref oldkey 0) (aref binding 0)))) + ;; Its the same. + nil + ;; Remove the old binding + (define-key srecode-prefix-map oldkey nil) + ))) + + ;; Update Keybings + (let ((oldbinding (lookup-key srecode-prefix-map binding))) + + ;; During development, allow overrides. + (when (and oldbinding + (not (eq oldbinding function)) + (or (eq this-command 'eval-defun) (eq this-command 'checkdoc-eval-defun)) + (y-or-n-p (format "Override old binding %s? " oldbinding))) + (setq oldbinding nil)) + + (if (not oldbinding) + (define-key srecode-prefix-map binding function) + (if (eq function oldbinding) + nil + ;; Not the same. + (message "Conflict binding %S binding to srecode map." + binding)))) + ) + +;; Add default code generators: +(srecode-add-code-generator 'srecode-document-insert-comment "Comments" "C") +(srecode-add-code-generator 'srecode-insert-getset "Get/Set" "G") + +(provide 'srecode/mode) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/mode" +;; End: + +;;; srecode/mode.el ends here diff --git a/lisp/cedet/srecode/semantic.el b/lisp/cedet/srecode/semantic.el new file mode 100644 index 00000000000..22969db2323 --- /dev/null +++ b/lisp/cedet/srecode/semantic.el @@ -0,0 +1,431 @@ +;;; srecode/semantic.el --- Semantic specific extensions to SRecode. + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic specific extensions to the Semantic Recoder. +;; +;; I realize it is the "Semantic Recoder", but most of srecode +;; is a template library and set of user interfaces unrelated to +;; semantic in the specific. +;; +;; This file defines the following: +;; - :tag argument handling. +;; - <more goes here> + +;;; Code: + +(require 'srecode/insert) +(require 'srecode/dictionary) +(require 'semantic/find) +(require 'semantic/format) +(require 'semantic/senator) +(require 'ring) + + +;;; The SEMANTIC TAG inserter +;; +;; Put a tag into the dictionary that can be used w/ arbitrary +;; lisp expressions. + +(defclass srecode-semantic-tag (srecode-dictionary-compound-value) + ((prime :initarg :prime + :type semantic-tag + :documentation + "This is the primary insertion tag.") + ) + "Wrap up a collection of semantic tag information. +This class will be used to derive dictionary values.") + +(defmethod srecode-compound-toString((cp srecode-semantic-tag) + function + dictionary) + "Convert the compound dictionary value CP to a string. +If FUNCTION is non-nil, then FUNCTION is somehow applied to an +aspect of the compound value." + (if (not function) + ;; Just format it in some handy dandy way. + (semantic-format-tag-prototype (oref cp :prime)) + ;; Otherwise, apply the function to the tag itself. + (funcall function (oref cp :prime)) + )) + + +;;; Managing the `current' tag +;; + +(defvar srecode-semantic-selected-tag nil + "The tag selected by a :tag template argument. +If this is nil, then `senator-tag-ring' is used.") + +(defun srecode-semantic-tag-from-kill-ring () + "Create an `srecode-semantic-tag' from the senator kill ring." + (if (ring-empty-p senator-tag-ring) + (error "You must use `senator-copy-tag' to provide a tag to this template")) + (ring-ref senator-tag-ring 0)) + + +;;; TAG in a DICTIONARY +;; +(defvar srecode-semantic-apply-tag-augment-hook nil + "A function called for each tag added to a dictionary. +The hook is called with two arguments, the TAG and DICT +to be augmented.") + +(define-overload srecode-semantic-apply-tag-to-dict (tagobj dict) + "Insert fewatures of TAGOBJ into the dictionary DICT. +TAGOBJ is an object of class `srecode-semantic-tag'. This class +is a compound inserter value. +DICT is a dictionary object. +At a minimum, this function will create dictionary macro for NAME. +It is also likely to create macros for TYPE (data type), function arguments, +variable default values, and other things." + ) + +(defun srecode-semantic-apply-tag-to-dict-default (tagobj dict) + "Insert features of TAGOBJ into dictionary DICT." + ;; Store the sst into the dictionary. + (srecode-dictionary-set-value dict "TAG" tagobj) + + ;; Pull out the tag for the individual pieces. + (let ((tag (oref tagobj :prime))) + + (srecode-dictionary-set-value dict "NAME" (semantic-tag-name tag)) + (srecode-dictionary-set-value dict "TYPE" (semantic-format-tag-type tag nil)) + + (run-hook-with-args 'srecode-semantic-apply-tag-augment-hook tag dict) + + (cond + ;; + ;; FUNCTION + ;; + ((eq (semantic-tag-class tag) 'function) + ;; FCN ARGS + (let ((args (semantic-tag-function-arguments tag))) + (while args + (let ((larg (car args)) + (subdict (srecode-dictionary-add-section-dictionary + dict "ARGS"))) + ;; Clean up elements in the arg list. + (if (stringp larg) + (setq larg (semantic-tag-new-variable + larg nil nil))) + ;; Apply the sub-argument to the subdictionary. + (srecode-semantic-apply-tag-to-dict + (srecode-semantic-tag (semantic-tag-name larg) + :prime larg) + subdict) + ) + ;; Next! + (setq args (cdr args)))) + ;; PARENTS + (let ((p (semantic-tag-function-parent tag))) + (when p + (srecode-dictionary-set-value dict "PARENT" p) + )) + ;; EXCEPTIONS (java/c++) + (let ((exceptions (semantic-tag-get-attribute tag :throws))) + (while exceptions + (let ((subdict (srecode-dictionary-add-section-dictionary + dict "THROWS"))) + (srecode-dictionary-set-value subdict "NAME" (car exceptions)) + ) + (setq exceptions (cdr exceptions))) + ) + ) + ;; + ;; VARIABLE + ;; + ((eq (semantic-tag-class tag) 'variable) + (when (semantic-tag-variable-default tag) + (let ((subdict (srecode-dictionary-add-section-dictionary + dict "HAVEDEFAULT"))) + (srecode-dictionary-set-value + subdict "VALUE" (semantic-tag-variable-default tag)))) + ) + ;; + ;; TYPE + ;; + ((eq (semantic-tag-class tag) 'type) + (dolist (p (semantic-tag-type-superclasses tag)) + (let ((sd (srecode-dictionary-add-section-dictionary + dict "PARENTS"))) + (srecode-dictionary-set-value sd "NAME" p) + )) + (dolist (i (semantic-tag-type-interfaces tag)) + (let ((sd (srecode-dictionary-add-section-dictionary + dict "INTERFACES"))) + (srecode-dictionary-set-value sd "NAME" i) + )) +; NOTE : The members are too complicated to do via a template. +; do it via the insert-tag solution instead. +; +; (dolist (mem (semantic-tag-type-members tag)) +; (let ((subdict (srecode-dictionary-add-section-dictionary +; dict "MEMBERS"))) +; (when (stringp mem) +; (setq mem (semantic-tag-new-variable mem nil nil))) +; (srecode-semantic-apply-tag-to-dict +; (srecode-semantic-tag (semantic-tag-name mem) +; :prime mem) +; subdict))) + )))) + + +;;; ARGUMENT HANDLERS + +;;; :tag ARGUMENT HANDLING +;; +;; When a :tag argument is required, identify the current :tag, +;; and apply it's parts into the dictionary. +(defun srecode-semantic-handle-:tag (dict) + "Add macroes into the dictionary DICT based on the current :tag." + ;; We have a tag, start adding "stuff" into the dictionary. + (let ((tag (or srecode-semantic-selected-tag + (srecode-semantic-tag-from-kill-ring)))) + (when (not tag) + "No tag for current template. Use the semantic kill-ring.") + (srecode-semantic-apply-tag-to-dict + (srecode-semantic-tag (semantic-tag-name tag) + :prime tag) + dict))) + +;;; :tagtype ARGUMENT HANDLING +;; +;; When a :tagtype argument is required, identify the current tag, of +;; cf class 'type. Apply those parameters to the dictionary. + +(defun srecode-semantic-handle-:tagtype (dict) + "Add macroes into the dictionary DICT based on a tag of class type at point. +Assumes the cursor is in a tag of class type. If not, throw an error." + (let ((typetag (or srecode-semantic-selected-tag + (semantic-current-tag-of-class 'type)))) + (when (not typetag) + (error "Cursor is not in a TAG of class 'type")) + (srecode-semantic-apply-tag-to-dict + typetag + dict))) + + +;;; INSERT A TAG API +;; +;; Routines that take a tag, and insert into a buffer. +(define-overload srecode-semantic-find-template (class prototype ctxt) + "Find a template for a tag of class CLASS based on context. +PROTOTYPE is non-nil if we want a prototype template instead." + ) + +(defun srecode-semantic-find-template-default (class prototype ctxt) + "Find a template for tag CLASS based on context. +PROTOTYPE is non-nil if we need a prototype. +CTXT is the pre-calculated context." + (let* ((top (car ctxt)) + (tname (if (stringp class) + class + (symbol-name class))) + (temp nil) + ) + ;; Try to find a template. + (setq temp (or + (when prototype + (srecode-template-get-table (srecode-table) + (concat tname "-tag-prototype") + top)) + (when prototype + (srecode-template-get-table (srecode-table) + (concat tname "-prototype") + top)) + (srecode-template-get-table (srecode-table) + (concat tname "-tag") + top) + (srecode-template-get-table (srecode-table) + tname + top) + (when (and (not (string= top "declaration")) + prototype) + (srecode-template-get-table (srecode-table) + (concat tname "-prototype") + "declaration")) + (when (and (not (string= top "declaration")) + prototype) + (srecode-template-get-table (srecode-table) + (concat tname "-tag-prototype") + "declaration")) + (when (not (string= top "declaration")) + (srecode-template-get-table (srecode-table) + (concat tname "-tag") + "declaration")) + (when (not (string= top "declaration")) + (srecode-template-get-table (srecode-table) + tname + "declaration")) + )) + temp)) + +(defun srecode-semantic-insert-tag (tag &optional style-option + point-insert-fcn + &rest dict-entries) + "Insert TAG into a buffer useing srecode templates at point. + +Optional STYLE-OPTION is a list of minor configuration of styles, +such as the symbol 'prototype for prototype functions, or +'system for system includes, and 'doxygen, for a doxygen style +comment. + +Optional third argument POINT-INSERT-FCN is a hook that is run after +TAG is inserted that allows an opportunity to fill in the body of +some thing. This hook function is called with one argument, the TAG +being inserted. + +The rest of the arguments are DICT-ENTRIES. DICT-ENTRIES +is of the form ( NAME1 VALUE1 NAME2 VALUE2 ... NAMEn VALUEn). + +The exact template used is based on the current context. +The template used is found within the toplevel context as calculated +by `srecode-calculate-context', such as `declaration', `classdecl', +or `code'. + +For various conditions, this function looks for a template with +the name CLASS-tag, where CLASS is the tag class. If it cannot +find that, it will look for that template in the +`declaration'context (if the current context was not `declaration'). + +If PROTOTYPE is specified, it will first look for templates with +the name CLASS-tag-prototype, or CLASS-prototype as above. + +See `srecode-semantic-apply-tag-to-dict' for details on what is in +the dictionary when the templates are called. + +This function returns to location in the buffer where the +inserted tag ENDS, and will leave point inside the inserted +text based on any occurance of a point-inserter. Templates such +as `function' will leave point where code might be inserted." + (srecode-load-tables-for-mode major-mode) + (let* ((ctxt (srecode-calculate-context)) + (top (car ctxt)) + (tname (symbol-name (semantic-tag-class tag))) + (dict (srecode-create-dictionary)) + (temp nil) + (errtype tname) + (prototype (memq 'prototype style-option)) + ) + ;; Try some special cases. + (cond ((and (semantic-tag-of-class-p tag 'function) + (semantic-tag-get-attribute tag :constructor-flag)) + (setq temp (srecode-semantic-find-template + "constructor" prototype ctxt)) + ) + + ((and (semantic-tag-of-class-p tag 'function) + (semantic-tag-get-attribute tag :destructor-flag)) + (setq temp (srecode-semantic-find-template + "destructor" prototype ctxt)) + ) + + ((and (semantic-tag-of-class-p tag 'function) + (semantic-tag-function-parent tag)) + (setq temp (srecode-semantic-find-template + "method" prototype ctxt)) + ) + + ((and (semantic-tag-of-class-p tag 'variable) + (semantic-tag-get-attribute tag :constant-flag)) + (setq temp (srecode-semantic-find-template + "variable-const" prototype ctxt)) + ) + ) + + (when (not temp) + ;; Try the basics + (setq temp (srecode-semantic-find-template + tname prototype ctxt))) + + ;; Try some backup template names. + (when (not temp) + (cond + ;; Types might split things up based on the type's type. + ((and (eq (semantic-tag-class tag) 'type) + (semantic-tag-type tag)) + (setq temp (srecode-semantic-find-template + (semantic-tag-type tag) prototype ctxt)) + (setq errtype (concat errtype " or " (semantic-tag-type tag))) + ) + ;; A function might be an externally declared method. + ((and (eq (semantic-tag-class tag) 'function) + (semantic-tag-function-parent tag)) + (setq temp (srecode-semantic-find-template + "method" prototype ctxt))) + (t + nil) + )) + + ;; Can't find one? Drat! + (when (not temp) + (error "Cannot find template %s in %s for inserting tag %S" + errtype top (semantic-format-tag-summarize tag))) + + ;; Resolve Arguments + (let ((srecode-semantic-selected-tag tag)) + (srecode-resolve-arguments temp dict)) + + ;; Resolve TAG into the dictionary. We may have a :tag arg + ;; from the macro such that we don't need to do this. + (when (not (srecode-dictionary-lookup-name dict "TAG")) + (let ((tagobj (srecode-semantic-tag (semantic-tag-name tag) :prime tag)) + ) + (srecode-semantic-apply-tag-to-dict tagobj dict))) + + ;; Insert dict-entries into the dictionary LAST so that previous + ;; items can be overriden. + (let ((entries dict-entries)) + (while entries + (srecode-dictionary-set-value dict + (car entries) + (car (cdr entries))) + (setq entries (cdr (cdr entries))))) + + ;; Insert the template. + (let ((endpt (srecode-insert-fcn temp dict nil t))) + + (run-hook-with-args 'point-insert-fcn tag) + ;;(sit-for 1) + + (cond + ((semantic-tag-of-class-p tag 'type) + ;; Insert all the members at the current insertion point. + (dolist (m (semantic-tag-type-members tag)) + + (when (stringp m) + (setq m (semantic-tag-new-variable m nil nil))) + + ;; We do prototypes w/in the class decl? + (let ((me (srecode-semantic-insert-tag m '(prototype)))) + (goto-char me)) + + )) + ) + + endpt) + )) + +(provide 'srecode/semantic) + +;;; srecode/semantic.el ends here diff --git a/lisp/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el new file mode 100644 index 00000000000..9034544482c --- /dev/null +++ b/lisp/cedet/srecode/srt-mode.el @@ -0,0 +1,751 @@ +;;; srecode/srt-mode.el --- Major mode for writing screcode macros + +;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Originally named srecode-template-mode.el in the CEDET repository. + +(require 'srecode/compile) +(require 'srecode/ctxt) +(require 'srecode/template) + +(require 'semantic) +(require 'semantic/analyze) +(require 'semantic/wisent) +(eval-when-compile + (require 'semantic/find)) + +(declare-function srecode-create-dictionary "srecode/dictionary") +(declare-function srecode-resolve-argument-list "srecode/insert") + +;;; Code: +(defvar srecode-template-mode-syntax-table + (let ((table (make-syntax-table (standard-syntax-table)))) + (modify-syntax-entry ?\; ". 12" table) ;; SEMI, Comment start ;; + (modify-syntax-entry ?\n ">" table) ;; Comment end + (modify-syntax-entry ?$ "." table) ;; Punctuation + (modify-syntax-entry ?: "." table) ;; Punctuation + (modify-syntax-entry ?< "." table) ;; Punctuation + (modify-syntax-entry ?> "." table) ;; Punctuation + (modify-syntax-entry ?# "." table) ;; Punctuation + (modify-syntax-entry ?! "." table) ;; Punctuation + (modify-syntax-entry ?? "." table) ;; Punctuation + (modify-syntax-entry ?\" "\"" table) ;; String + (modify-syntax-entry ?\- "_" table) ;; Symbol + (modify-syntax-entry ?\\ "\\" table) ;; Quote + (modify-syntax-entry ?\` "'" table) ;; Prefix ` (backquote) + (modify-syntax-entry ?\' "'" table) ;; Prefix ' (quote) + (modify-syntax-entry ?\, "'" table) ;; Prefix , (comma) + + table) + "Syntax table used in semantic recoder macro buffers.") + +(defface srecode-separator-face + '((t (:weight bold :strike-through t))) + "Face used for decorating separators in srecode template mode." + :group 'srecode) + +(defvar srecode-font-lock-keywords + '( + ;; Template + ("^\\(template\\)\\s-+\\(\\w*\\)\\(\\( \\(:\\w+\\)\\|\\)+\\)$" + (1 font-lock-keyword-face) + (2 font-lock-function-name-face) + (3 font-lock-builtin-face )) + ("^\\(sectiondictionary\\)\\s-+\"" + (1 font-lock-keyword-face)) + ("^\\(bind\\)\\s-+\"" + (1 font-lock-keyword-face)) + ;; Variable type setting + ("^\\(set\\)\\s-+\\(\\w+\\)\\s-+" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face)) + ("^\\(show\\)\\s-+\\(\\w+\\)\\s-*$" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face)) + ("\\<\\(macro\\)\\s-+\"" + (1 font-lock-keyword-face)) + ;; Context type setting + ("^\\(context\\)\\s-+\\(\\w+\\)" + (1 font-lock-keyword-face) + (2 font-lock-builtin-face)) + ;; Prompting setting + ("^\\(prompt\\)\\s-+\\(\\w+\\)" + (1 font-lock-keyword-face) + (2 font-lock-variable-name-face)) + ("\\(default\\(macro\\)?\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)" + (1 font-lock-keyword-face) + (3 font-lock-type-face)) + ("\\<\\(default\\(macro\\)?\\)\\>" (1 font-lock-keyword-face)) + ("\\<\\(read\\)\\s-+\\(\\(\\w\\|\\s_\\)+\\)" + (1 font-lock-keyword-face) + (2 font-lock-type-face)) + + ;; Macro separators + ("^----\n" 0 'srecode-separator-face) + + ;; Macro Matching + (srecode-template-mode-macro-escape-match 1 font-lock-string-face) + ((lambda (limit) + (srecode-template-mode-font-lock-macro-helper + limit "\\(\\??\\w+\\)[^ \t\n{}$#@&*()]*")) + 1 font-lock-variable-name-face) + ((lambda (limit) + (srecode-template-mode-font-lock-macro-helper + limit "\\([#/]\\w+\\)[^ \t\n{}$#@&*()]*")) + 1 font-lock-keyword-face) + ((lambda (limit) + (srecode-template-mode-font-lock-macro-helper + limit "\\([<>]\\w*\\):\\(\\w+\\):\\(\\w+\\)")) + (1 font-lock-keyword-face) + (2 font-lock-builtin-face) + (3 font-lock-type-face)) + ((lambda (limit) + (srecode-template-mode-font-lock-macro-helper + limit "\\([<>?]?\\w*\\):\\(\\w+\\)")) + (1 font-lock-keyword-face) + (2 font-lock-type-face)) + ((lambda (limit) + (srecode-template-mode-font-lock-macro-helper + limit "!\\([^{}$]*\\)")) + 1 font-lock-comment-face) + + ) + "Keywords for use with srecode macros and font-lock.") + +(defun srecode-template-mode-font-lock-macro-helper (limit expression) + "Match against escape characters. +Don't scan past LIMIT. Match with EXPRESSION." + (let* ((done nil) + (md nil) + (es (regexp-quote (srecode-template-get-escape-start))) + (ee (regexp-quote (srecode-template-get-escape-end))) + (regex (concat es expression ee)) + ) + (while (not done) + (save-match-data + (if (re-search-forward regex limit t) + (when (equal (car (srecode-calculate-context)) "code") + (setq md (match-data) + done t)) + (setq done t)))) + (set-match-data md) + ;; (when md (message "Found a match!")) + (when md t))) + +(defun srecode-template-mode-macro-escape-match (limit) + "Match against escape characters. +Don't scan past LIMIT." + (let* ((done nil) + (md nil) + (es (regexp-quote (srecode-template-get-escape-start))) + (ee (regexp-quote (srecode-template-get-escape-end))) + (regex (concat "\\(" es "\\|" ee "\\)")) + ) + (while (not done) + (save-match-data + (if (re-search-forward regex limit t) + (when (equal (car (srecode-calculate-context)) "code") + (setq md (match-data) + done t)) + (setq done t)))) + (set-match-data md) + ;;(when md (message "Found a match!")) + (when md t))) + +(defvar srecode-font-lock-macro-keywords nil + "Dynamically generated `font-lock' keywords for srecode templates. +Once the escape_start, and escape_end sequences are known, then +we can tell font lock about them.") + +(defvar srecode-template-mode-map + (let ((km (make-sparse-keymap))) + (define-key km "\C-c\C-c" 'srecode-compile-templates) + (define-key km "\C-c\C-m" 'srecode-macro-help) + (define-key km "/" 'srecode-self-insert-complete-end-macro) + km) + "Keymap used in srecode mode.") + +;;;###autoload +(defun srecode-template-mode () + "Major-mode for writing srecode macros." + (interactive) + (kill-all-local-variables) + (setq major-mode 'srecode-template-mode + mode-name "SRecoder" + comment-start ";;" + comment-end "") + (set (make-local-variable 'parse-sexp-ignore-comments) t) + (set (make-local-variable 'comment-start-skip) + "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + (set-syntax-table srecode-template-mode-syntax-table) + (use-local-map srecode-template-mode-map) + (set (make-local-variable 'font-lock-defaults) + '(srecode-font-lock-keywords + nil ;; perform string/comment fontification + nil ;; keywords are case sensitive. + ;; This puts _ & - as a word constituant, + ;; simplifying our keywords significantly + ((?_ . "w") (?- . "w")))) + (run-hooks 'srecode-template-mode-hook)) + +;;;###autoload +(defalias 'srt-mode 'srecode-template-mode) + +;;; Template Commands +;; +(defun srecode-self-insert-complete-end-macro () + "Self insert the current key, then autocomplete the end macro." + (interactive) + (call-interactively 'self-insert-command) + (when (and (semantic-current-tag) + (semantic-tag-of-class-p (semantic-current-tag) 'function) + ) + (let* ((es (srecode-template-get-escape-start)) + (ee (srecode-template-get-escape-end)) + (name (save-excursion + (forward-char (- (length es))) + (forward-char -1) + (if (looking-at (regexp-quote es)) + (srecode-up-context-get-name (point) t)))) + ) + (when name + (insert name) + (insert ee)))) + ) + + +(defun srecode-macro-help () + "Provide help for working with macros in a tempalte." + (interactive) + (let* ((root 'srecode-template-inserter) + (chl (aref (class-v root) class-children)) + (ess (srecode-template-get-escape-start)) + (ees (srecode-template-get-escape-end)) + ) + (with-output-to-temp-buffer "*SRecode Macros*" + (princ "Description of known SRecode Template Macros.") + (terpri) + (terpri) + (while chl + (let* ((C (car chl)) + (name (symbol-name C)) + (key (when (slot-exists-p C 'key) + (oref C key))) + (showexample t) + ) + (setq chl (cdr chl)) + (setq chl (append (aref (class-v C) class-children) chl)) + + (catch 'skip + (when (eq C 'srecode-template-inserter-section-end) + (throw 'skip nil)) + + (when (class-abstract-p C) + (throw 'skip nil)) + + (princ "`") + (princ name) + (princ "'") + (when (slot-exists-p C 'key) + (when key + (princ " - Character Key: ") + (if (stringp key) + (progn + (setq showexample nil) + (cond ((string= key "\n") + (princ "\"\\n\"") + ) + (t + (prin1 key) + ))) + (prin1 (format "%c" key)) + ))) + (terpri) + (princ (documentation-property C 'variable-documentation)) + (terpri) + (when showexample + (princ "Example:") + (terpri) + (srecode-inserter-prin-example C ess ees) + ) + + (terpri) + + ) ;; catch + );; let* + )))) + + +;;; Misc Language Overrides +;; +(define-mode-local-override semantic-ia-insert-tag + srecode-template-mode (tag) + "Insert the SRecode TAG into the current buffer." + (insert (semantic-tag-name tag))) + + +;;; Local Context Parsing. + +(defun srecode-in-macro-p (&optional point) + "Non-nil if POINT is inside a macro bounds. +If the ESCAPE_START and END are different sequences, +a simple search is used. If ESCAPE_START and END are the same +characteres, start at the beginning of the line, and find out +how many occur." + (let ((tag (semantic-current-tag)) + (es (regexp-quote (srecode-template-get-escape-start))) + (ee (regexp-quote (srecode-template-get-escape-end))) + (start (or point (point))) + ) + (when (and tag (semantic-tag-of-class-p tag 'function)) + (if (string= es ee) + (save-excursion + (beginning-of-line) + (while (re-search-forward es start t 2)) + (if (re-search-forward es start t) + ;; If there is a single, the the answer is yes. + t + ;; If there wasn't another, then the answer is no. + nil) + ) + ;; ES And EE are not the same. + (save-excursion + (and (re-search-backward es (semantic-tag-start tag) t) + (>= (or (re-search-forward ee (semantic-tag-end tag) t) + ;; No end match means an incomplete macro. + start) + start))) + )))) + +(defun srecode-up-context-get-name (&optional point find-unmatched) + "Move up one context as for `semantic-up-context', and return the name. +Moves point to the opening characters of the section macro text. +If there is no upper context, return nil. +Starts at POINT if provided. +If FIND-UNMATCHED is specified as non-nil, then we are looking for an unmatched +section." + (when point (goto-char (point))) + (let* ((tag (semantic-current-tag)) + (es (regexp-quote (srecode-template-get-escape-start))) + (start (concat es "[#<]\\(\\w+\\)")) + (orig (point)) + (name nil) + (res nil)) + (when (semantic-tag-of-class-p tag 'function) + (while (and (not res) + (re-search-backward start (semantic-tag-start tag) t)) + (when (save-excursion + (setq name (match-string 1)) + (let ((endr (concat es "/" name))) + (if (re-search-forward endr (semantic-tag-end tag) t) + (< orig (point)) + (if (not find-unmatched) + (error "Unmatched Section Template") + ;; We found what we want. + t)))) + (setq res (point))) + ) + ;; Restore in no result found. + (goto-char (or res orig)) + name))) + +(define-mode-local-override semantic-up-context + srecode-template-mode (&optional point) + "Move up one context in the current code. +Moves out one named section." + (not (srecode-up-context-get-name point))) + +(define-mode-local-override semantic-beginning-of-context + srecode-template-mode (&optional point) + "Move to the beginning of the current context. +Moves the the beginning of one named section." + (if (semantic-up-context point) + t + (let ((es (regexp-quote (srecode-template-get-escape-start))) + (ee (regexp-quote (srecode-template-get-escape-end)))) + (re-search-forward es) ;; move over the start chars. + (re-search-forward ee) ;; Move after the end chars. + nil))) + +(define-mode-local-override semantic-end-of-context + srecode-template-mode (&optional point) + "Move to the beginning of the current context. +Moves the the beginning of one named section." + (let ((name (srecode-up-context-get-name point)) + (tag (semantic-current-tag)) + (es (regexp-quote (srecode-template-get-escape-start)))) + (if (not name) + t + (unless (re-search-forward (concat es "/" name) (semantic-tag-end tag) t) + (error "Section %s has no end" name)) + (goto-char (match-beginning 0)) + nil))) + +(define-mode-local-override semantic-get-local-variables + srecode-template-mode (&optional point) + "Get local variables from an SRecode template." + (save-excursion + (when point (goto-char (point))) + (let* ((tag (semantic-current-tag)) + (name (save-excursion + (srecode-up-context-get-name (point)))) + (subdicts (semantic-tag-get-attribute tag :dictionaries)) + (global nil) + ) + (dolist (D subdicts) + (setq global (cons (semantic-tag-new-variable (car D) nil) + global))) + (if name + ;; Lookup any subdictionaries in TAG. + (let ((res nil)) + + (while (and (not res) subdicts) + ;; Find the subdictionary with the same name. Those variables + ;; are now local to this section. + (when (string= (car (car subdicts)) name) + (setq res (cdr (car subdicts)))) + (setq subdicts (cdr subdicts))) + ;; Pre-pend our global vars. + (append global res)) + ;; If we aren't in a subsection, just do the global variables + global + )))) + +(define-mode-local-override semantic-get-local-arguments + srecode-template-mode (&optional point) + "Get local arguments from an SRecode template." + (require 'srecode/insert) + (save-excursion + (when point (goto-char (point))) + (let* ((tag (semantic-current-tag)) + (args (semantic-tag-function-arguments tag)) + (argsym (mapcar 'intern args)) + (argvars nil) + ;; Create a temporary dictionary in which the + ;; arguments can be resolved so we can extract + ;; the results. + (dict (srecode-create-dictionary t)) + ) + ;; Resolve args into our temp dictionary + (srecode-resolve-argument-list argsym dict) + + (maphash + (lambda (key entry) + (setq argvars + (cons (semantic-tag-new-variable key nil entry) + argvars))) + (oref dict namehash)) + + argvars))) + +(define-mode-local-override semantic-ctxt-current-symbol + srecode-template-mode (&optional point) + "Return the current symbol under POINT. +Return nil if point is not on/in a template macro." + (let ((macro (srecode-parse-this-macro point))) + (cdr macro)) + ) + +(defun srecode-parse-this-macro (&optional point) + "Return the current symbol under POINT. +Return nil if point is not on/in a template macro. +The first element is the key for the current macro, such as # for a +section or ? for an ask variable." + (save-excursion + (if point (goto-char point)) + (let ((tag (semantic-current-tag)) + (es (regexp-quote (srecode-template-get-escape-start))) + (ee (regexp-quote (srecode-template-get-escape-end))) + (start (point)) + (macrostart nil) + (raw nil) + ) + (when (and tag (semantic-tag-of-class-p tag 'function) + (srecode-in-macro-p point) + (re-search-backward es (semantic-tag-start tag) t)) + (setq macrostart (match-end 0)) + (goto-char macrostart) + ;; We have a match + (when (not (re-search-forward ee (semantic-tag-end tag) t)) + (goto-char start) ;; Pretend we are ok for completion + (set-match-data (list start start)) + ) + + (if (> start (point)) + ;; If our starting point is after the found point, that + ;; means we are not inside the macro. Retur nil. + nil + ;; We are inside the macro, extract the text so far. + (let* ((macroend (match-beginning 0)) + (raw (buffer-substring-no-properties + macrostart macroend)) + (STATE (srecode-compile-state "TMP")) + (inserter (condition-case nil + (srecode-compile-parse-inserter + raw STATE) + (error nil))) + ) + (when inserter + (let ((base + (cons (oref inserter :object-name) + (if (and (slot-boundp inserter :secondname) + (oref inserter :secondname)) + (split-string (oref inserter :secondname) + ":") + nil))) + (key (oref inserter key))) + (cond ((null key) + ;; A plain variable + (cons nil base)) + (t + ;; A complex variable thingy. + (cons (format "%c" key) + base))))) + ) + ))) + )) + +(define-mode-local-override semantic-analyze-current-context + srecode-template-mode (point) + "Provide a Semantic analysis in SRecode template mode." + (let* ((context-return nil) + (prefixandbounds (semantic-ctxt-current-symbol-and-bounds)) + (prefix (car prefixandbounds)) + (bounds (nth 2 prefixandbounds)) + (key (car (srecode-parse-this-macro (point)))) + (prefixsym nil) + (prefix-var nil) + (prefix-context nil) + (prefix-function nil) + (prefixclass (semantic-ctxt-current-class-list)) + (globalvar (semantic-find-tags-by-class 'variable (current-buffer))) + (argtype 'macro) + (scope (semantic-calculate-scope point)) + ) + + (oset scope fullscope (append (oref scope localvar) globalvar)) + + (when prefix + ;; First, try to find the variable for the first + ;; entry in the prefix list. + (setq prefix-var (semantic-find-first-tag-by-name + (car prefix) (oref scope fullscope))) + + (cond + ((and (or (not key) (string= key "?")) + (> (length prefix) 1)) + ;; Variables can have lisp function names. + (with-mode-local emacs-lisp-mode + (let ((fcns (semanticdb-find-tags-by-name (car (last prefix))))) + (setq prefix-function (car (semanticdb-find-result-nth fcns 0))) + (setq argtype 'elispfcn))) + ) + ((or (string= key "<") (string= key ">")) + ;; Includes have second args that is the template name. + (if (= (length prefix) 3) + (let ((contexts (semantic-find-tags-by-class + 'context (current-buffer)))) + (setq prefix-context + (or (semantic-find-first-tag-by-name + (nth 1 prefix) contexts) + ;; Calculate from location + (semantic-tag + (symbol-name + (srecode-template-current-context)) + 'context))) + (setq argtype 'template)) + (setq prefix-context + ;; Calculate from location + (semantic-tag + (symbol-name (srecode-template-current-context)) + 'context)) + (setq argtype 'template) + ) + ;; The last one? + (when (> (length prefix) 1) + (let ((toc (srecode-template-find-templates-of-context + (read (semantic-tag-name prefix-context)))) + ) + (setq prefix-function + (or (semantic-find-first-tag-by-name + (car (last prefix)) toc) + ;; Not in this buffer? Search the master + ;; templates list. + nil)) + )) + ) + ) + + (setq prefixsym + (cond ((= (length prefix) 3) + (list (or prefix-var (nth 0 prefix)) + (or prefix-context (nth 1 prefix)) + (or prefix-function (nth 2 prefix)))) + ((= (length prefix) 2) + (list (or prefix-var (nth 0 prefix)) + (or prefix-function (nth 1 prefix)))) + ((= (length prefix) 1) + (list (or prefix-var (nth 0 prefix))) + ))) + + (setq context-return + (semantic-analyze-context-functionarg + "context-for-srecode" + :buffer (current-buffer) + :scope scope + :bounds bounds + :prefix (or prefixsym + prefix) + :prefixtypes nil + :prefixclass prefixclass + :errors nil + ;; Use the functionarg analyzer class so we + ;; can save the current key, and the index + ;; into the macro part we are completing on. + :function (list key) + :index (length prefix) + :argument (list argtype) + )) + + context-return))) + +(define-mode-local-override semantic-analyze-possible-completions + srecode-template-mode (context) + "Return a list of possible completions based on NONTEXT." + (save-excursion + (set-buffer (oref context buffer)) + (let* ((prefix (car (last (oref context :prefix)))) + (prefixstr (cond ((stringp prefix) + prefix) + ((semantic-tag-p prefix) + (semantic-tag-name prefix)))) +; (completetext (cond ((semantic-tag-p prefix) +; (semantic-tag-name prefix)) +; ((stringp prefix) +; prefix) +; ((stringp (car prefix)) +; (car prefix)))) + (argtype (car (oref context :argument))) + (matches nil)) + + ;; Depending on what the analyzer is, we have different ways + ;; of creating completions. + (cond ((eq argtype 'template) + (setq matches (semantic-find-tags-for-completion + prefixstr (current-buffer))) + (setq matches (semantic-find-tags-by-class + 'function matches)) + ) + ((eq argtype 'elispfcn) + (with-mode-local emacs-lisp-mode + (setq matches (semanticdb-find-tags-for-completion + prefixstr)) + (setq matches (semantic-find-tags-by-class + 'function matches)) + ) + ) + ((eq argtype 'macro) + (let ((scope (oref context scope))) + (setq matches + (semantic-find-tags-for-completion + prefixstr (oref scope fullscope)))) + ) + ) + + matches))) + + + +;;; Utils +;; +(defun srecode-template-get-mode () + "Get the supported major mode for this template file." + (let ((m (semantic-find-first-tag-by-name "mode" (current-buffer)))) + (when m (read (semantic-tag-variable-default m))))) + +(defun srecode-template-get-escape-start () + "Get the current escape_start characters." + (let ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer))) + ) + (if es (car (semantic-tag-get-attribute es :default-value)) + "{{"))) + +(defun srecode-template-get-escape-end () + "Get the current escape_end characters." + (let ((ee (semantic-find-first-tag-by-name "escape_end" (current-buffer))) + ) + (if ee (car (semantic-tag-get-attribute ee :default-value)) + "}}"))) + +(defun srecode-template-current-context (&optional point) + "Calculate the context encompassing POINT." + (save-excursion + (when point (goto-char (point))) + (let ((ct (semantic-current-tag))) + (when (not ct) + (setq ct (semantic-find-tag-by-overlay-prev))) + + ;; Loop till we find the context. + (while (and ct (not (semantic-tag-of-class-p ct 'context))) + (setq ct (semantic-find-tag-by-overlay-prev + (semantic-tag-start ct)))) + + (if ct + (read (semantic-tag-name ct)) + 'declaration)))) + +(defun srecode-template-find-templates-of-context (context &optional buffer) + "Find all the templates belonging to a particular CONTEXT. +When optional BUFFER is provided, search that buffer." + (save-excursion + (when buffer (set-buffer buffer)) + (let ((tags (semantic-fetch-available-tags)) + (cc 'declaration) + (scan nil) + (ans nil)) + + (when (eq cc context) + (setq scan t)) + + (dolist (T tags) + ;; Handle contexts + (when (semantic-tag-of-class-p T 'context) + (setq cc (read (semantic-tag-name T))) + (when (eq cc context) + (setq scan t))) + + ;; Scan + (when (and scan (semantic-tag-of-class-p T 'function)) + (setq ans (cons T ans))) + ) + + (nreverse ans)))) + +(provide 'srecode/srt-mode) + +;; The autoloads in this file must go into the global loaddefs.el, not +;; the srecode one, so that srecode-template-mode can be called from +;; auto-mode-alist. + +;; Local variables: +;; generated-autoload-load-name: "srecode/srt-mode" +;; End: + +;;; srecode/srt-mode.el ends here diff --git a/lisp/cedet/srecode/srt-wy.el b/lisp/cedet/srecode/srt-wy.el new file mode 100644 index 00000000000..4446a66afca --- /dev/null +++ b/lisp/cedet/srecode/srt-wy.el @@ -0,0 +1,277 @@ +;;; srecode/srt-wy.el --- Generated parser support file + +;; Copyright (C) 2005, 2007, 2008, 2009 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Generated from srecode-template.wy in the CEDET repository. + +;;; Code: + +(require 'semantic/lex) + + +;;; Prologue +;; + +;;; Declarations +;; +(defconst srecode-template-wy--keyword-table + (semantic-lex-make-keyword-table + '(("set" . SET) + ("show" . SHOW) + ("macro" . MACRO) + ("context" . CONTEXT) + ("template" . TEMPLATE) + ("sectiondictionary" . SECTIONDICTIONARY) + ("prompt" . PROMPT) + ("default" . DEFAULT) + ("defaultmacro" . DEFAULTMACRO) + ("read" . READ) + ("bind" . BIND)) + '(("bind" summary "bind \"<letter>\"") + ("read" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]") + ("defaultmacro" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]") + ("default" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]") + ("prompt" summary "prompt <symbol> \"Describe Symbol: \" [default[macro] <lispsym>|\"valuetext\"] [read <lispsym>]") + ("sectiondictionary" summary "sectiondictionary <name>\\n <dictionary entries>") + ("template" summary "template <name>\\n <template definition>") + ("context" summary "context <name>") + ("macro" summary "... macro \"string\" ...") + ("show" summary "show <name> ; to show a section") + ("set" summary "set <name> <value>"))) + "Table of language keywords.") + +(defconst srecode-template-wy--token-table + (semantic-lex-make-type-table + '(("number" + (number)) + ("string" + (string)) + ("symbol" + (symbol)) + ("property" + (property)) + ("separator" + (TEMPLATE_BLOCK . "^----")) + ("newline" + (newline))) + '(("number" :declared t) + ("string" :declared t) + ("symbol" :declared t) + ("property" :declared t) + ("newline" :declared t) + ("punctuation" syntax "\\s.+") + ("punctuation" :declared t) + ("keyword" :declared t))) + "Table of lexical tokens.") + +(defconst srecode-template-wy--parse-table + (progn + (eval-when-compile + (require 'semantic/wisent/comp)) + (wisent-compile-grammar + '((SET SHOW MACRO CONTEXT TEMPLATE SECTIONDICTIONARY PROMPT DEFAULT DEFAULTMACRO READ BIND newline TEMPLATE_BLOCK property symbol string number) + nil + (template_file + ((newline) + nil) + ((context)) + ((prompt)) + ((variable)) + ((template))) + (context + ((CONTEXT symbol newline) + (wisent-raw-tag + (semantic-tag $2 'context)))) + (prompt + ((PROMPT symbol string opt-default-fcn opt-read-fcn newline) + (wisent-raw-tag + (semantic-tag $2 'prompt :text + (read $3) + :default $4 :read $5)))) + (opt-default-fcn + ((DEFAULT symbol) + (progn + (read $2))) + ((DEFAULT string) + (progn + (read $2))) + ((DEFAULTMACRO string) + (progn + (cons 'macro + (read $2)))) + (nil nil)) + (opt-read-fcn + ((READ symbol) + (progn + (read $2))) + (nil nil)) + (variable + ((SET symbol insertable-string-list newline) + (wisent-raw-tag + (semantic-tag-new-variable $2 nil $3))) + ((SHOW symbol newline) + (wisent-raw-tag + (semantic-tag-new-variable $2 nil t)))) + (insertable-string-list + ((insertable-string) + (list $1)) + ((insertable-string-list insertable-string) + (append $1 + (list $2)))) + (insertable-string + ((string) + (read $1)) + ((MACRO string) + (cons 'macro + (read $2)))) + (template + ((TEMPLATE templatename opt-dynamic-arguments newline opt-string opt-section-dictionaries TEMPLATE_BLOCK newline opt-bind) + (wisent-raw-tag + (semantic-tag-new-function $2 nil $3 :documentation $5 :code $7 :dictionaries $6 :binding $9)))) + (templatename + ((symbol)) + ((PROMPT)) + ((CONTEXT)) + ((TEMPLATE)) + ((DEFAULT)) + ((MACRO)) + ((DEFAULTMACRO)) + ((READ)) + ((SET))) + (opt-dynamic-arguments + ((property opt-dynamic-arguments) + (cons $1 $2)) + (nil nil)) + (opt-string + ((string newline) + (read $1)) + (nil nil)) + (opt-section-dictionaries + (nil nil) + ((section-dictionary-list))) + (section-dictionary-list + ((one-section-dictionary) + (list $1)) + ((section-dictionary-list one-section-dictionary) + (append $1 + (list $2)))) + (one-section-dictionary + ((SECTIONDICTIONARY string newline variable-list) + (cons + (read $2) + $4))) + (variable-list + ((variable) + (wisent-cook-tag $1)) + ((variable-list variable) + (append $1 + (wisent-cook-tag $2)))) + (opt-bind + ((BIND string newline) + (read $2)) + (nil nil))) + '(template_file))) + "Parser table.") + +(defun srecode-template-wy--install-parser () + "Setup the Semantic Parser." + (semantic-install-function-overrides + '((parse-stream . wisent-parse-stream))) + (setq semantic-parser-name "LALR" + semantic--parse-table srecode-template-wy--parse-table + semantic-debug-parser-source "srecode-template.wy" + semantic-flex-keywords-obarray srecode-template-wy--keyword-table + semantic-lex-types-obarray srecode-template-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-keyword-type-analyzer srecode-template-wy--<keyword>-keyword-analyzer + "keyword analyzer for <keyword> tokens." + "\\(\\sw\\|\\s_\\)+") + +(define-lex-regex-type-analyzer srecode-template-wy--<symbol>-regexp-analyzer + "regexp analyzer for <symbol> tokens." + "\\(\\sw\\|\\s_\\)+" + nil + 'symbol) + +(define-lex-sexp-type-analyzer srecode-template-wy--<string>-sexp-analyzer + "sexp analyzer for <string> tokens." + "\\s\"" + 'string) + +(define-lex-regex-type-analyzer srecode-template-wy--<number>-regexp-analyzer + "regexp analyzer for <number> tokens." + semantic-lex-number-expression + nil + 'number) + +(define-lex-string-type-analyzer srecode-template-wy--<punctuation>-string-analyzer + "string analyzer for <punctuation> tokens." + "\\s.+" + nil + 'punctuation) + + +;;; Epilogue +;; +(define-lex-simple-regex-analyzer srecode-template-property-analyzer + "Detect and create a dynamic argument properties." + ":\\(\\w\\|\\s_\\)*" 'property 0) + +(define-lex-regex-analyzer srecode-template-separator-block + "Detect and create a template quote block." + "^----\n" + (semantic-lex-push-token + (semantic-lex-token + 'TEMPLATE_BLOCK + (match-end 0) + (semantic-lex-unterminated-syntax-protection 'TEMPLATE_BLOCK + (goto-char (match-end 0)) + (re-search-forward "^----$") + (match-beginning 0)))) + (setq semantic-lex-end-point (point))) + + +(define-lex wisent-srecode-template-lexer + "Lexical analyzer that handles SRecode Template buffers. +It ignores whitespace, newlines and comments." + semantic-lex-newline + semantic-lex-ignore-whitespace + semantic-lex-ignore-newline + semantic-lex-ignore-comments + srecode-template-separator-block + srecode-template-wy--<keyword>-keyword-analyzer + srecode-template-property-analyzer + srecode-template-wy--<symbol>-regexp-analyzer + srecode-template-wy--<number>-regexp-analyzer + srecode-template-wy--<string>-sexp-analyzer + srecode-template-wy--<punctuation>-string-analyzer + semantic-lex-default-action + ) + +(provide 'srecode/srt-wy) + +;;; srecode/srt-wy.el ends here diff --git a/lisp/cedet/srecode/srt.el b/lisp/cedet/srecode/srt.el new file mode 100644 index 00000000000..7f438ae5951 --- /dev/null +++ b/lisp/cedet/srecode/srt.el @@ -0,0 +1,106 @@ +;;; srecode/srt.el --- argument handlers for SRT files + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Filters for SRT files, the Semantic Recoder template files. + +;;; Code: + +(require 'eieio) +(require 'srecode/dictionary) +(require 'srecode/insert) + +(defvar srecode-read-variable-name-history nil + "History for `srecode-read-variable-name'.") + +(defun srecode-read-variable-name (prompt &optional initial hist default) + "Read in the name of a declaired variable in the current SRT file. +PROMPT is the prompt to use. +INITIAL is the initial string. +HIST is the history value, otherwise `srecode-read-variable-name-history' + is used. +DEFAULT is the default if RET is hit." + (let* ((newdict (srecode-create-dictionary)) + (currfcn (semantic-current-tag)) + ) + (srecode-resolve-argument-list + (mapcar 'read + (semantic-tag-get-attribute currfcn :arguments)) + newdict) + + (with-slots (namehash) newdict + (completing-read prompt namehash nil nil initial + (or hist 'srecode-read-variable-name-history) + default)) + )) + +(defvar srecode-read-major-mode-history nil + "History for `srecode-read-variable-name'.") + +(defun srecode-read-major-mode-name (prompt &optional initial hist default) + "Read in the name of a desired `major-mode'. +PROMPT is the prompt to use. +INITIAL is the initial string. +HIST is the history value, otherwise `srecode-read-variable-name-history' + is used. +DEFAULT is the default if RET is hit." + (completing-read prompt obarray + (lambda (s) (string-match "-mode$" (symbol-name s))) + nil initial (or hist 'srecode-read-major-mode-history)) + ) + +(defun srecode-semantic-handle-:srt (dict) + "Add macros into the dictionary DICT based on the current SRT file. +Adds the following: +ESCAPE_START - This files value of escape_start +ESCAPE_END - This files value of escape_end +MODE - The mode of this buffer. If not declared yet, guess." + (let* ((es (semantic-find-first-tag-by-name "escape_start" (current-buffer))) + (ee (semantic-find-first-tag-by-name "escape_end" (current-buffer))) + (mode-var (semantic-find-first-tag-by-name "mode" (current-buffer))) + (mode (if mode-var + (semantic-tag-variable-default mode-var) + nil)) + ) + (srecode-dictionary-set-value dict "ESCAPE_START" + (if es + (car (semantic-tag-variable-default es)) + "{{")) + (srecode-dictionary-set-value dict "ESCAPE_END" + (if ee + (car (semantic-tag-variable-default ee)) + "}}")) + (when (not mode) + (let* ((fname (file-name-nondirectory + (buffer-file-name (current-buffer)))) + ) + (when (string-match "-\\(\\w+\\)\\.srt" fname) + (setq mode (concat (match-string 1 fname) "-mode"))))) + + (when mode + (srecode-dictionary-set-value dict "MAJORMODE" mode)) + + )) + +(provide 'srecode/srt) + +;;; srecode/srt.el ends here diff --git a/lisp/cedet/srecode/table.el b/lisp/cedet/srecode/table.el new file mode 100644 index 00000000000..2591983c7a6 --- /dev/null +++ b/lisp/cedet/srecode/table.el @@ -0,0 +1,248 @@ +;;; srecode/table.el --- Tables of Semantic Recoders + +;; Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Semantic Recoder tables manage lists of templates and the major +;; modes they are associated with. +;; + +(require 'eieio) +(require 'eieio-base) +(require 'mode-local) +(require 'srecode) + +(declare-function srecode-load-tables-for-mode "srecode/find") + +;;; Code: + +;;; TEMPLATE TABLE +;; +(defclass srecode-template-table () + (;; + ;; Raw file tracking + ;; + (file :initarg :file + :type string + :documentation + "The name of the file this table was built from.") + (filesize :initarg :filesize + :type number + :documentation + "The size of the file when it was parsed.") + (filedate :initarg :filedate + :type cons + :documentation + "Date from the inode of the file when it was last edited. +Format is from the `file-attributes' function.") + (major-mode :initarg :major-mode + :documentation + "The major mode this table of templates is associated with.") + ;; + ;; Template file sorting data + ;; + (application :initarg :application + :type symbol + :documentation + "Tracks the name of the application these templates belong to. +If this is nil, then this template table belongs to a set of generic +templates that can be used with no additional dictionary values. +When it is non-nil, it is assumed the template macros need specialized +Emacs Lisp code to fill in the dictoinary.") + (priority :initarg :priority + :type number + :documentation + "For file of this Major Mode, what is the priority of this file. +When there are multiple template files with similar names, templates with +the highest priority are scanned last, allowing them to override values in +previous template files.") + ;; + ;; Parsed Data from the template file + ;; + (templates :initarg :templates + :type list + :documentation + "The list of templates compiled into this table.") + (namehash :initarg :namehash + :documentation + "Hash table containing the names of all the templates.") + (contexthash :initarg :contexthash + :documentation + "") + (variables :initarg :variables + :documentation + "AList of variables. +These variables are used to initialize dictionaries.") + ) + "Semantic recoder template table. +A Table contains all templates from a single .srt file. +Tracks various lookup hash tables.") + +;;; MODE TABLE +;; +(defvar srecode-mode-table-list nil + "List of all the SRecode mode table classes that have been built.") + +(defclass srecode-mode-table (eieio-instance-tracker) + ((tracking-symbol :initform 'srecode-mode-table-list) + (major-mode :initarg :major-mode + :documentation + "Table of template tables for this major-mode.") + (tables :initarg :tables + :documentation + "All the tables that have been defined for this major mode.") + ) + "Track template tables for a particular major mode. +Tracks all the template-tables for a specific major mode.") + +(defun srecode-get-mode-table (mode) + "Get the SRecoder mode table for the major mode MODE. +Optional argument SOFT indicates to not make a new one if a table +was not found." + (let ((ans nil)) + (while (and (not ans) mode) + (setq ans (eieio-instance-tracker-find + mode 'major-mode 'srecode-mode-table-list) + mode (get-mode-local-parent mode))) + ans)) + +(defun srecode-make-mode-table (mode) + "Get the SRecoder mode table for the major mode MODE." + (let ((old (eieio-instance-tracker-find + mode 'major-mode 'srecode-mode-table-list))) + (if old + old + (let* ((ms (if (stringp mode) mode (symbol-name mode))) + (new (srecode-mode-table ms + :major-mode mode + :tables nil))) + ;; Save this new mode table in that mode's variable. + (eval `(setq-mode-local ,mode srecode-table ,new)) + + new)))) + +(defmethod srecode-mode-table-find ((mt srecode-mode-table) file) + "Look in the mode table MT for a template table from FILE. +Return nil if there was none." + (object-assoc file 'file (oref mt tables))) + +(defun srecode-mode-table-new (mode file &rest init) + "Create a new template table for MODE in FILE. +INIT are the initialization parametrs for the new template table." + (let* ((mt (srecode-make-mode-table mode)) + (old (srecode-mode-table-find mt file)) + (attr (file-attributes file)) + (new (apply 'srecode-template-table + (file-name-nondirectory file) + :file file + :filesize (nth 7 attr) + :filedate (nth 5 attr) + :major-mode mode + init + ))) + ;; Whack the old table. + (when old (object-remove-from-list mt 'tables old)) + ;; Add the new table + (object-add-to-list mt 'tables new) + ;; Sort the list in reverse order. When other routines + ;; go front-to-back, the highest priority items are put + ;; into the search table first, allowing lower priority items + ;; to be the items found in the search table. + (object-sort-list mt 'tables (lambda (a b) + (> (oref a :priority) + (oref b :priority)))) + ;; Return it. + new)) + +(defun object-sort-list (object slot predicate) + "Sort the items in OBJECT's SLOT. +Use PREDICATE is the same as for the `sort' function." + (when (slot-boundp object slot) + (when (listp (eieio-oref object slot)) + (eieio-oset object slot (sort (eieio-oref object slot) predicate))))) + +;;; DEBUG +;; +;; Dump out information about the current srecoder compiled templates. +;; +(defun srecode-dump-templates (mode) + "Dump a list of the current templates for MODE." + (interactive "sMode: ") + (require 'srecode/find) + (let ((modesym (cond ((string= mode "") + major-mode) + ((not (string-match "-mode" mode)) + (intern-soft (concat mode "-mode"))) + (t + (intern-soft mode))))) + (srecode-load-tables-for-mode modesym) + (let ((tmp (srecode-get-mode-table modesym)) + ) + (if (not tmp) + (error "No table found for mode %S" modesym)) + (with-output-to-temp-buffer "*SRECODE DUMP*" + (srecode-dump tmp)) + ))) + +(defmethod srecode-dump ((tab srecode-mode-table)) + "Dump the contents of the SRecode mode table TAB." + (princ "MODE TABLE FOR ") + (princ (oref tab :major-mode)) + (princ "\n--------------------------------------------\n\nNumber of tables: ") + (let ((subtab (oref tab :tables))) + (princ (length subtab)) + (princ "\n\n") + (while subtab + (srecode-dump (car subtab)) + (setq subtab (cdr subtab))) + )) + +(defmethod srecode-dump ((tab srecode-template-table)) + "Dump the contents of the SRecode template table TAB." + (princ "Template Table for ") + (princ (object-name-string tab)) + (princ "\nPriority: ") + (prin1 (oref tab :priority)) + (when (oref tab :application) + (princ "\nApplication: ") + (princ (oref tab :application))) + (princ "\n\nVariables:\n") + (let ((vars (oref tab variables))) + (while vars + (princ (car (car vars))) + (princ "\t") + (if (< (length (car (car vars))) 9) + (princ "\t")) + (prin1 (cdr (car vars))) + (princ "\n") + (setq vars (cdr vars)))) + (princ "\n\nTemplates:\n") + (let ((temp (oref tab templates))) + (while temp + (srecode-dump (car temp)) + (setq temp (cdr temp)))) + ) + + +(provide 'srecode/table) + +;;; srecode/table.el ends here + diff --git a/lisp/cedet/srecode/template.el b/lisp/cedet/srecode/template.el new file mode 100644 index 00000000000..fee960f5852 --- /dev/null +++ b/lisp/cedet/srecode/template.el @@ -0,0 +1,69 @@ +;;; srecode-template.el --- SRecoder template language parser support. + +;;; Copyright (C) 2005, 2007, 2008 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Parser setup for the semantic recoder template parser. + +;;; Code: +(require 'semantic) +(require 'semantic/ctxt) +(require 'semantic/wisent) +(require 'srecode/srt-wy) + +(define-mode-local-override semantic-tag-components + srecode-template-mode (tag) + "Return sectiondictionary tags." + (when (semantic-tag-of-class-p tag 'function) + (let ((dicts (semantic-tag-get-attribute tag :dictionaries)) + (ans nil)) + (while dicts + (setq ans (append ans (cdr (car dicts)))) + (setq dicts (cdr dicts))) + ans) + )) + +(defun srecode-template-setup-parser () + "Setup buffer for parse." + (srecode-template-wy--install-parser) + + (setq + ;; Lexical Analysis + semantic-lex-analyzer 'wisent-srecode-template-lexer + ;; Parsing + ;; Environment + semantic-imenu-summary-function 'semantic-format-tag-name + imenu-create-index-function 'semantic-create-imenu-index + semantic-command-separation-character "\n" + semantic-lex-comment-regex ";;" + ;; Speedbar + semantic-symbol->name-assoc-list + '((function . "Template") + (variable . "Variable") + ) + ;; Navigation + senator-step-at-tag-classes '(function variable) + )) + +;;;;###autoload +(add-hook 'srecode-template-mode-hook 'srecode-template-setup-parser) + +(provide 'srecode/template) + +;;; srecode/template.el ends here diff --git a/lisp/cedet/srecode/texi.el b/lisp/cedet/srecode/texi.el new file mode 100644 index 00000000000..6c223f1cc5a --- /dev/null +++ b/lisp/cedet/srecode/texi.el @@ -0,0 +1,282 @@ +;;; srecode-texi.el --- Srecode texinfo support. + +;; Copyright (C) 2008, 2009 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <eric@siege-engine.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Texinfo semantic recoder support. +;; +;; Contains some handlers, and a few simple texinfo srecoder applications. + +(require 'semantic) +(require 'semantic/texi) +(require 'srecode/semantic) + +;;; Code: + +(defun srecode-texi-add-menu (newnode) + "Add an item into the current menu. Add @node statements as well. +Argument NEWNODE is the name of the new node." + (interactive "sName of new node: ") + (srecode-load-tables-for-mode major-mode) + (semantic-fetch-tags) + (let ((currnode (reverse (semantic-find-tag-by-overlay))) + (nodebounds nil)) + (when (not currnode) + (error "Cannot find node to put menu item into")) + (setq currnode (car currnode)) + (setq nodebounds (semantic-tag-texi-section-text-bounds currnode)) + ;; Step 1: + ;; Limit search within this node. + ;; Step 2: + ;; Find the menu. If there isn't one, add one to the end. + ;; Step 3: + ;; Add new item to end of menu list. + ;; Step 4: + ;; Find correct node new item should show up after, and stick + ;; the new node there. + (if (string= (semantic-texi-current-environment) "menu") + ;; We are already in a menu, so insert the new item right here. + (beginning-of-line) + ;; Else, try to find a menu item to append to. + (goto-char (car nodebounds)) + (if (not (re-search-forward "^@menu" (car (cdr nodebounds)) t)) + (progn + (goto-char (car (cdr nodebounds))) + (if (not (y-or-n-p "Add menu here? ")) + (error "Abort")) + (srecode-insert "declaration:menu")) + ;; Else, find the end + (re-search-forward "@end menu") + (beginning-of-line))) + ;; At this point, we are in a menu... or not. + ;; If we are, do stuff, else error. + (when (string= (semantic-texi-current-environment) "menu") + (let ((menuname newnode) + (returnpoint nil)) + (srecode-insert "declaration:menuitem" "NAME" menuname) + (set-mark (point)) + (setq returnpoint (make-marker)) + ;; Update the bound since we added text + (setq nodebounds (semantic-tag-texi-section-text-bounds currnode)) + (beginning-of-line) + (forward-char -1) + (beginning-of-line) + (let ((end nil)) + (if (not (looking-at "\\* \\([^:]+\\):")) + (setq end (car (cdr nodebounds))) + (let* ((nname (match-string 1)) + (tag + (semantic-deep-find-tags-by-name nname (current-buffer)))) + (when tag + (setq end (semantic-tag-end (car tag)))) + )) + (when (not end) + (goto-char returnpoint) + (error "Could not find location for new node" )) + (when end + (goto-char end) + (when (bolp) (forward-char -1)) + (insert "\n") + (if (eq (semantic-current-tag) currnode) + (srecode-insert "declaration:subnode" "NAME" menuname) + (srecode-insert "declaration:node" "NAME" menuname)) + ) + ))) + )) + +;;;###autoload +(defun srecode-semantic-handle-:texi (dict) + "Add macros into the dictionary DICT based on the current texinfo file. +Adds the following: + LEVEL - chapter, section, subsection, etc + NEXTLEVEL - One below level" + + ;; LEVEL and NEXTLEVEL calculation + (semantic-fetch-tags) + (let ((tags (reverse (semantic-find-tag-by-overlay))) + (level nil)) + (while (and tags (not (semantic-tag-of-class-p (car tags) 'section))) + (setq tags (cdr tags))) + (when tags + (save-excursion + (goto-char (semantic-tag-start (car tags))) + (when (looking-at "@node") + (forward-line 1) + (beginning-of-line)) + (when (looking-at "@\\(\\w+\\)") + (setq level (match-string 1)) + ))) + (srecode-dictionary-set-value dict "LEVEL" (or level "chapter")) + (let ((nl (assoc level '( ( nil . "top" ) + ("top" . "chapter") + ("chapter" . "section") + ("section" . "subsection") + ("subsection" . "subsubsection") + ("subsubsection" . "subsubsection") + )))) + (srecode-dictionary-set-value dict "NEXTLEVEL" (cdr nl)))) + ) + +;;;###autoload +(defun srecode-semantic-handle-:texitag (dict) + "Add macros into the dictionary DICT based on the current :tag file. +Adds the following: + TAGDOC - Texinfo formatted doc string for :tag." + + ;; If we also have a TAG, what is the doc? + (let ((tag (srecode-dictionary-lookup-name dict "TAG")) + (doc nil) + ) + + ;; If the user didn't apply :tag, then do so now. + (when (not tag) + (srecode-semantic-handle-:tag dict)) + + (setq tag (srecode-dictionary-lookup-name dict "TAG")) + + (when (not tag) + (error "No tag to insert for :texitag template argument")) + + ;; Extract the tag out of the compound object. + (setq tag (oref tag :prime)) + + ;; Extract the doc string + (setq doc (semantic-documentation-for-tag tag)) + + (when doc + (srecode-dictionary-set-value dict "TAGDOC" + (srecode-texi-massage-to-texinfo + tag (semantic-tag-buffer tag) + doc))) + )) + +;;; OVERRIDES +;; +;; Override some semantic and srecode features with texi specific +;; versions. + +(define-mode-local-override semantic-insert-foreign-tag + texinfo-mode (foreign-tag) + "Insert TAG from a foreign buffer in TAGFILE. +Assume TAGFILE is a source buffer, and create a documentation +thingy from it using the `document' tool." + (let ((srecode-semantic-selected-tag foreign-tag)) + ;; @todo - choose of the many types of tags to insert, + ;; or put all that logic into srecode. + (srecode-insert "declaration:function"))) + + + +;;; Texinfo mangling. + +(define-overloadable-function srecode-texi-texify-docstring + (docstring) + "Texify the doc string DOCSTRING. +Takes plain text formatting that may exist, and converts it to +using TeXinfo formatting.") + +(defun srecode-texi-texify-docstring-default (docstring) + "Texify the doc string DOCSTRING. +Takes a few very generic guesses as to what the formatting is." + (let ((case-fold-search nil) + (start 0)) + (while (string-match + "\\(^\\|[^{]\\)\\<\\([A-Z0-9_-]+\\)\\>\\($\\|[^}]\\)" + docstring start) + (let ((ms (match-string 2 docstring))) + ;(when (eq mode 'emacs-lisp-mode) + ; (setq ms (downcase ms))) + + (when (not (or (string= ms "A") + (string= ms "a") + )) + (setq docstring (concat (substring docstring 0 (match-beginning 2)) + "@var{" + ms + "}" + (substring docstring (match-end 2)))))) + (setq start (match-end 2))) + ;; Return our modified doc string. + docstring)) + +(defun srecode-texi-massage-to-texinfo (tag buffer string) + "Massage TAG's documentation from BUFFER as STRING. +This is to take advantage of TeXinfo's markup symbols." + (save-excursion + (if buffer + (progn (set-buffer buffer) + (srecode-texi-texify-docstring string)) + ;; Else, no buffer, so lets do something else + (with-mode-local texinfo-mode + (srecode-texi-texify-docstring string))))) + +(define-mode-local-override srecode-texi-texify-docstring emacs-lisp-mode + (string) + "Take STRING, (a normal doc string), and convert it into a texinfo string. +For instances where CLASS is the class being referenced, do not Xref +that class. + + `function' => @dfn{function} + `variable' => @code{variable} + `class' => @code{class} @xref{class} + `unknown' => @code{unknonwn} + \"text\" => ``text'' + 'quoteme => @code{quoteme} + non-nil => non-@code{nil} + t => @code{t} + :tag => @code{:tag} + [ stuff ] => @code{[ stuff ]} + Key => @kbd{Key} (key is C\\-h, M\\-h, SPC, RET, TAB and the like) + ... => @dots{}" + (while (string-match "`\\([-a-zA-Z0-9<>.]+\\)'" string) + (let* ((vs (substring string (match-beginning 1) (match-end 1))) + (v (intern-soft vs))) + (setq string + (concat + (replace-match (concat + (if (fboundp v) + "@dfn{" "@code{") + vs "}") + nil t string))))) + (while (string-match "\\( \\|^\\)\\(nil\\|t\\|'[-a-zA-Z0-9]+\\|:[-a-zA-Z0-9]+\\)\\([. ,]\\|$\\)" string) + (setq string (replace-match "@code{\\2}" t nil string 2))) + (while (string-match "\\( \\|^\\)\\(\\(non-\\)\\(nil\\)\\)\\([. ,]\\|$\\)" string) + (setq string (replace-match "\\3@code{\\4}" t nil string 2))) + (while (string-match "\\( \\|^\\)\\(\\[[^]]+\\]\\)\\( \\|$\\)" string) + (setq string (replace-match "@code{\\2}" t nil string 2))) + (while (string-match "\\( \\|^\\)\\(\\(\\(C-\\|M-\\|S-\\)+\\([^ \t\n]\\|RET\\|SPC\\|TAB\\)\\)\\|\\(RET\\|SPC\\|TAB\\)\\)\\( \\|\\s.\\|$\\)" string) + (setq string (replace-match "@kbd{\\2}" t nil string 2))) + (while (string-match "\"\\(.+\\)\"" string) + (setq string (replace-match "``\\1''" t nil string 0))) + (while (string-match "\\.\\.\\." string) + (setq string (replace-match "@dots{}" t nil string 0))) + ;; Also do base docstring type. + (srecode-texi-texify-docstring-default string)) + +(provide 'srecode/texi) + +;; Local variables: +;; generated-autoload-file: "loaddefs.el" +;; generated-autoload-feature: srecode/loaddefs +;; generated-autoload-load-name: "srecode/texi" +;; End: + +;;; srecode/texi.el ends here |